static void maybe_read(struct thread *thread) { obj_t *fp = thread->fp; int fd = fixnum_value(fp[-9]); int nfound, res; obj_t *old_sp; nfound = input_available(fd); if (nfound < 0) { old_sp = pop_linkage(thread); thread->sp = old_sp + 2; old_sp[0] = obj_False; old_sp[1] = make_fixnum(errno); do_return(thread, old_sp, old_sp); } else if (nfound == 0) wait_for_input(thread, fd, maybe_read); else { res = mindy_read(fd, (char *)(buffer_data(fp[-8]) + fixnum_value(fp[-7])), fixnum_value(fp[-6])); results(thread, pop_linkage(thread), res, make_fixnum(res)); } }
static void maybe_write(struct thread *thread) { obj_t *fp = thread->fp; int fd = fixnum_value(fp[-9]); int nfound, res; obj_t *old_sp; nfound = output_writable(fd); if (nfound < 0) { if (errno != EINTR) { old_sp = pop_linkage(thread); thread->sp = old_sp + 2; old_sp[0] = obj_False; old_sp[1] = make_fixnum(errno); do_return(thread, old_sp, old_sp); } else { wait_for_output(thread, fd, maybe_write); } } else if (nfound == 0) wait_for_output(thread, fd, maybe_write); else { res = write(fd, buffer_data(fp[-8]) + fixnum_value(fp[-7]), fixnum_value(fp[-6])); results(thread, pop_linkage(thread), res, make_fixnum(res)); } }
// ### digit-char-p char &optional radix => weight Value CL_digit_char_p(unsigned int numargs, Value args[]) { if (numargs < 1 || numargs > 2) return wrong_number_of_arguments(S_digit_char_p, numargs, 1, 2); BASE_CHAR c = char_value(args[0]); int radix; if (numargs == 2) radix = check_index(args[1], 2, 36); else radix = 10; if (c >= '0') { int n = c - '0'; if (radix <= 10) return (n < radix) ? make_fixnum(n) : NIL; if (n < 10) return make_fixnum(n); if (c >= 'A') { // A-Z n -= 7; if (n >= 10 && n < radix) return make_fixnum(n); if (c >= 'a') { // a-z n -= 32; if (n >= 10 && n < radix) return make_fixnum(n); } } } return NIL; }
bool Array_T::typep(Value type) const { if (consp(type)) { Value type_specifier_atom = xcar(type); Value tail = xcdr(type); if (type_specifier_atom == S_array) { if (consp(tail)) { Value element_type = xcar(tail); tail = xcdr(tail); if (element_type == UNSPECIFIED || ::equal(element_type, _element_type) || (_element_type == S_bit && ::equal(element_type, BIT_TYPE))) { if (tail == NIL) return true; if (::length(tail) == 1) { Value dimensions = xcar(tail); if (dimensions == UNSPECIFIED) return true; if (dimensions == make_fixnum(_rank)) return true; if (consp(dimensions)) { if (::length(dimensions) == _rank) { unsigned long i = 0; while (dimensions != NIL) { Value dim = xcar(dimensions); if (dim == UNSPECIFIED || dim == make_fixnum(_dimensions[i])) ; // ok else return false; dimensions = xcdr(dimensions); ++i; } return true; } } } } } } } else if (symbolp(type)) { if (type == S_array || type == S_atom || type == T) return true; } else { if (type == C_array || type == C_t) return true; } return false; }
bool SimpleArray_UB16_1::typep(Value type) const { if (consp(type)) { Value type_specifier_atom = xcar(type); Value tail = xcdr(type); if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array) { if (consp(tail)) { Value element_type = xcar(tail); if (element_type == UNSPECIFIED) ; // ok else { Value upgraded_element_type = upgraded_array_element_type(element_type); if (::equal(upgraded_element_type, UB16_TYPE)) ; // ok else if (::equal(upgraded_element_type, list3(S_integer, FIXNUM_ZERO, make_fixnum(65535)))) ; // ok else if (::equal(upgraded_element_type, list3(S_integer, FIXNUM_ZERO, list1(make_fixnum(65536))))) ; // ok else return false; } tail = xcdr(tail); if (tail == NIL) return true; if (cdr(tail) == NIL) // i.e. length(tail) == 1 { Value dimensions = xcar(tail); if (dimensions == UNSPECIFIED) return true; if (dimensions == FIXNUM_ONE) return true; if (::equal(dimensions, list1(UNSPECIFIED))) return true; if (::equal(dimensions, list1(make_fixnum(_capacity)))) return true; } } } } else if (symbolp(type)) { if (type == S_vector || type == S_sequence || type == S_simple_array || type == S_array || type == S_atom || type == T) return true; } else { if (type == C_vector || type == C_array || type == C_sequence || type == C_t) return true; } return false; }
/* * DEV can be either a printer or devmode */ static Lisp_Object print_dialog_worker (Lisp_Object dev, DWORD flags) { Lisp_Devmode *ldm = decode_devmode (dev); PRINTDLGW pd; memset (&pd, 0, sizeof (pd)); pd.lStructSize = sizeof (pd); pd.hwndOwner = mswindows_get_selected_frame_hwnd (); pd.hDevMode = devmode_to_hglobal (ldm); pd.Flags = flags | PD_USEDEVMODECOPIESANDCOLLATE; pd.nMinPage = 0; pd.nMaxPage = 0xFFFF; if (!qxePrintDlg (&pd)) { global_free_2_maybe (pd.hDevNames, pd.hDevMode); return Qnil; } handle_devmode_changes (ldm, pd.hDevNames, pd.hDevMode); /* Finally, build the resulting plist */ { Lisp_Object result = Qnil; struct gcpro gcpro1; GCPRO1 (result); /* Do consing in reverse order. Number of copies */ result = Fcons (Qcopies, Fcons (make_fixnum (pd.nCopies), result)); /* Page range */ if (pd.Flags & PD_PAGENUMS) { result = Fcons (Qto_page, Fcons (make_fixnum (pd.nToPage), result)); result = Fcons (Qfrom_page, Fcons (make_fixnum (pd.nFromPage), result)); result = Fcons (Qselected_page_button, Fcons (Qpages, result)); } else if (pd.Flags & PD_SELECTION) result = Fcons (Qselected_page_button, Fcons (Qselection, result)); else result = Fcons (Qselected_page_button, Fcons (Qall, result)); /* Device name */ result = Fcons (Qname, Fcons (ldm->printer_name, result)); UNGCPRO; global_free_2_maybe (pd.hDevNames, pd.hDevMode); return result; } }
void handle_single_step_trap (os_context_t *context, int kind, int register_offset) { fake_foreign_function_call(context); #ifndef LISP_FEATURE_WIN32 thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); #endif funcall2(StaticSymbolFunction(HANDLE_SINGLE_STEP_TRAP), make_fixnum(kind), make_fixnum(register_offset)); undo_fake_foreign_function_call(context); /* blocks signals again */ }
Value Array_T::dimensions() const { Value result = NIL; for (unsigned long i = _rank; i-- > 0;) result = make_cons(make_fixnum(_dimensions[i]), result); return result; }
// ### %read-from-string string eof-error-p eof-value start end preserve-whitespace // => object, position Value SYS_read_from_string_internal(Value arg1, Value arg2, Value arg3, Value arg4, Value arg5, Value arg6) { AbstractString * string = check_string(arg1); bool eof_error_p = (arg2 != NIL); bool preserve_whitespace = (arg6 != NIL); INDEX start; if (arg4 != NIL) start = check_index(arg4); else start = 0; INDEX end; if (arg5 != NIL) end = check_index(arg5); else end = string->length(); StringInputStream * in = new StringInputStream(string, start, end); Thread * const thread = current_thread(); Value result; Readtable * rt = check_readtable(thread->symbol_value(S_current_readtable)); if (preserve_whitespace) result = stream_read_preserving_whitespace(make_value(in), eof_error_p, arg3, false, thread, rt); else result = stream_read(make_value(in), eof_error_p, arg3, false, thread, rt); return thread->set_values(result, make_fixnum(in->offset())); }
static Lisp_Object msprinter_device_system_metrics (struct device *d, enum device_metrics m) { switch (m) { /* Device sizes - pixel and mm */ #define FROB(met, index1, index2) \ case DM_##met: \ return build_devicecaps_cons \ (DEVICE_MSPRINTER_HDC (d), index1, index2); FROB (size_device, PHYSICALWIDTH, PHYSICALHEIGHT); FROB (size_device_mm, HORZSIZE, VERTSIZE); FROB (size_workspace, HORZRES, VERTRES); FROB (offset_workspace, PHYSICALOFFSETX, PHYSICALOFFSETY); FROB (device_dpi, LOGPIXELSX, LOGPIXELSY); #undef FROB case DM_num_bit_planes: /* this is what X means by bitplanes therefore we ought to be consistent. num planes is always 1 under mswindows and therefore useless */ return make_fixnum (GetDeviceCaps (DEVICE_MSPRINTER_HDC (d), BITSPIXEL)); case DM_num_color_cells: /* Printers are non-palette devices */ case DM_slow_device: /* Animation would be a really bad idea */ case DM_security: /* Not provided by windows */ return Qzero; } /* Do not know such property */ return Qunbound; }
static long compute_offset(os_context_t *context, lispobj code) { if (code == NIL) return 0; else { uword_t code_start; struct code *codeptr = (struct code *)native_pointer(code); #ifdef LISP_FEATURE_HPPA uword_t pc = *os_context_pc_addr(context) & ~3; #else uword_t pc = *os_context_pc_addr(context); #endif code_start = (uword_t)codeptr + HeaderValue(codeptr->header)*sizeof(lispobj); if (pc < code_start) return 0; else { uword_t offset = pc - code_start; if (offset >= (uword_t)fixnum_value(codeptr->code_size)) return 0; else return make_fixnum(offset); } } }
obj_t vector_ref(obj_t obj, size_t index) { CHECK_OBJ(obj); CHECK(is_vector(obj), "must be vector", obj); vector_obj_t *vec = (vector_obj_t *)obj; CHECK(index < vec->v_size, "index out of range", obj, make_fixnum(index)); return *elem_addr(vec, index); }
static obj_t file_write_date(obj_t path) { struct stat buf; if (stat(string_chars(path), &buf) < 0) return obj_False; else return make_fixnum(buf.st_mtime); }
object make_integer(__mpz_struct *u) { if ((u)->_mp_size == 0) return small_fixnum(0); if (mpz_fits_slong_p(u)) { return make_fixnum(mpz_get_si(u)); } return make_bignum(u); }
Fixnum fixnum_gcd(Fixnum _n, Fixnum _m) { int n, m; n = theFIXNUM(_n); m = theFIXNUM(_m); return make_fixnum(gcd(n, m)); }
object *mul_proc(object *arguments) { long result = 1; while (!is_the_empty_list(arguments)) { result *= (car(arguments))->data.fixnum.value; arguments = cdr(arguments); } return make_fixnum(result); }
object *sub_proc(object *arguments) { long result; result = (car(arguments))->data.fixnum.value; while (!is_the_empty_list(arguments = cdr(arguments))) { result -= (car(arguments))->data.fixnum.value; } return make_fixnum(result); }
inline SimpleArray_UB32_1 * check_simple_array_ub32_1(Value value) { if (simple_array_ub32_1_p(value)) return the_simple_array_ub32_1(value); Value expected_type = list3(S_simple_array, S_unsigned_byte, list1(make_fixnum(32))); signal_type_error(value, expected_type); // Not reached. return NULL; }
obj_t make_C_procedure(C_procedure_t code, obj_t name, interval_t arg_range, obj_t env) { CHECK_OBJ(env); proc_flags_t flags = PF_COMPILED_C | PF_ARGS_EVALUATED; return make_proc(flags, (obj_t)code, name, make_fixnum(arg_range), env); }
bool SimpleString::typep(Value type) const { if (classp(type)) return (type == C_string || type == C_vector || type == C_array || type == C_sequence || type == C_t); if (symbolp(type)) return (type == S_string || type == S_base_string || type == S_simple_string || type == S_simple_base_string || type == S_vector || type == S_simple_array || type == S_array || type == S_sequence || type == S_atom || type == T); if (consp(type)) { Value type_specifier_atom = xcar(type); Value tail = xcdr(type); if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array) { if (consp(tail)) { Value element_type = xcar(tail); tail = xcdr(tail); if (element_type == UNSPECIFIED || element_type == S_character || element_type == S_base_char) { if (tail == NIL) return true; if (cdr(tail) == NIL) // i.e. length(tail) == 1 { Value dimensions = xcar(tail); if (dimensions == UNSPECIFIED) return true; if (dimensions == FIXNUM_ONE) return true; if (consp(dimensions)) { if (::length(dimensions) == 1) { Value dim = xcar(dimensions); if (dim == UNSPECIFIED || dim == make_fixnum(_capacity)) return true; } } } } } } else if (type_specifier_atom == S_string || type_specifier_atom == S_base_string || type_specifier_atom == S_simple_string || type_specifier_atom == S_simple_base_string) { Value size = car(tail); return (size == UNSPECIFIED || check_index(size) == _capacity); } } return false; }
void vector_set(obj_t obj, size_t index, obj_t elem) { CHECK_OBJ(obj); CHECK(is_vector(obj), "must be vector", obj); vector_obj_t *vec = (vector_obj_t *)obj; //XXX CHECK(is_mutable(obj), "must be mutable", pair); CHECK(index < vec->v_size, "index out of range", obj, make_fixnum(index)); MUTATE(obj); *elem_addr(vec, index) = elem; }
inline object log_op2(fixnum op,object x,object y) { enum type tx=type_of(x),ty=type_of(y); if (tx==t_fixnum && ty==t_fixnum) return make_fixnum(fixnum_log_op2(op,fix(x),fix(y))); else return maybe_replace_big(integer_log_op2(op,x,tx,y,ty)); }
static void fd_exec(obj_t self, struct thread *thread, obj_t *args) { obj_t *oldargs; oldargs = args - 1; thread->sp = args + 1; { PROCESS_INFORMATION piProcInfo; STARTUPINFO siStartInfo; SECURITY_ATTRIBUTES saAttr; int inpipes[2], outpipes[2]; HANDLE old_handles[2]; const char *command_line = string_chars(args[0]); siStartInfo.cb = sizeof(STARTUPINFO); siStartInfo.lpReserved = NULL; siStartInfo.lpReserved2 = NULL; siStartInfo.cbReserved2 = 0; siStartInfo.lpDesktop = NULL; /* pipe_setup initializes the rest of siStartInfo */ saAttr.nLength = sizeof(SECURITY_ATTRIBUTES); saAttr.bInheritHandle = true; saAttr.lpSecurityDescriptor = NULL; pipe_setup(&siStartInfo, inpipes, outpipes, old_handles); if (! CreateProcess(NULL, command_line, NULL, NULL, true, 0, NULL, NULL, &siStartInfo, &piProcInfo)) { DWORD debug_info = GetLastError(); oldargs[0] = obj_False; oldargs[1] = obj_False; } else { oldargs[0] = make_fixnum(inpipes[1]); /* fd we can write to */ oldargs[1] = make_fixnum(outpipes[0]); /* fd we can read from */ setup_input_checker(outpipes[0]); } pipe_cleanup(inpipes, outpipes, old_handles); } do_return(thread, oldargs, oldargs); }
static int plist_get_margin (Lisp_Object plist, Lisp_Object prop, int mm_p) { Lisp_Object val = Fplist_get (plist, prop, make_fixnum (mswindows_get_default_margin (prop))); if (!FIXNUMP (val)) invalid_argument ("Margin value must be an integer", val); return MulDiv (XFIXNUM (val), mm_p ? 254 : 100, 144); }
/* Add a (POS . LINE) pair to the ring, and rotate it. */ static void add_position_to_cache (struct buffer *b, Charbpos pos, EMACS_INT line) { Lisp_Object *ring = XVECTOR_DATA (LINE_NUMBER_RING (b)); int i = LINE_NUMBER_RING_SIZE - 1; /* Set the last marker in the ring to point nowhere. */ if (CONSP (ring[i])) Fset_marker (XCAR (ring[i]), Qnil, Qnil); /* Rotate the ring... */ for (; i > 0; i--) ring[i] = ring[i - 1]; /* ...and update it. */ ring[0] = Fcons (Fset_marker (Fmake_marker (), make_fixnum (pos), wrap_buffer (b)), make_fixnum (line)); }
static void fd_open(obj_t self, struct thread *thread, obj_t *args) { obj_t path = args[0]; obj_t flags = args[1]; int res; res = mindy_open(string_chars(path), fixnum_value(flags), 0666); results(thread, args-1, res, make_fixnum(res)); }
Value Function::parts() { String * description = new String(prin1_to_string()); description->append_char('\n'); Value elements = NIL; Value name = operator_name(); elements = make_cons(make_cons(make_simple_string("NAME"), name != NULL_VALUE ? name : NIL), elements); elements = make_cons(make_cons(make_simple_string("ARITY"), make_fixnum(arity())), elements); elements = make_cons(make_cons(make_simple_string("MINARGS"), make_fixnum(minargs())), elements); elements = make_cons(make_cons(make_simple_string("MAXARGS"), make_fixnum(maxargs())), elements); return current_thread()->set_values(make_value(description), T, CL_nreverse(elements)); }
lispobj alloc_string(const char *str) { int len = strlen(str); lispobj result = alloc_vector(type_SimpleString, len + 1, 8); struct vector *vec = (struct vector *) PTR(result); vec->length = make_fixnum(len); strcpy((char *) vec->data, str); return result; }
static void fd_seek(obj_t self, struct thread *thread, obj_t *args) { obj_t fd = args[0]; obj_t offset = args[1]; obj_t whence = args[2]; off_t res; res = lseek(fixnum_value(fd), fixnum_value(offset), fixnum_value(whence)); results(thread, args-1, res, make_fixnum(res)); }
Integer parse_integer(char *token) { Integer n; if (is_fixnum_token(token)) n = make_fixnum(atoi(token)); else n = parse_bignum(token); free(token); return n; }