static void fasl_ensure_valid_table_index(lref_t reader, size_t index) { if (NULLP(FASL_READER_STREAM(reader)->table)) { FASL_READER_STREAM(reader)->table = vectorcons((index >= DEFAULT_FASL_TABLE_SIZE) ? index + DEFAULT_FASL_TABLE_SIZE : DEFAULT_FASL_TABLE_SIZE, NIL); } else { lref_t fasl_table = FASL_READER_STREAM(reader)->table; assert(VECTORP(fasl_table)); size_t old_len = fasl_table->as.vector.dim; if (index >= old_len) { size_t new_len = (index >= old_len * 2) ? index + DEFAULT_FASL_TABLE_SIZE : (old_len * 2); FASL_READER_STREAM(reader)->table = vector_resize(fasl_table, new_len > SIZE_MAX ? SIZE_MAX : (size_t) new_len, NIL); } } assert(VECTORP(FASL_READER_STREAM(reader)->table)); assert(index < (FASL_READER_STREAM(reader)->table)->as.vector.dim); }
static Lisp_Object validate_coding_system (Lisp_Object coding_system) { Lisp_Object eol_type; /* Make sure the input is valid. */ if (NILP (Fcoding_system_p (coding_system))) return Qnil; /* Make sure we use a DOS coding system as mandated by the system specs. */ eol_type = Fcoding_system_eol_type (coding_system); /* Already a DOS coding system? */ if (EQ (eol_type, make_number (1))) return coding_system; /* Get EOL_TYPE vector of the base of CODING_SYSTEM. */ if (!VECTORP (eol_type)) { eol_type = Fcoding_system_eol_type (Fcoding_system_base (coding_system)); if (!VECTORP (eol_type)) return Qnil; } return AREF (eol_type, 1); }
t_real perso2rqtrn(t_qtrn *q) { const t_real alpha = SCALARP(q) / 2; const t_real scale = VECTORP(q).s.rho; SCALARP(q) = cos(alpha / 2); VECTORP(q).s.rho = sin(alpha / 2); return (scale); }
static void evict_lower_half (log_t *log) { ptrdiff_t size = ASIZE (log->key_and_value) / 2; EMACS_INT median = approximate_median (log, 0, size); ptrdiff_t i; for (i = 0; i < size; i++) /* Evict not only values smaller but also values equal to the median, so as to make sure we evict something no matter what. */ if (XINT (HASH_VALUE (log, i)) <= median) { Lisp_Object key = HASH_KEY (log, i); { /* FIXME: we could make this more efficient. */ Lisp_Object tmp; XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */ Fremhash (key, tmp); } eassert (EQ (log->next_free, make_number (i))); { int j; eassert (VECTORP (key)); for (j = 0; j < ASIZE (key); j++) ASET (key, j, Qnil); } set_hash_key_slot (log, i, key); } }
PRIVATE int real_isa(OBJECT x, OBJECT y) { while (1) { if (x == NULL) return 0; if (x == y) return 1; if (x->parents == NULL) return 0; if (OBJECTP(x->parents)) { x = (OBJECT) x->parents; continue; } if (VECTORP(x->parents)) { int i; VECTOR vxp = (VECTOR) x->parents; for (i = 0; i < vxp->_.length; i++) if (real_isa((OBJECT) AT(vxp, i), y)) return 1; return 0; } return 0; } }
object_t *vectorp (object_t * lst) { DOC ("Return t if object is a vector."); REQ (lst, 1, c_sym ("vectorp")); if (VECTORP (CAR (lst))) return T; return NIL; }
static void restore_menu_items (Lisp_Object saved) { menu_items = XCAR (saved); menu_items_inuse = (! NILP (menu_items) ? Qt : Qnil); menu_items_allocated = (VECTORP (menu_items) ? ASIZE (menu_items) : 0); saved = XCDR (saved); menu_items_used = XINT (XCAR (saved)); saved = XCDR (saved); menu_items_n_panes = XINT (XCAR (saved)); saved = XCDR (saved); menu_items_submenu_depth = XINT (XCAR (saved)); }
static ptrdiff_t module_vec_size (emacs_env *env, emacs_value vec) { /* FIXME: Return a sentinel value (e.g., -1) on error. */ MODULE_FUNCTION_BEGIN (0); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return 0; } return ASIZE (lvec); }
scm_hashtable_t make_generic_hashtable(object_heap_t* heap, scm_vector_t handlers) { assert(VECTORP(handlers)); scm_hashtable_t obj = (scm_hashtable_t)heap->allocate_collectible(sizeof(scm_hashtable_rec_t)); obj->hdr = scm_hdr_hashtable; obj->type = SCM_HASHTABLE_TYPE_GENERIC; obj->handlers = handlers; obj->hash = NULL; obj->equiv = NULL; obj->datum = NULL; obj->lock.init(); return obj; }
SchObj vector_fill(SchObj vec, SchObj obj) { size_t i,len; if ( ! VECTORP(vec) ) { EXCEPTION("a vector required"); return SCH_NIL; } len = SCH_VECTOR_LEN(vec); for ( i = 0 ; i < len ; ++i ) { SCH_VECTOR_REF(vec,i) = obj; } return SCH_UNDEFINE; }
SchObj vector2list(SchObj vec) { SchObj lst = SCH_NIL; size_t len; if ( !VECTORP(vec) ) { EXCEPTION("a vector required"); return SCH_NIL; } len = SCH_VECTOR_LEN(vec); do { len--; lst = SCH_CONS(SCH_VECTOR_REF(vec,len),lst); } while ( len > 0); return lst; }
/* _vector->tvector */ obj_t BGl__vectorzd2ze3tvectorz31zz__tvectorz00(obj_t BgL_envz00_1650, obj_t BgL_idz00_1651, obj_t BgL_vz00_1652) { AN_OBJECT; { /* Llib/tvector.scm 186 */ { /* Llib/tvector.scm 187 */ obj_t BgL_auxz00_1886; obj_t BgL_auxz00_1879; if (VECTORP(BgL_vz00_1652)) { /* Llib/tvector.scm 187 */ BgL_auxz00_1886 = BgL_vz00_1652; } else { obj_t BgL_auxz00_1889; BgL_auxz00_1889 = BGl_typezd2errorzd2zz__errorz00(BGl_string2198z00zz__tvectorz00, BINT(((long) 7562)), BGl_string2220z00zz__tvectorz00, BGl_string2221z00zz__tvectorz00, BgL_vz00_1652); FAILURE(BgL_auxz00_1889, BFALSE, BFALSE); } if (SYMBOLP(BgL_idz00_1651)) { /* Llib/tvector.scm 187 */ BgL_auxz00_1879 = BgL_idz00_1651; } else { obj_t BgL_auxz00_1882; BgL_auxz00_1882 = BGl_typezd2errorzd2zz__errorz00(BGl_string2198z00zz__tvectorz00, BINT(((long) 7562)), BGl_string2220z00zz__tvectorz00, BGl_string2203z00zz__tvectorz00, BgL_idz00_1651); FAILURE(BgL_auxz00_1882, BFALSE, BFALSE); } return BGl_vectorzd2ze3tvectorz31zz__tvectorz00(BgL_auxz00_1879, BgL_auxz00_1886); } } }
PUBLIC int in_group(OBJECT what, VECTOR group) { int i; if (group == NULL) return 0; for (i = 0; i < group->_.length; i++) { OBJ x = AT(group, i); if (x == (OBJ) what) return 1; if (VECTORP(x)) if (in_group(what, (VECTOR) x)) return 1; } return 0; }
lref_t lstructurecons(lref_t slots, lref_t layout) { if (!VECTORP(slots)) vmerror_wrong_type_n(1, slots); size_t len = slots->as.vector.dim; validate_structure_layout(len, layout); lref_t st = new_cell(TC_STRUCTURE); SET_STRUCTURE_DIM(st, len); SET_STRUCTURE_LAYOUT(st, layout); SET_STRUCTURE_DATA(st, (lref_t *) gc_malloc(len * sizeof(lref_t))); for (size_t ii = 0; ii < len; ii++) SET_STRUCTURE_ELEM(st, ii, slots->as.vector.data[ii]); return st; }
static emacs_value module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) { MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return module_nil; } if (! (0 <= i && i < ASIZE (lvec))) { if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) module_args_out_of_range (env, lvec, make_number (i)); else module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return module_nil; } return lisp_to_value (AREF (lvec, i)); }
static void module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) { /* FIXME: This function should return bool because it can fail. */ MODULE_FUNCTION_BEGIN (); Lisp_Object lvec = value_to_lisp (vec); if (! VECTORP (lvec)) { module_wrong_type (env, Qvectorp, lvec); return; } if (! (0 <= i && i < ASIZE (lvec))) { if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) module_args_out_of_range (env, lvec, make_number (i)); else module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); return; } ASET (lvec, i, value_to_lisp (val)); }
/*---------------------------------------------------------------------*/ void bglk_gtk_start( obj_t gtk_argv, int main_loop_p, char *argv0, char *name ) { int argc; char **argv; int len_argv = VECTOR_LENGTH( gtk_argv ); char *peer_version = BSTRING_TO_STRING( biglook_peer_version ); if( !VECTORP( gtk_argv ) ) exit( 1 ); /* convert scheme vector to an char*[] for gtk_init */ argv = alloca( sizeof( char * ) * len_argv ); for( argc = 0; argc < len_argv; argc++ ) argv[ argc ] = BSTRING_TO_STRING( VECTOR_REF( gtk_argv, argc )); //gnomelib_init( "biglook", peer_version ); gnome_program_init( "biglook", peer_version, LIBGNOMEUI_MODULE, argc, argv, NULL); gtk_init( &argc, &argv ); }
static void mark_obj(ScmObj obj) { #if SCM_USE_VECTOR scm_int_t i, len; ScmObj *vec; #endif mark_loop: /* no need to mark immediates */ if (SCM_IMMP(obj)) return; /* avoid cyclic marking */ if (SCM_MARKEDP(obj)) return; /* mark this object */ SCM_MARK(obj); /* mark recursively */ switch (SCM_PTAG(obj)) { case SCM_PTAG_CONS: /* CONS accessors bypass tag manipulation by default so we * have to do it specially here. */ obj = SCM_DROP_GCBIT(obj); mark_obj(SCM_CONS_CAR(obj)); obj = SCM_CONS_CDR(obj); goto mark_loop; case SCM_PTAG_CLOSURE: mark_obj(SCM_CLOSURE_EXP(obj)); obj = SCM_CLOSURE_ENV(obj); goto mark_loop; case SCM_PTAG_MISC: if (SYMBOLP(obj)) { obj = SCM_SYMBOL_VCELL(obj); goto mark_loop; #if SCM_USE_HYGIENIC_MACRO } else if (SCM_WRAPPERP(obj)) { /* Macro-related wrapper. */ obj = SCM_WRAPPER_OBJ(obj); goto mark_loop; #endif /* SCM_USE_HYGIENIC_MACRO */ #if SCM_USE_VECTOR /* Alert: objects that store a non-ScmObj in obj_x must * explicitly drop the GC bit here. This currently applies * only to vectors. */ } else if (VECTORP(obj)) { len = SCM_VECTOR_LEN(obj); vec = SCM_VECTOR_VEC(obj); vec = (ScmObj *)SCM_DROP_GCBIT((scm_intobj_t)vec); for (i = 0; i < len; i++) { mark_obj(vec[i]); } #endif /* SCM_USE_VECTOR */ } else if (VALUEPACKETP(obj)) { obj = SCM_VALUEPACKET_VALUES(obj); goto mark_loop; } break; default: break; } }
void set_frame_menubar (struct frame *f, bool first_time, bool deep_p) { HMENU menubar_widget = f->output_data.w32->menubar_widget; Lisp_Object items; widget_value *wv, *first_wv, *prev_wv = 0; int i, last_i; int *submenu_start, *submenu_end; int *submenu_top_level_items, *submenu_n_panes; /* We must not change the menubar when actually in use. */ if (f->output_data.w32->menubar_active) return; XSETFRAME (Vmenu_updating_frame, f); if (! menubar_widget) deep_p = true; if (deep_p) { /* Make a widget-value tree representing the entire menu trees. */ struct buffer *prev = current_buffer; Lisp_Object buffer; ptrdiff_t specpdl_count = SPECPDL_INDEX (); int previous_menu_items_used = f->menu_bar_items_used; Lisp_Object *previous_items = (Lisp_Object *) alloca (previous_menu_items_used * word_size); /* If we are making a new widget, its contents are empty, do always reinitialize them. */ if (! menubar_widget) previous_menu_items_used = 0; buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents; specbind (Qinhibit_quit, Qt); /* Don't let the debugger step into this code because it is not reentrant. */ specbind (Qdebug_on_next_call, Qnil); record_unwind_save_match_data (); if (NILP (Voverriding_local_map_menu_flag)) { specbind (Qoverriding_terminal_local_map, Qnil); specbind (Qoverriding_local_map, Qnil); } set_buffer_internal_1 (XBUFFER (buffer)); /* Run the hooks. */ safe_run_hooks (Qactivate_menubar_hook); safe_run_hooks (Qmenu_bar_update_hook); fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); items = FRAME_MENU_BAR_ITEMS (f); /* Save the frame's previous menu bar contents data. */ if (previous_menu_items_used) memcpy (previous_items, XVECTOR (f->menu_bar_vector)->contents, previous_menu_items_used * word_size); /* Fill in menu_items with the current menu bar contents. This can evaluate Lisp code. */ save_menu_items (); menu_items = f->menu_bar_vector; menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0; submenu_start = (int *) alloca (ASIZE (items) * sizeof (int)); submenu_end = (int *) alloca (ASIZE (items) * sizeof (int)); submenu_n_panes = (int *) alloca (ASIZE (items) * sizeof (int)); submenu_top_level_items = (int *) alloca (ASIZE (items) * sizeof (int)); init_menu_items (); for (i = 0; i < ASIZE (items); i += 4) { Lisp_Object key, string, maps; last_i = i; key = AREF (items, i); string = AREF (items, i + 1); maps = AREF (items, i + 2); if (NILP (string)) break; submenu_start[i] = menu_items_used; menu_items_n_panes = 0; submenu_top_level_items[i] = parse_single_submenu (key, string, maps); submenu_n_panes[i] = menu_items_n_panes; submenu_end[i] = menu_items_used; } finish_menu_items (); /* Convert menu_items into widget_value trees to display the menu. This cannot evaluate Lisp code. */ wv = make_widget_value ("menubar", NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; first_wv = wv; for (i = 0; i < last_i; i += 4) { menu_items_n_panes = submenu_n_panes[i]; wv = digest_single_submenu (submenu_start[i], submenu_end[i], submenu_top_level_items[i]); if (prev_wv) prev_wv->next = wv; else first_wv->contents = wv; /* Don't set wv->name here; GC during the loop might relocate it. */ wv->enabled = true; wv->button_type = BUTTON_TYPE_NONE; prev_wv = wv; } set_buffer_internal_1 (prev); /* If there has been no change in the Lisp-level contents of the menu bar, skip redisplaying it. Just exit. */ for (i = 0; i < previous_menu_items_used; i++) if (menu_items_used == i || (!EQ (previous_items[i], AREF (menu_items, i)))) break; if (i == menu_items_used && i == previous_menu_items_used && i != 0) { free_menubar_widget_value_tree (first_wv); discard_menu_items (); unbind_to (specpdl_count, Qnil); return; } fset_menu_bar_vector (f, menu_items); f->menu_bar_items_used = menu_items_used; /* This undoes save_menu_items. */ unbind_to (specpdl_count, Qnil); /* Now GC cannot happen during the lifetime of the widget_value, so it's safe to store data from a Lisp_String, as long as local copies are made when the actual menu is created. Windows takes care of this for normal string items, but not for owner-drawn items or additional item-info. */ wv = first_wv->contents; for (i = 0; i < ASIZE (items); i += 4) { Lisp_Object string; string = AREF (items, i + 1); if (NILP (string)) break; wv->name = SSDATA (string); update_submenu_strings (wv->contents); wv = wv->next; } } else { /* Make a widget-value tree containing just the top level menu bar strings. */ wv = make_widget_value ("menubar", NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; first_wv = wv; items = FRAME_MENU_BAR_ITEMS (f); for (i = 0; i < ASIZE (items); i += 4) { Lisp_Object string; string = AREF (items, i + 1); if (NILP (string)) break; wv = make_widget_value (SSDATA (string), NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; /* This prevents lwlib from assuming this menu item is really supposed to be empty. */ /* The EMACS_INT cast avoids a warning. This value just has to be different from small integers. */ wv->call_data = (void *) (EMACS_INT) (-1); if (prev_wv) prev_wv->next = wv; else first_wv->contents = wv; prev_wv = wv; } /* Forget what we thought we knew about what is in the detailed contents of the menu bar menus. Changing the top level always destroys the contents. */ f->menu_bar_items_used = 0; } /* Create or update the menu bar widget. */ block_input (); if (menubar_widget) { /* Empty current menubar, rather than creating a fresh one. */ while (DeleteMenu (menubar_widget, 0, MF_BYPOSITION)) ; } else { menubar_widget = CreateMenu (); } fill_in_menu (menubar_widget, first_wv->contents); free_menubar_widget_value_tree (first_wv); { HMENU old_widget = f->output_data.w32->menubar_widget; f->output_data.w32->menubar_widget = menubar_widget; SetMenu (FRAME_W32_WINDOW (f), f->output_data.w32->menubar_widget); /* Causes flicker when menu bar is updated DrawMenuBar (FRAME_W32_WINDOW (f)); */ /* Force the window size to be recomputed so that the frame's text area remains the same, if menubar has just been created. */ if (old_widget == NULL) { windows_or_buffers_changed = 23; adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines); } } unblock_input (); }
PUBLIC int run_vm(VMSTATE vms) { OBJ vm_hold; /* Holding register. NOT SEEN BY GC */ int ticks_left = VM_TIMESLICE_TICKS; while (vms->c.vm_state != VM_STATE_DYING && ticks_left-- && vms->r->vm_acc != yield_thread) { if (vms->c.vm_state > 0) { vms->c.vm_state--; if (vms->c.vm_state == 0) { /* Quota expired. Warn. */ vms->c.vm_state = VM_DEFAULT_CPU_QUOTA; vm_raise(vms, (OBJ) newsym("quota-expired"), NULL); /* Make sure we don't recurse :-) */ vms->r->vm_trap_closure = NULL; } } gc_reach_safepoint(); #ifdef DEBUG debug_dump_instr( vms->r->vm_code->vec , vms->c.vm_ip ); #endif switch (CODEAT(vms->c.vm_ip)) { case OP_AT: { int index = CODEAT(vms->c.vm_ip + 1); if (index < 0 || index >= vms->r->vm_acc->length) { vm_raise(vms, (OBJ) newsym("range-check-error"), vms->r->vm_acc); break; } if (!VECTORP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } vms->r->vm_acc = AT((VECTOR) vms->r->vm_acc, index); vms->c.vm_ip += 2; break; } case OP_ATPUT: { int index = CODEAT(vms->c.vm_ip + 1); vm_hold = PEEK(); if (index < 0 || index >= vm_hold->length) { vm_raise(vms, (OBJ) newsym("range-check-error"), vm_hold); break; } if (!VECTORP(vm_hold)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vm_hold); break; } ATPUT((VECTOR) vm_hold, index, vms->r->vm_acc); vms->c.vm_ip += 2; break; } case OP_MOV_A_LOCL: { int i = CODEAT(vms->c.vm_ip + 1); vm_hold = (OBJ) vms->r->vm_env; while (i-- > 0) vm_hold = AT((VECTOR) vm_hold, 0); vms->r->vm_acc = AT((VECTOR) vm_hold, CODEAT(vms->c.vm_ip + 2) + 1); vms->c.vm_ip += 3; break; } case OP_MOV_A_GLOB: vm_hold = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); vms->r->vm_acc = AT((OVECTOR) vm_hold, SY_VALUE); vms->c.vm_ip += 2; break; case OP_MOV_A_SLOT: { OVECTOR slot, slotname; if (!OBJECTP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } slotname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); if (!O_CAN_X((OBJECT) vms->r->vm_acc, vms->r->vm_effuid)) { NOPERMISSION((OBJ) slotname); } slot = findslot((OBJECT) vms->r->vm_acc, slotname, NULL); if (slot == NULL) { vm_raise(vms, (OBJ) newsym("slot-not-found"), (OBJ) slotname); break; } if (!MS_CAN_R(slot, vms->r->vm_effuid)) { NOPERMISSION((OBJ) slotname); } vms->r->vm_acc = AT(slot, SL_VALUE); vms->c.vm_ip += 2; break; } case OP_MOV_A_LITL: vms->r->vm_acc = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); vms->c.vm_ip += 2; break; case OP_MOV_A_SELF: vms->r->vm_acc = (OBJ) vms->r->vm_self; vms->c.vm_ip++; break; case OP_MOV_A_FRAM: vms->r->vm_acc = (OBJ) vms->r->vm_frame; vms->c.vm_ip++; break; case OP_MOV_LOCL_A: { int i = CODEAT(vms->c.vm_ip + 1); vm_hold = (OBJ) vms->r->vm_env; while (i-- > 0) vm_hold = AT((VECTOR) vm_hold, 0); ATPUT((VECTOR) vm_hold, CODEAT(vms->c.vm_ip + 2) + 1, vms->r->vm_acc); vms->c.vm_ip += 3; break; } case OP_MOV_GLOB_A: if (!PRIVILEGEDP(vms->r->vm_effuid)) { NOPERMISSION((OBJ) newsym("setting-global-value")); } vm_hold = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); ATPUT((OVECTOR) vm_hold, SY_VALUE, vms->r->vm_acc); vms->c.vm_ip += 2; break; case OP_MOV_SLOT_A: { OVECTOR slot, slotname; OBJECT target = (OBJECT) POP(); OBJECT foundin; if (!OBJECTP(target)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), (OBJ) target); break; } slotname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); if (!O_CAN_X(target, vms->r->vm_effuid)) { NOPERMISSION((OBJ) slotname); } slot = findslot(target, slotname, &foundin); if (slot == NULL) { vm_raise(vms, (OBJ) newsym("slot-not-found"), (OBJ) slotname); break; } if (!MS_CAN_W(slot, vms->r->vm_effuid)) { NOPERMISSION((OBJ) slotname); } if (foundin == target) { ATPUT(slot, SL_VALUE, vms->r->vm_acc); } else { OVECTOR newslot = addslot(target, slotname, (OBJECT) AT(slot, SL_OWNER)); ATPUT(newslot, SL_FLAGS, AT(slot, SL_FLAGS)); ATPUT(newslot, SL_VALUE, vms->r->vm_acc); } vms->c.vm_ip += 2; break; } case OP_MOV_FRAM_A: if (!PRIVILEGEDP(vms->r->vm_effuid)) { NOPERMISSION((OBJ) newsym("restoring-vm-frame-pointer")); } if (!OVECTORP(vms->r->vm_acc) || ((OVECTOR) vms->r->vm_acc)->type != T_FRAME) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } vms->r->vm_frame = (OVECTOR) vms->r->vm_acc; vms->c.vm_ip++; break; case OP_PUSH: PUSH(vms->r->vm_acc); vms->c.vm_ip++; break; case OP_POP: vms->r->vm_acc = POP(); vms->c.vm_ip++; break; case OP_SWAP: vm_hold = POP(); PUSH(vms->r->vm_acc); vms->r->vm_acc = vm_hold; vms->c.vm_ip++; break; case OP_VECTOR: vms->r->vm_acc = (OBJ) newvector(CODEAT(vms->c.vm_ip+1)); vms->c.vm_ip += 2; break; case OP_ENTER_SCOPE: vm_hold = (OBJ) newvector(CODEAT(vms->c.vm_ip+1) + 1); ATPUT((VECTOR) vm_hold, 0, (OBJ) vms->r->vm_env); vms->r->vm_env = (VECTOR) vm_hold; vms->c.vm_ip += 2; break; case OP_LEAVE_SCOPE: vms->r->vm_env = (VECTOR) AT(vms->r->vm_env, 0); vms->c.vm_ip++; break; case OP_MAKE_VECTOR: { int i = 0; int len = CODEAT(vms->c.vm_ip+1); VECTOR vec = newvector_noinit(len); for (i = len - 1; i >= 0; i--) ATPUT(vec, i, POP()); vms->r->vm_acc = (OBJ) vec; vms->c.vm_ip += 2; break; } case OP_CLOSURE: vms->r->vm_acc = make_closure_from((OVECTOR) vms->r->vm_acc, vms->r->vm_self, vms->r->vm_env, vms->r->vm_effuid); vms->c.vm_ip++; break; case OP_METHOD_CLOSURE: { OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); OVECTOR method; if (!OBJECTP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } method = findmethod((OBJECT) vms->r->vm_acc, methname); if (method == NULL) { vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname); break; } if (!MS_CAN_R(method, vms->r->vm_effuid)) { NOPERMISSION((OBJ) methname); } vm_hold = (OBJ) newovector(CL_MAXSLOTINDEX, T_CLOSURE); ATPUT((OVECTOR) vm_hold, CL_METHOD, (OBJ) method); ATPUT((OVECTOR) vm_hold, CL_SELF, vms->r->vm_acc); vms->r->vm_acc = vm_hold; vms->c.vm_ip += 2; break; } case OP_RET: if (vms->r->vm_frame != NULL) { restoreframe(vms, vms->r->vm_frame); if (vms->r->vm_code != NULL) break; } vms->c.vm_state = VM_STATE_DYING; return 1; /* finished, nothing more to run! */ case OP_CALL: { OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); OVECTOR method; if (vms->r->vm_acc == NULL || TAGGEDP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("null-call-error"), AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip+1))); break; } if (!OBJECTP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } method = findmethod((OBJECT) vms->r->vm_acc, methname); if (method == NULL) { vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname); break; } if (!MS_CAN_X(method, vms->r->vm_effuid)) { NOPERMISSION((OBJ) methname); } vm_hold = POP(); if (vm_hold->length-1 != NUM(AT(method, ME_ARGC))) { vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) methname); break; } vms->c.vm_ip += 2; push_frame(vms); vms->r->vm_env = (VECTOR) vm_hold; ATPUT(vms->r->vm_env, 0, AT(method, ME_ENV)); vms->r->vm_code = (BVECTOR) AT(method, ME_CODE); vms->r->vm_lits = (VECTOR) AT(method, ME_LITS); vms->r->vm_self = (OBJECT) vms->r->vm_acc; if (NUM(AT(method, ME_FLAGS)) & O_SETUID) vms->r->vm_effuid = (OBJECT) AT(method, ME_OWNER); vms->r->vm_method = method; vms->c.vm_ip = 0; break; } case OP_CALL_AS: { OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1)); OVECTOR method; if (vms->r->vm_self == NULL || vms->r->vm_acc == NULL || TAGGEDP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("null-call-error"), AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip+1))); break; } if (!OBJECTP(vms->r->vm_acc)) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } method = findmethod((OBJECT) vms->r->vm_acc, methname); if (method == NULL) { vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname); break; } if (!MS_CAN_X(method, vms->r->vm_effuid)) { NOPERMISSION((OBJ) methname); } vm_hold = POP(); if (vm_hold->length-1 != NUM(AT(method, ME_ARGC))) { vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) methname); break; } vms->c.vm_ip += 2; push_frame(vms); vms->r->vm_env = (VECTOR) vm_hold; ATPUT(vms->r->vm_env, 0, AT(method, ME_ENV)); vms->r->vm_code = (BVECTOR) AT(method, ME_CODE); vms->r->vm_lits = (VECTOR) AT(method, ME_LITS); /* don't set vm_self, this is OP_CALL_AS. */ /* vms->r->vm_self = vms->r->vm_acc; */ if (NUM(AT(method, ME_FLAGS)) & O_SETUID) vms->r->vm_effuid = (OBJECT) AT(method, ME_OWNER); vms->r->vm_method = method; vms->c.vm_ip = 0; break; } case OP_APPLY: vms->c.vm_ip++; apply_closure(vms, (OVECTOR) vms->r->vm_acc, (VECTOR) POP()); break; case OP_JUMP: vms->c.vm_ip += 3 + ((int16_t) CODE16AT(vms->c.vm_ip+1)); break; case OP_JUMP_TRUE: vms->c.vm_ip += (vms->r->vm_acc == false) ? 3 : 3 + ((int16_t) CODE16AT(vms->c.vm_ip+1)); break; case OP_JUMP_FALSE: vms->c.vm_ip += (vms->r->vm_acc != false) ? 3 : 3 + ((int16_t) CODE16AT(vms->c.vm_ip+1)); break; case OP_NOT: vms->r->vm_acc = (vms->r->vm_acc == false) ? true : false; vms->c.vm_ip++; break; case OP_EQ: vms->r->vm_acc = (vms->r->vm_acc == POP()) ? true : false; vms->c.vm_ip++; break; case OP_NE: vms->r->vm_acc = (vms->r->vm_acc != POP()) ? true : false; vms->c.vm_ip++; break; NUMOP(OP_GT, vms->r->vm_acc = (NUM(vms->r->vm_acc) < NUM(POP())) ? true : false); NUMOP(OP_LT, vms->r->vm_acc = (NUM(vms->r->vm_acc) > NUM(POP())) ? true : false); NUMOP(OP_GE, vms->r->vm_acc = (NUM(vms->r->vm_acc) <= NUM(POP())) ? true : false); NUMOP(OP_LE, vms->r->vm_acc = (NUM(vms->r->vm_acc) >= NUM(POP())) ? true : false); NUMOP(OP_NEG, vms->r->vm_acc = MKNUM(-NUM(vms->r->vm_acc))); NUMOP(OP_BNOT, vms->r->vm_acc = MKNUM(~NUM(vms->r->vm_acc))); NUMOP(OP_BOR, vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)|NUM(POP()))); NUMOP(OP_BAND, vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)&NUM(POP()))); case OP_PLUS: if (vms->r->vm_acc == NULL || PEEK() == NULL) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } if (NUMP(vms->r->vm_acc) && NUMP(PEEK())) vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)+NUM(POP())); else if (TAGGEDP(vms->r->vm_acc) || TAGGEDP(PEEK())) { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } else if (BVECTORP(vms->r->vm_acc) && BVECTORP(PEEK())) vms->r->vm_acc = (OBJ) bvector_concat((BVECTOR) POP(), (BVECTOR) vms->r->vm_acc); else if (VECTORP(vms->r->vm_acc) && VECTORP(PEEK())) vms->r->vm_acc = (OBJ) vector_concat((VECTOR) POP(), (VECTOR) vms->r->vm_acc); else { vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc); break; } vms->c.vm_ip++; break; NUMOP(OP_MINUS, vms->r->vm_acc = MKNUM(NUM(POP())-NUM(vms->r->vm_acc))); NUMOP(OP_STAR, vms->r->vm_acc = MKNUM(NUM(POP())*NUM(vms->r->vm_acc))); NUMOP(OP_SLASH, if (vms->r->vm_acc == MKNUM(0)) vm_raise(vms, (OBJ) newsym("divide-by-zero"), NULL); else vms->r->vm_acc = MKNUM(NUM(POP())/NUM(vms->r->vm_acc))); NUMOP(OP_PERCENT, if (vms->r->vm_acc == MKNUM(0)) vm_raise(vms, (OBJ) newsym("divide-by-zero"), NULL); else vms->r->vm_acc = MKNUM(NUM(POP())%NUM(vms->r->vm_acc))); default: fprintf(stderr, "Unknown bytecode reached (%d == 0x%x).\n", CODEAT(vms->c.vm_ip), CODEAT(vms->c.vm_ip)); exit(MOVE_EXIT_PROGRAMMER_FUCKUP); } } return vms->c.vm_state == VM_STATE_DYING; }
PRIVATE BVECTOR getPrintString_body(VMSTATE vms, OBJ x, int depth) { char buf[80]; if (x == NULL) return newstring("null"); if (NUMP(x)) { sprintf(buf, "%ld", (long) NUM(x)); return newstring(buf); } if (SINGLETONP(x)) { if (x == true) return newstring("true"); if (x == false) return newstring("false"); if (x == undefined) return newstring("undefined"); return newstring("#<unknown-singleton>"); } if (OBJECTP(x)) return newstring("#<object>"); if (BVECTORP(x)) return (BVECTOR) x; if (OVECTORP(x)) { OVECTOR ov = (OVECTOR) x; switch (ov->type) { case T_HASHTABLE: return newstring("#<hashtable>"); case T_SLOT: return newstring("#<slot>"); case T_METHOD: return newstring("#<method>"); case T_CLOSURE: return newstring("#<closure>"); case T_SYMBOL: return (BVECTOR) AT(ov, SY_NAME); case T_PRIM: return bvector_concat(newstring("#<prim "), bvector_concat((BVECTOR) AT((OVECTOR) AT(ov, PR_NAME), SY_NAME), newstring(">"))); case T_FRAME: return newstring("#<frame>"); case T_VMREGS: return newstring("#<vmregs>"); case T_CONNECTION: return newstring("#<connection>"); case T_CONTINUATION: return newstring("#<continuation>"); case T_USERHASHLINK: return newstring("#<hashlink>"); default: return newstring("#<unknown-ovector-type>"); } } if (VECTORP(x)) { if (depth < 5) { VECTOR v = (VECTOR) x; BVECTOR result = newstring("["); int i; for (i = 0; i < (int) x->length - 1; i++) { result = bvector_concat(result, getPrintString_body(vms, AT(v, i), depth + 1)); result = bvector_concat(result, newstring(", ")); } if (x->length > 0) result = bvector_concat(result, getPrintString_body(vms, AT(v, x->length - 1), depth + 1)); return bvector_concat(result, newstring("]")); } else return newstring("[...]"); } return newstring("unhandled-type-getPrintString"); }
static void fast_read(lref_t reader, lref_t * retval, bool allow_loader_ops /* = false */ ) { lref_t *fasl_table_entry = NULL; *retval = NIL; if (!FASL_READER_P(reader)) vmerror_wrong_type_n(1, reader); assert(NULLP(FASL_READER_STREAM(reader)->table) || VECTORP(FASL_READER_STREAM(reader)->table)); /* The core of this function is wrapped in a giant while loop to remove * tail recursive calls. Some opcodes don't directly return anything: * they just tail recursively read the next opcode after performing their * action via side effect. */ bool current_read_complete = false; while (!current_read_complete) { /* Assume we're going to complete the read unless we find out otherwise.. */ current_read_complete = true; size_t opcode_location = PORT_BYTES_READ(FASL_READER_PORT(reader)); enum fasl_opcode_t opcode = fast_read_opcode(reader); fixnum_t index = 0; lref_t name; if (DEBUG_FLAG(DF_FASL_SHOW_OPCODES)) { const _TCHAR *opcode_name = fasl_opcode_name(opcode); dscwritef(DF_FASL_SHOW_OPCODES, (_T("; DEBUG: fasl-opcode@~cx :~cS\n"), opcode_location, opcode_name ? opcode_name : _T("<INVALID>"))); } switch (opcode) { case FASL_OP_NIL: *retval = NIL; break; case FASL_OP_TRUE: *retval = boolcons(true); break; case FASL_OP_FALSE: *retval = boolcons(false); break; case FASL_OP_CHARACTER: fast_read_character(reader, retval); break; case FASL_OP_LIST: fast_read_list(reader, false, retval); break; case FASL_OP_LISTD: fast_read_list(reader, true, retval); break; case FASL_OP_FIX8: fast_read_fixnum_int8(reader, retval); break; case FASL_OP_FIX16: fast_read_fixnum_int16(reader, retval); break; case FASL_OP_FIX32: fast_read_fixnum_int32(reader, retval); break; case FASL_OP_FIX64: fast_read_fixnum_int64(reader, retval); break; case FASL_OP_FLOAT: fast_read_flonum(reader, false, retval); break; case FASL_OP_COMPLEX: fast_read_flonum(reader, true, retval); break; case FASL_OP_STRING: fast_read_string(reader, retval); break; case FASL_OP_PACKAGE: fast_read_package(reader, retval); break; case FASL_OP_VECTOR: fast_read_vector(reader, retval); break; case FASL_OP_HASH: fast_read_hash(reader, retval); break; case FASL_OP_CLOSURE: fast_read_closure(reader, retval); break; case FASL_OP_MACRO: fast_read_macro(reader, retval); break; case FASL_OP_SYMBOL: fast_read_symbol(reader, retval); break; case FASL_OP_SUBR: fast_read_subr(reader, retval); break; case FASL_OP_STRUCTURE: fast_read_structure(reader, retval); break; case FASL_OP_STRUCTURE_LAYOUT: fast_read_structure_layout(reader, retval); break; case FASL_OP_FAST_OP_0: fast_read_fast_op(0, false, reader, retval); break; case FASL_OP_FAST_OP_1: fast_read_fast_op(1, false, reader, retval); break; case FASL_OP_FAST_OP_2: fast_read_fast_op(2, false, reader, retval); break; case FASL_OP_FAST_OP_0N: fast_read_fast_op(0, true, reader, retval); break; case FASL_OP_FAST_OP_1N: fast_read_fast_op(1, true, reader, retval); break; case FASL_OP_FAST_OP_2N: fast_read_fast_op(2, true, reader, retval); break; case FASL_OP_NOP_1: case FASL_OP_NOP_2: case FASL_OP_NOP_3: current_read_complete = false; break; case FASL_OP_COMMENT_1: case FASL_OP_COMMENT_2: fast_read_to_newline(reader); current_read_complete = false; break; case FASL_OP_RESET_READER_DEFS: FASL_READER_STREAM(reader)->table = NIL; current_read_complete = false; break; case FASL_OP_READER_DEFINITION: index = fast_read_table_index(reader); fasl_table_entry = &(FASL_READER_STREAM(reader)->table->as.vector.data[index]); fast_read(reader, fasl_table_entry, allow_loader_ops); /* This should throw if the FASL table was resized * during the call to read. */ assert(fasl_table_entry == &(FASL_READER_STREAM(reader)->table->as.vector.data[index])); *retval = *fasl_table_entry; break; case FASL_OP_READER_REFERENCE: index = fast_read_table_index(reader); *retval = FASL_READER_STREAM(reader)->table->as.vector.data[index]; break; case FASL_OP_EOF: *retval = lmake_eof(); break; case FASL_OP_LOADER_DEFINEQ: case FASL_OP_LOADER_DEFINEA0: if (!allow_loader_ops) vmerror_fast_read(_T("loader definitions not allowed outside loader"), reader, NIL); fast_read_loader_definition(reader, opcode); current_read_complete = false; break; case FASL_OP_LOADER_APPLY0: case FASL_OP_LOADER_APPLYN: if (!allow_loader_ops) vmerror_fast_read(_T("loader function applications not allowed outside loader"), reader, NIL); fast_read_loader_application(reader, opcode); break; case FASL_OP_BEGIN_LOAD_UNIT: if (!allow_loader_ops) vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL); fast_read(reader, &name, allow_loader_ops); dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL entering unit ~s\n", name)); break; case FASL_OP_END_LOAD_UNIT: if (!allow_loader_ops) vmerror_fast_read(_T("load units are not allowed outside loader"), reader, NIL); fast_read(reader, &name, allow_loader_ops); dscwritef(DF_SHOW_FAST_LOAD_UNITS, ("; DEBUG: FASL leaving unit ~s\n", name)); break; case FASL_OP_LOADER_PUSH: fast_loader_stack_push(reader, FASL_READER_STREAM(reader)->accum); break; case FASL_OP_LOADER_DROP: fast_loader_stack_pop(reader); break; default: vmerror_fast_read("invalid opcode", reader, fixcons(opcode)); } } }
static json_t * lisp_to_json_toplevel_1 (Lisp_Object lisp) { json_t *json; ptrdiff_t count; if (VECTORP (lisp)) { ptrdiff_t size = ASIZE (lisp); json = json_check (json_array ()); count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, json); for (ptrdiff_t i = 0; i < size; ++i) { int status = json_array_append_new (json, lisp_to_json (AREF (lisp, i))); if (status == -1) json_out_of_memory (); } eassert (json_array_size (json) == size); } else if (HASH_TABLE_P (lisp)) { struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); json = json_check (json_object ()); count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, json); for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) if (!NILP (HASH_HASH (h, i))) { Lisp_Object key = json_encode (HASH_KEY (h, i)); /* We can't specify the length, so the string must be null-terminated. */ check_string_without_embedded_nulls (key); const char *key_str = SSDATA (key); /* Reject duplicate keys. These are possible if the hash table test is not `equal'. */ if (json_object_get (json, key_str) != NULL) wrong_type_argument (Qjson_value_p, lisp); int status = json_object_set_new (json, key_str, lisp_to_json (HASH_VALUE (h, i))); if (status == -1) { /* A failure can be caused either by an invalid key or by low memory. */ json_check_utf8 (key); json_out_of_memory (); } } } else if (NILP (lisp)) return json_check (json_object ()); else if (CONSP (lisp)) { Lisp_Object tail = lisp; json = json_check (json_object ()); count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, json); bool is_plist = !CONSP (XCAR (tail)); FOR_EACH_TAIL (tail) { const char *key_str; Lisp_Object value; Lisp_Object key_symbol; if (is_plist) { key_symbol = XCAR (tail); tail = XCDR (tail); CHECK_CONS (tail); value = XCAR (tail); if (EQ (tail, li.tortoise)) circular_list (lisp); } else { Lisp_Object pair = XCAR (tail); CHECK_CONS (pair); key_symbol = XCAR (pair); value = XCDR (pair); } CHECK_SYMBOL (key_symbol); Lisp_Object key = SYMBOL_NAME (key_symbol); /* We can't specify the length, so the string must be null-terminated. */ check_string_without_embedded_nulls (key); key_str = SSDATA (key); /* In plists, ensure leading ":" in keys is stripped. It will be reconstructed later in `json_to_lisp'.*/ if (is_plist && ':' == key_str[0] && key_str[1]) { key_str = &key_str[1]; } /* Only add element if key is not already present. */ if (json_object_get (json, key_str) == NULL) { int status = json_object_set_new (json, key_str, lisp_to_json (value)); if (status == -1) json_out_of_memory (); } } CHECK_LIST_END (tail, lisp); } else