static void continue_prepare(struct compile_and_run_frame *frame) { value closure; struct global_state *gcopy; if (mprepare_load_next_start(&frame->ps)) return; mprepare_vars(&frame->ps); gcopy = copy_global_state(frame->ps.ccontext->gstate); GCPRO1(gcopy); closure = compile_code(frame->ps.ccontext->gstate, frame->f->body); GCPOP(1); if (closure) { GCPRO1(closure); if (debug_lvl > 1) output_value(muderr, prt_examine, closure); frame->state = running; if (frame->dontrun) { /* Just leave the closure itself as the result */ stack_reserve(sizeof(value)); stack_push(closure); } else push_closure(closure, 0); GCPOP(1); return; } global_set(frame->ps.ccontext->gstate, gcopy); runtime_error(error_compile_error); }
static struct closure *compile_code(struct global_state *gstate, clist b) { struct code *cc; u8 nb_locals; fncode top; location topl; struct string *afilename; /* Code strings must be allocated before code (immutability restriction) */ afilename = make_filename(lexloc.filename); GCPRO1(afilename); erred = FALSE; env_reset(); topl.filename = NULL; topl.lineno = 0; top = new_fncode(gstate, topl, TRUE, 0); env_push(NULL, top); /* Environment must not be totally empty */ generate_clist(b, FALSE, top); ins0(OPmreturn, top); env_pop(&nb_locals); cc = generate_fncode(top, nb_locals, NULL, NULL, afilename, 0); delete_fncode(top); GCPOP(1); if (erred) return NULL; else return alloc_closure0(cc); }
static value make_list(constant loc, cstlist csts, int has_tail, bool save_location, fncode fn) { struct list *l; if (has_tail && csts != NULL) { l = csts->cst ? make_constant(csts->cst, FALSE, fn) : NULL; csts = csts->next; } else l = NULL; GCPRO1(l); /* Remember that csts is in reverse order ... */ while (csts) { value tmp = make_constant(csts->cst, save_location, fn); l = alloc_list(tmp, l); SET_READONLY(l); SET_IMMUTABLE(l); csts = csts->next; } if (save_location) { value vloc = make_location(&loc->loc); l = alloc_list(vloc, l); SET_READONLY(l); SET_IMMUTABLE(l); } GCPOP(1); return l; }
static u16 global_add(struct global_state *gstate, struct string *name, value val) { struct symbol *pos; ivalue old_size, aindex; GCCHECK(val); GCPRO2(gstate, name); old_size = vector_len(gstate->environment->values); aindex = env_add_entry(gstate->environment, val); if (vector_len(gstate->environment->values) != old_size) /* Increase mvars too */ { struct vector *new_mvars = alloc_vector(vector_len(gstate->environment->values)); memcpy(new_mvars->data, gstate->mvars->data, gstate->mvars->o.size - sizeof(struct obj)); gstate->mvars = new_mvars; } GCPOP(2); gstate->mvars->data[aindex] = makeint(var_normal); pos = table_add_fast(gstate->global, name, makeint(aindex)); SET_READONLY(pos); /* index of global vars never changes */ return aindex; }
void delete_fncode(fncode fn) /* Effects: deletes fncode 'fn' */ { GCPOP(1); POP_LIST(fn->cstpro); free_block(fn->fnmemory); }
static void pcst(struct oport *f, instruction *i, char *insname) { value cst = RINSCST(i); GCPRO1(cst); pprintf(f, insname); GCPOP(1); _print_value(f, prt_examine, cst, 0); pprintf(f, "\n"); }
struct string *copy_string(struct string *s) { struct string *newp; uvalue size = string_len(s); GCPRO1(s); newp = alloc_string_n(size); memcpy(newp->str, s->str, size * sizeof(*s->str)); GCPOP(1); return newp; }
struct vector *copy_vector(struct vector *v) { struct vector *newp; uvalue size = vector_len(v); GCPRO1(v); newp = alloc_vector(size); memcpy(newp->data, v->data, size * sizeof(*v->data)); GCPOP(1); return newp; }
static value make_symbol(cstpair p, fncode fn) { struct symbol *sym; struct string *s = alloc_string(p->cst1->u.string); GCPRO1(s); SET_IMMUTABLE(s); SET_READONLY(s); sym = alloc_symbol(s, make_constant(p->cst2, FALSE, fn)); SET_IMMUTABLE(sym); SET_READONLY(sym); GCPOP(1); return sym; }
struct closure *alloc_closure0(struct code *code) { struct closure *newp; GCCHECK(code); GCPRO1(code); newp = (struct closure *)allocate_record(type_function, 1); GCPOP(1); newp->code = code; SET_READONLY(newp); return newp; }
CC compile_and_run(block_t region, struct global_state *gstate, const char *nicename, u8 *noreload, bool dontrun) { struct compile_and_run_frame *frame; struct compile_context *ccontext; GCPRO1(gstate); frame = push_frame(compile_and_run_action, sizeof(struct compile_and_run_frame)); ccontext = (struct compile_context *)allocate_record(type_vector, 2); frame->dontrun = dontrun; frame->ps.ccontext = ccontext; ccontext->gstate = gstate; /* no evaluation_state yet */ GCPOP(1); frame->state = init; if (!region) region = new_block(); frame->parser_block = region; /* Set filename */ lexloc.filename = bstrdup(region, nicename); normal_lexing(); if ((frame->f = parse(frame->parser_block))) { if (noreload) { if (frame->f->name && module_status(frame->ps.ccontext->gstate, frame->f->name) != module_unloaded) { free_block(frame->parser_block); *noreload = TRUE; FA_POP(&fp, &sp); return; } *noreload = FALSE; } if (mprepare(&frame->ps, frame->parser_block, frame->f)) { frame->state = preparing; continue_prepare(frame); return; } } runtime_error(error_compile_error); }
struct list *alloc_list(value car, value cdr) { struct list *newp; GCCHECK(car); GCCHECK(cdr); GCPRO2(car, cdr); newp = (struct list *)unsafe_allocate_record(type_pair, 2); GCPOP(2); newp->car = car; newp->cdr = cdr; return newp; }
static value make_table(cstlist csts, fncode fn) { struct table *t = alloc_table(DEF_TABLE_SIZE); GCPRO1(t); for (; csts; csts = csts->next) table_set(t, csts->cst->u.constpair->cst1->u.string, make_constant(csts->cst->u.constpair->cst2, FALSE, fn), NULL); table_foreach(t, protect_symbol); SET_READONLY(t); GCPOP(1); return t; }
static void make_global_state(int argc, const char **argv) { struct machine_specification *this_machine = (struct machine_specification *)allocate_record(type_vector, 4); struct extptr *tms; GCPRO1(this_machine); tms = alloc_extptr(&this_machine_specification); GCPOP(1); this_machine->c_machine_specification = tms; globals = new_global_state(this_machine); staticpro((value *)&globals); runtime_setup(globals, argc, argv); }
struct closure *unsafe_alloc_and_push_closure(u8 nb_variables) { /* This could (should?) be optimised to avoid the need for GCPRO1/stack_reserve/GCPOP */ struct closure *newp = (struct closure *)unsafe_allocate_record(type_function, nb_variables + 1); SET_READONLY(newp); GCPRO1(newp); stack_reserve(sizeof(value)); GCPOP(1); stack_push(newp); return newp; }
struct symbol *alloc_symbol(struct string *name, value data) { struct symbol *newp; GCCHECK(name); GCCHECK(data); GCPRO2(name, data); newp = (struct symbol *)unsafe_allocate_record(type_symbol, 2); GCPOP(2); newp->name = name; newp->data = data; return newp; }
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; }
struct global_state *new_global_state(struct machine_specification *machine) /* Returns: A new global state for a motlle interpreter for machine */ { struct global_state *gstate; GCPRO1(machine); gstate = (struct global_state *)allocate_record(type_vector, 5); GCPRO1(gstate); gstate->modules = alloc_table(DEF_TABLE_SIZE); gstate->mvars = alloc_vector(GLOBAL_SIZE); gstate->global = alloc_table(GLOBAL_SIZE); gstate->environment = alloc_env(GLOBAL_SIZE); gstate->machine = machine; GCPOP(2); return gstate; }
u16 global_lookup(struct global_state *gstate, const char *name) /* Returns: the index for global variable name in environment. If name doesn't exist yet, it is created with a variable whose value is NULL. */ { struct symbol *pos; struct string *tname; if (table_lookup(gstate->global, name, &pos)) return (u16)intval(pos->data); GCPRO1(gstate); tname = alloc_string(name); GCPOP(1); return global_add(gstate, tname, NULL); }
static void write_string(struct oport *p, prt_level level, struct string *print) { uvalue l = string_len(print); if (level == prt_display) pswrite(p, print, 0, l); else { unsigned char *str = (unsigned char *)alloca(l + 1); unsigned char *endstr; memcpy((char *)str, print->str, l + 1); GCPRO1(p); /* The NULL byte at the end doesn't count */ endstr = str + l; pputc('"', p); while (str < endstr) { unsigned char *pos = str; while (pos < endstr && writable(*pos)) pos++; opwrite(p, (char *)str, pos - str); if (pos < endstr) /* We stopped for a \ */ { pputc('\\', p); switch (*pos) { case '\\': case '"': pputc(*pos, p); break; case '\n': pputc('n', p); break; case '\r': pputc('r', p); break; case '\t': pputc('t', p); break; case '\f': pputc('f', p); break; default: pprintf(p, "%o", *pos); break; } str = pos + 1; } else str = pos; } pputc('"', p); GCPOP(1); } }
u16 mglobal_lookup(struct global_state *gstate, struct string *name) /* Returns: the index for global variable name in environment. If name doesn't exist yet, it is created with a variable whose value is NULL. */ { struct symbol *pos; struct string *tname; if (table_lookup(gstate->global, name->str, &pos)) return (u16)intval(pos->data); GCPRO2(gstate, name); tname = alloc_string_n(string_len(name)); strcpy(tname->str, name->str); GCPOP(2); return global_add(gstate, tname, NULL); }
static value make_quote(constant c, bool save_location, fncode fn) { struct list *l; value quote; l = alloc_list(make_constant(c->u.constant, save_location, fn), NULL); SET_READONLY(l); SET_IMMUTABLE(l); GCPRO1(l); quote = make_gsymbol("quote", fn); l = alloc_list(quote, l); SET_READONLY(l); SET_IMMUTABLE(l); if (save_location) { value loc = make_location(&c->loc); l = alloc_list(loc, l); SET_READONLY(l); SET_IMMUTABLE(l); } GCPOP(1); return l; }
static value make_array(cstlist csts, fncode fn) { struct list *l; struct vector *v; uvalue size = 0, i; cstlist scan; for (scan = csts; scan; scan = scan->next) size++; /* This intermediate step is necessary as v is IMMUTABLE (so must be allocated after its contents) */ l = make_list(NULL, csts, 0, FALSE, fn); GCPRO1(l); v = alloc_vector(size); SET_IMMUTABLE(v); SET_READONLY(v); GCPOP(1); for (i = 0; i < size; i++, l = l->cdr) v->data[i] = l->car; return v; }
static void write_code(struct oport *f, struct code *c) { u16 nbins, i; GCPRO2(f, c); nbins = code_length(c); if (c->varname) { write_string(f, prt_display, c->varname); pputs(": ", f); } pprintf(f, "Code["); write_string(f, prt_display, c->filename); pprintf(f, ":%u] %u bytes:\n", c->lineno, nbins); i = 0; while (i < nbins) i += write_instruction(f, c->ins + i, i); pprintf(f, "\n%u locals, %u stack\n", c->nb_locals, c->stkdepth); GCPOP(2); }
u16 global_add(struct global_state *gstate, const char *name, mtype t) /* Effects: adds name to global environment gstate, along with its type (t) If variable already exists, change its type to t. Returns: the new variable's index Modifies: gstate */ { struct string *tname; mtype current_type; u16 pos = global_lookup(gstate, name, ¤t_type); if (pos != GLOBAL_INVALID) { gstate->types->data[pos] = makeint(t); return pos; } GCPRO1(gstate); tname = alloc_string(name); GCPOP(1); return global_add1(gstate, tname, t, NULL); }
struct global_state *copy_global_state(struct global_state *gstate) /* Returns: A copy of global state gstate, which includes copying global variable and module state */ { struct global_state *newp; value tmp; GCPRO1(gstate); newp = (struct global_state *)allocate_record(type_vector, 8); GCPRO1(newp); tmp = copy_table(gstate->modules); newp->modules = tmp; tmp = copy_vector(gstate->mvars); newp->mvars = tmp; tmp = copy_vector(gstate->types); newp->types = tmp; tmp = copy_vector(gstate->names); newp->names = tmp; tmp = copy_table(gstate->global); newp->global = tmp; tmp = copy_table(gstate->gsymbols); newp->gsymbols = tmp; tmp = copy_env(gstate->environment); newp->environment = tmp; newp->machine = gstate->machine; GCPOP(2); return newp; }
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); }