void mexecute(u16 n, const char *name, int count, fncode fn) /* Effects: Generates code to call function in variable n, with count arguments */ { struct string *mod; int status = module_vstatus(fnglobals(fn), n, &mod); if (!in_glist(n, definable) && !in_glist(n, readable) && !in_glist(n, writable)) { if (status == var_module) { /* Implicitly import protected modules */ if (module_status(fnglobals(fn), mod->str) != module_protected && !all_readable && imported(mod->str) == module_unloaded) log_error("read of global %s (module %s)", name, mod->str); } else if (!all_readable) log_error("read of global %s", name); } if (count == 1) ins2(op_execute_global1, n, fn); else if (count == 2) ins2(op_execute_global2, n, fn); else { /* Could have an op_execute_global */ ins2(op_recall + global_var, n, fn); ins1(op_execute, count, fn); } }
void mrecall(u16 n, const char *name, fncode fn) /* Effects: Generate code to recall variable n */ { struct string *mod; struct global_state *gstate = fnglobals(fn); int status = module_vstatus(gstate, n, &mod); if (!in_glist(n, definable) && !in_glist(n, readable) && !in_glist(n, writable)) { if (status == var_module) { /* Implicitly import protected modules */ if (module_status(gstate, mod->str) == module_protected) { if (immutablep(GVAR(gstate, n))) /* Use value */ { ins_constant(GVAR(gstate, n), fn); return; } } else if (!all_readable && imported(mod->str) == module_unloaded) log_error("read of global %s (module %s)", name, mod->str); } else if (!all_readable) log_error("read of global %s", name); } ins2(op_recall + global_var, n, fn); }
void massign(u16 n, const char *name, fncode fn) /* Effects: Generate code to assign to variable n */ { struct string *mod; int status = module_vstatus(fnglobals(fn), n, &mod); if (status == var_module) if (mod == this_module && fntoplevel(fn)) /* defined here */ ins2(op_define, n, fn); else log_error("write of global %s (module %s)", name, mod->str); else if (all_writable || in_glist(n, writable)) { ins2(op_assign + global_var, n, fn); if (status != var_write) module_vset(fnglobals(fn), n, var_write, NULL); } else log_error("write of global %s", name); }
static value make_gsymbol(const char *name, fncode fn) { struct table *gsymbols = (fn ? fnglobals(fn) : globals)->gsymbols; struct symbol *gsym; if (!table_lookup(gsymbols, name, &gsym)) { struct string *s; GCPRO1(gsymbols); s = alloc_string(name); SET_READONLY(s); GCPOP(1); gsym = table_add_fast(gsymbols, s, makeint(table_entries(gsymbols))); } return gsym; }
void generate_function(function f, fncode fn) { struct code *c; struct string *help, *afilename, *varname; fncode newfn; vlist argument; u16 clen; i8 nargs; u8 nb_locals, *cvars; varlist closure, cvar; /* Code strings must be allocated before code (immutability restriction) */ if (f->help) help = alloc_string(f->help); else help = NULL; GCPRO1(help); /* Make variable name (if present) */ if (f->varname) varname = alloc_string(f->varname); else varname = NULL; GCPRO1(varname); /* Make filename string */ afilename = make_filename(f->l.filename); GCPRO1(afilename); if (f->varargs) /* varargs makes a vector from the first nargs entries of the stack and stores it in local value 0 */ nargs = -1; else /* count the arguments */ for (nargs = 0, argument = f->args; argument; argument = argument->next) nargs++; newfn = new_fncode(fnglobals(fn), f->l, FALSE, nargs); if (!f->varargs) { /* Generate code to check the argument types */ for (nargs = 0, argument = f->args; argument; argument = argument->next) { if (argument->type != stype_any) ins1(OPmvcheck4 + argument->type, nargs, newfn); nargs++; } } /* Generate code of function */ env_push(f->args, newfn); start_block("<return>", FALSE, FALSE, newfn); generate_component(f->value, NULL, FALSE, newfn); end_block(newfn); if (f->type != stype_any) ins0(OPmscheck4 + f->type, newfn); ins0(OPmreturn, newfn); closure = env_pop(&nb_locals); c = generate_fncode(newfn, nb_locals, help, varname, afilename, f->l.lineno); /* Generate code for creating closure */ /* Count length of closure */ clen = 0; for (cvar = closure; cvar; cvar = cvar->next) clen++; /* Generate closure */ cvars = ins_closure(c, clen, fn); /* Add variables to it */ for (cvar = closure; cvar; cvar = cvar->next) *cvars++ = (cvar->offset << 1) + cvar->vclass; delete_fncode(newfn); GCPOP(3); }
void generate_component(component comp, const char *mlabel, bool discard, fncode fn) { clist args; switch (comp->vclass) { case c_assign: { u16 offset; mtype t; variable_class vclass = env_lookup(comp->l, comp->u.assign.symbol, &offset, &t, FALSE); component val = comp->u.assign.value; if (val->vclass == c_closure) { /* Defining a function, give it a name */ if (vclass == global_var) val->u.closure->varname = comp->u.assign.symbol; else { char *varname = allocate(fnmemory(fn), strlen(comp->u.assign.symbol) + 7); sprintf(varname, "local-%s", comp->u.assign.symbol); val->u.closure->varname = varname; } } generate_component(comp->u.assign.value, NULL, FALSE, fn); if (t != stype_any) ins0(OPmscheck4 + t, fn); if (vclass == global_var) massign(comp->l, offset, comp->u.assign.symbol, fn); else if (vclass == closure_var) ins1(OPmwritec, offset, fn); else ins1(OPmwritel, offset, fn); /* Note: varname becomes a dangling pointer when fnmemory(fn) is deallocated, but it is never used again so this does not cause a problem. */ break; } case c_recall: scompile_recall(comp->l, comp->u.recall, fn); break; case c_constant: ins_constant(make_constant(comp->u.cst, FALSE, fn), fn); break; case c_scheme: scheme_compile_mgc(comp->l, make_constant(comp->u.cst, TRUE, fn), discard, fn); discard = FALSE; break; case c_closure: generate_function(comp->u.closure, fn); break; case c_block: generate_block(comp->u.blk, discard, fn); discard = FALSE; break; case c_decl: { vlist decl, next; /* declare variables one at a time (any x = y, y = 2; is an error) */ for (decl = comp->u.decls; decl; decl = next) { next = decl->next; decl->next = NULL; env_declare(decl); generate_decls(decl, fn); } generate_component(component_undefined, NULL, FALSE, fn); break; } case c_labeled: { start_block(comp->u.labeled.name, FALSE, discard, fn); generate_component(comp->u.labeled.expression, comp->u.labeled.name, discard, fn); end_block(fn); discard = FALSE; break; } case c_exit: { bool discard_exit; label exitlab = exit_block(comp->u.labeled.name, FALSE, &discard_exit, fn); if (comp->u.labeled.expression != component_undefined && discard_exit) warning(comp->l, "break result is ignored"); generate_component(comp->u.labeled.expression, NULL, discard_exit, fn); if (exitlab) branch(OPmba3, exitlab, fn); else { if (!comp->u.labeled.name) log_error(comp->l, "No loop to exit from"); else log_error(comp->l, "No block labeled %s", comp->u.labeled.name); } /* Callers expect generate_component to increase stack depth by 1 */ if (discard_exit) adjust_depth(1, fn); break; } case c_continue: { bool discard_exit; /* Meaningless for continue blocks */ label exitlab = exit_block(comp->u.labeled.name, TRUE, &discard_exit, fn); if (exitlab) branch(OPmba3, exitlab, fn); else { if (comp->u.labeled.name[0] == '<') log_error(comp->l, "No loop to continue"); else log_error(comp->l, "No loop labeled %s", comp->u.labeled.name); } /* Callers expect generate_component to increase stack depth by 1 (*/ adjust_depth(1, fn); break; } case c_execute: { u16 count; generate_args(comp->u.execute->next, fn, &count); generate_execute(comp->u.execute->c, count, fn); break; } case c_builtin: args = comp->u.builtin.args; switch (comp->u.builtin.fn) { case b_if: generate_if(args->c, args->next->c, NULL, TRUE, fn); generate_component(component_undefined, NULL, FALSE, fn); break; case b_ifelse: generate_if(args->c, args->next->c, args->next->next->c, discard, fn); discard = FALSE; break; case b_sc_and: case b_sc_or: generate_if(comp, component_true, component_false, discard, fn); discard = FALSE; break; case b_while: enter_loop(fn); generate_while(args->c, args->next->c, mlabel, discard, fn); exit_loop(fn); discard = FALSE; break; case b_dowhile: enter_loop(fn); generate_dowhile(args->c, args->next->c, mlabel, discard, fn); exit_loop(fn); discard = FALSE; break; case b_for: enter_loop(fn); generate_for(args->c, args->next->c, args->next->next->c, args->next->next->next->c, mlabel, discard, fn); exit_loop(fn); discard = FALSE; break; default: { u16 count; assert(comp->u.builtin.fn < last_builtin); generate_args(args, fn, &count); ins0(builtin_ops[comp->u.builtin.fn], fn); break; } case b_cons: { u16 count; u16 goffset; mtype t; assert(comp->u.builtin.fn < last_builtin); generate_args(args, fn, &count); goffset = global_lookup(fnglobals(fn), builtin_functions[comp->u.builtin.fn], &t); mexecute(comp->l, goffset, NULL, count, fn); break; } } break; default: assert(0); } if (discard) ins0(OPmpop, fn); }