# include "dgd.h" # include "str.h" # include "array.h" # include "object.h" # include "xfloat.h" # include "interpret.h" # include "data.h" # include "control.h" # include "csupport.h" # include "table.h" # ifdef DEBUG # undef EXTRA_STACK # define EXTRA_STACK 0 # endif static value stack[MIN_STACK]; /* initial stack */ frame *cframe; /* current frame */ static char *creator; /* creator function name */ static unsigned int clen; /* creator function name length */ value zero_value = { T_INT, TRUE }; value zero_float = { T_FLOAT, TRUE }; /* * NAME: interpret->init() * DESCRIPTION: initialize the interpreter */ void i_init(create) char *create; { static frame topframe; topframe.fp = topframe.sp = stack + MIN_STACK; topframe.stack = topframe.prev_ilvp = topframe.ilvp = stack; topframe.nodepth = TRUE; topframe.noticks = TRUE; cframe = &topframe; creator = create; clen = strlen(create); } /* * NAME: interpret->ref_value() * DESCRIPTION: reference a value */ void i_ref_value(v) register value *v; { switch (v->type) { case T_STRING: str_ref(v->u.string); break; case T_OBJECT: if (DESTRUCTED(v)) { *v = zero_value; } break; case T_ARRAY: case T_MAPPING: arr_ref(v->u.array); break; } } /* * NAME: interpret->del_value() * DESCRIPTION: dereference a value (not an lvalue) */ void i_del_value(v) register value *v; { switch (v->type) { case T_STRING: str_del(v->u.string); break; case T_ARRAY: case T_MAPPING: arr_del(v->u.array); break; } } /* * NAME: interpret->copy() * DESCRIPTION: copy values from one place to another */ void i_copy(v, w, len) register value *v, *w; register unsigned int len; { while (len != 0) { i_ref_value(w); *v++ = *w++; --len; } } /* * NAME: interpret->grow_stack() * DESCRIPTION: check if there is room on the stack for new values; if not, * make space */ void i_grow_stack(f, size) register frame *f; int size; { if (f->sp < f->ilvp + size + MIN_STACK) { register int spsize, ilsize; register value *v, *stk; register long offset; /* * extend the local stack */ spsize = f->fp - f->sp; ilsize = f->ilvp - f->stack; size = ALGN(spsize + ilsize + size + MIN_STACK, 8); stk = ALLOC(value, size); offset = (long) (stk + size) - (long) f->fp; /* copy indexed lvalue stack values */ v = stk; if (ilsize > 0) { memcpy(stk, f->stack, ilsize * sizeof(value)); do { if (v->type == T_LVALUE && v->u.lval >= f->sp && v->u.lval < f->fp) { v->u.lval = (value *) ((long) v->u.lval + offset); } v++; } while (--ilsize > 0); } f->ilvp = v; /* copy stack values */ v = stk + size; if (spsize > 0) { memcpy(v - spsize, f->sp, spsize * sizeof(value)); do { --v; if (v->type == T_LVALUE && v->u.lval >= f->sp && v->u.lval < f->fp) { v->u.lval = (value *) ((long) v->u.lval + offset); } } while (--spsize > 0); } f->sp = v; /* replace old stack */ if (f->sos) { /* stack on stack: alloca'd */ AFREE(f->stack); f->sos = FALSE; } else if (f->stack != stack) { FREE(f->stack); } f->stack = stk; f->fp = stk + size; } } /* * NAME: interpret->push_value() * DESCRIPTION: push a value on the stack */ void i_push_value(f, v) frame *f; register value *v; { *--f->sp = *v; switch (v->type) { case T_STRING: str_ref(v->u.string); break; case T_OBJECT: if (DESTRUCTED(v)) { /* * can't wipe out the original, since it may be a value from a * mapping */ *f->sp = zero_value; } break; case T_ARRAY: case T_MAPPING: arr_ref(v->u.array); break; } } /* * NAME: interpret->pop() * DESCRIPTION: pop a number of values (can be lvalues) from the stack */ void i_pop(f, n) register frame *f; register int n; { register value *v; for (v = f->sp; --n >= 0; v++) { switch (v->type) { case T_STRING: str_del(v->u.string); break; case T_ARRAY: case T_MAPPING: arr_del(v->u.array); break; case T_SALVALUE: --f->ilvp; case T_ALVALUE: arr_del((--f->ilvp)->u.array); break; case T_MLVALUE: case T_SMLVALUE: i_del_value(--f->ilvp); arr_del((--f->ilvp)->u.array); break; } } f->sp = v; } /* * NAME: interpret->odest() * DESCRIPTION: replace all occurrances of an object on the stack by 0 */ void i_odest(ftop, obj) frame *ftop; object *obj; { register Uint count; register value *v; register frame *f; count = obj->count; /* wipe out objects in stack frames */ v = ftop->sp; for (f = ftop; f != (frame *) NULL; f = f->prev) { while (v < f->fp) { if (v->type == T_OBJECT && v->u.objcnt == count) { *v = zero_value; } v++; } v = f->argp; } /* wipe out objects in indexed lvalue stack */ v = ftop->ilvp; for (f = ftop; f != (frame *) NULL; f = f->prev) { while (v >= f->stack) { if (v->type == T_OBJECT && v->u.objcnt == count) { *v = zero_value; } --v; } v = f->prev_ilvp; } } /* * NAME: interpret->string() * DESCRIPTION: push a string constant on the stack */ void i_string(f, inherit, index) frame *f; int inherit; unsigned int index; { (--f->sp)->type = T_STRING; str_ref(f->sp->u.string = d_get_strconst(f->p_ctrl, inherit, index)); } /* * NAME: interpret->aggregate() * DESCRIPTION: create an array on the stack */ void i_aggregate(f, size) register frame *f; register unsigned int size; { register array *a; if (size == 0) { a = arr_new(f->data, 0L); } else { register value *v, *elts; i_add_ticks(f, size); a = arr_new(f->data, (long) size); elts = a->elts + size; v = f->sp; do { *--elts = *v++; } while (--size != 0); d_ref_imports(a); f->sp = v; } (--f->sp)->type = T_ARRAY; arr_ref(f->sp->u.array = a); } /* * NAME: interpret->map_aggregate() * DESCRIPTION: create a mapping on the stack */ void i_map_aggregate(f, size) register frame *f; register unsigned int size; { register array *a; if (size == 0) { a = map_new(f->data, 0L); } else { register value *v, *elts; i_add_ticks(f, size); a = map_new(f->data, (long) size); elts = a->elts + size; v = f->sp; do { *--elts = *v++; } while (--size != 0); f->sp = v; if (ec_push((ec_ftn) NULL)) { /* error in sorting, delete mapping and pass on error */ arr_ref(a); arr_del(a); error((char *) NULL); } map_sort(a); ec_pop(); d_ref_imports(a); } (--f->sp)->type = T_MAPPING; arr_ref(f->sp->u.array = a); } /* * NAME: interpret->spread() * DESCRIPTION: push the values in an array on the stack, return the size * of the array - 1 */ int i_spread(f, n, vtype) register frame *f; register int n, vtype; { register array *a; register int i; register value *v; if (f->sp->type != T_ARRAY) { error("Spread of non-array"); } a = f->sp->u.array; if (n < 0 || n > a->size) { /* no lvalues */ n = a->size; } if (a->size > 0) { i_add_ticks(f, a->size); i_grow_stack(f, (a->size << 1) - n - 1); a->ref += a->size - n; } f->sp++; /* values */ for (i = 0, v = d_get_elts(a); i < n; i++, v++) { i_push_value(f, v); } /* lvalues */ for (n = a->size; i < n; i++) { f->ilvp->type = T_ARRAY; (f->ilvp++)->u.array = a; (--f->sp)->type = T_ALVALUE; f->sp->oindex = vtype; f->sp->u.number = i; } arr_del(a); return n - 1; } /* * NAME: interpret->global() * DESCRIPTION: push a global value on the stack */ void i_global(f, inherit, index) register frame *f; register int inherit, index; { i_add_ticks(f, 4); if (inherit != 0) { inherit = f->ctrl->inherits[f->p_index - inherit].varoffset; } i_push_value(f, d_get_variable(f->data, inherit + index)); } /* * NAME: interpret->global_lvalue() * DESCRIPTION: push a global lvalue on the stack */ void i_global_lvalue(f, inherit, index, vtype) register frame *f; register int inherit; int index, vtype; { i_add_ticks(f, 4); if (inherit != 0) { inherit = f->ctrl->inherits[f->p_index - inherit].varoffset; } (--f->sp)->type = T_LVALUE; f->sp->oindex = vtype; f->sp->u.lval = d_get_variable(f->data, inherit + index); } /* * NAME: interpret->index() * DESCRIPTION: index a value, REPLACING it by the indexed value */ void i_index(f) register frame *f; { register int i; register value *aval, *ival, *val; array *a; i_add_ticks(f, 2); ival = f->sp++; aval = f->sp; switch (aval->type) { case T_STRING: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric string index"); } i = UCHAR(aval->u.string->text[str_index(aval->u.string, (long) ival->u.number)]); str_del(aval->u.string); aval->type = T_INT; aval->u.number = i; return; case T_ARRAY: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric array index"); } val = &d_get_elts(aval->u.array)[arr_index(aval->u.array, (long) ival->u.number)]; break; case T_MAPPING: val = map_index(aval->u.array, ival, (value *) NULL); i_del_value(ival); break; default: i_del_value(ival); error("Index on bad type"); } a = aval->u.array; switch (val->type) { case T_STRING: str_ref(val->u.string); break; case T_OBJECT: if (DESTRUCTED(val)) { val = &zero_value; } break; case T_ARRAY: case T_MAPPING: arr_ref(val->u.array); break; } *aval = *val; arr_del(a); } /* * NAME: interpret->index_lvalue() * DESCRIPTION: Index a value, REPLACING it by an indexed lvalue. */ void i_index_lvalue(f, vtype) register frame *f; int vtype; { register int i; register value *lval, *ival, *val; i_add_ticks(f, 2); ival = f->sp++; lval = f->sp; switch (lval->type) { case T_STRING: /* for instance, "foo"[1] = 'a'; */ i_del_value(ival); error("Bad lvalue"); case T_ARRAY: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric array index"); } i = arr_index(lval->u.array, (long) ival->u.number); f->ilvp->type = T_ARRAY; (f->ilvp++)->u.array = lval->u.array; lval->type = T_ALVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_MAPPING: f->ilvp->type = T_ARRAY; (f->ilvp++)->u.array = lval->u.array; *f->ilvp++ = *ival; lval->type = T_MLVALUE; lval->oindex = vtype; return; case T_LVALUE: /* * note: the lvalue is not yet referenced */ switch (lval->u.lval->type) { case T_STRING: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric string index"); } i = str_index(f->lvstr = lval->u.lval->u.string, (long) ival->u.number); f->ilvp->type = T_LVALUE; (f->ilvp++)->u.lval = lval->u.lval; /* indexed string lvalues are not referenced */ lval->type = T_SLVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_ARRAY: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric array index"); } i = arr_index(lval->u.lval->u.array, (long) ival->u.number); f->ilvp->type = T_ARRAY; arr_ref((f->ilvp++)->u.array = lval->u.lval->u.array); lval->type = T_ALVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_MAPPING: f->ilvp->type = T_ARRAY; arr_ref((f->ilvp++)->u.array = lval->u.lval->u.array); *f->ilvp++ = *ival; lval->type = T_MLVALUE; lval->oindex = vtype; return; } break; case T_ALVALUE: val = &d_get_elts(f->ilvp[-1].u.array)[lval->u.number]; switch (val->type) { case T_STRING: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric string index"); } i = str_index(f->lvstr = val->u.string, (long) ival->u.number); f->ilvp->type = T_INT; (f->ilvp++)->u.number = lval->u.number; lval->type = T_SALVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_ARRAY: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric array index"); } i = arr_index(val->u.array, (long) ival->u.number); arr_ref(val->u.array); /* has to be first */ arr_del(f->ilvp[-1].u.array); /* has to be second */ f->ilvp[-1].u.array = val->u.array; lval->oindex = vtype; lval->u.number = i; return; case T_MAPPING: arr_ref(val->u.array); /* has to be first */ arr_del(f->ilvp[-1].u.array); /* has to be second */ f->ilvp[-1].u.array = val->u.array; *f->ilvp++ = *ival; lval->type = T_MLVALUE; lval->oindex = vtype; return; } break; case T_MLVALUE: val = map_index(f->ilvp[-2].u.array, &f->ilvp[-1], (value *) NULL); switch (val->type) { case T_STRING: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric string index"); } i = str_index(f->lvstr = val->u.string, (long) ival->u.number); lval->type = T_SMLVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_ARRAY: if (ival->type != T_INT) { i_del_value(ival); error("Non-numeric array index"); } i = arr_index(val->u.array, (long) ival->u.number); i_del_value(--f->ilvp); arr_ref(val->u.array); /* has to be first */ arr_del(f->ilvp[-1].u.array); /* has to be second */ f->ilvp[-1].u.array = val->u.array; lval->type = T_ALVALUE; lval->oindex = vtype; lval->u.number = i; return; case T_MAPPING: arr_ref(val->u.array); /* has to be first */ arr_del(f->ilvp[-2].u.array); /* has to be second */ f->ilvp[-2].u.array = val->u.array; i_del_value(&f->ilvp[-1]); f->ilvp[-1] = *ival; lval->oindex = vtype; return; } break; } i_del_value(ival); error("Index on bad type"); } /* * NAME: interpret->typename() * DESCRIPTION: return the name of the argument type */ char *i_typename(type) register unsigned int type; { static bool flag; static char buf1[8 + 8 + 1], buf2[8 + 8 + 1], *name[] = TYPENAMES; register char *buf; if (flag) { buf = buf1; flag = FALSE; } else { buf = buf2; flag = TRUE; } strcpy(buf, name[type & T_TYPE]); type &= T_REF; type >>= REFSHIFT; if (type > 0) { register char *p; p = buf + strlen(buf); *p++ = ' '; do { *p++ = '*'; } while (--type > 0); *p = '\0'; } return buf; } /* * NAME: interpret->cast() * DESCRIPTION: cast a value to a type */ void i_cast(val, type) register value *val; register unsigned int type; { char *tname; if (val->type != type && (val->type != T_INT || val->u.number != 0 || type == T_FLOAT)) { tname = i_typename(type); if (strchr("aeiuoy", tname[0]) != (char *) NULL) { error("Value is not an %s", tname); } else { error("Value is not a %s", tname); } } } /* * NAME: interpret->fetch() * DESCRIPTION: fetch the value of an lvalue */ void i_fetch(f) register frame *f; { switch (f->sp->type) { case T_LVALUE: i_push_value(f, f->sp->u.lval); break; case T_ALVALUE: i_push_value(f, d_get_elts(f->ilvp[-1].u.array) + f->sp->u.number); break; case T_MLVALUE: i_push_value(f, map_index(f->ilvp[-2].u.array, &f->ilvp[-1], (value *) NULL)); break; default: /* * Indexed string. * The fetch is always done directly after an lvalue * constructor, so lvstr is valid. */ (--f->sp)->type = T_INT; f->sp->u.number = UCHAR(f->lvstr->text[f->sp[1].u.number]); break; } } /* * NAME: istr() * DESCRIPTION: create a copy of the argument string, with one char replaced */ static value *istr(str, i, val) register string *str; unsigned short i; register value *val; { static value ret = { T_STRING }; if (val->type != T_INT) { error("Non-numeric value in indexed string assignment"); } if (str->primary == (strref *) NULL && str->ref == 1) { /* only reference to this string: don't copy */ ret.u.string = str; } else { ret.u.string = str_new(str->text, (long) str->len); } ret.u.string->text[i] = val->u.number; return &ret; } /* * NAME: interpret->store() * DESCRIPTION: Perform an assignment. This invalidates the lvalue. */ void i_store(f, lval, val) register frame *f; register value *lval, *val; { register value *v; register unsigned short i; register array *a; if (lval->oindex != 0) { i_cast(val, lval->oindex); } i_add_ticks(f, 1); switch (lval->type) { case T_LVALUE: d_assign_var(f->data, lval->u.lval, val); break; case T_SLVALUE: v = f->ilvp[-1].u.lval; i = lval->u.number; if (v->type != T_STRING || i >= v->u.string->len) { /* * The lvalue was changed. */ error("Lvalue disappeared!"); } --f->ilvp; d_assign_var(f->data, v, istr(v->u.string, i, val)); break; case T_ALVALUE: a = (--f->ilvp)->u.array; d_assign_elt(a, &d_get_elts(a)[lval->u.number], val); arr_del(a); break; case T_MLVALUE: map_index(a = f->ilvp[-2].u.array, &f->ilvp[-1], val); i_del_value(--f->ilvp); --f->ilvp; arr_del(a); break; case T_SALVALUE: a = f->ilvp[-2].u.array; v = &a->elts[f->ilvp[-1].u.number]; i = lval->u.number; if (v->type != T_STRING || i >= v->u.string->len) { /* * The lvalue was changed. */ error("Lvalue disappeared!"); } d_assign_elt(a, v, istr(v->u.string, i, val)); f->ilvp -= 2; arr_del(a); break; case T_SMLVALUE: a = f->ilvp[-2].u.array; v = map_index(a, &f->ilvp[-1], (value *) NULL); if (v->type != T_STRING || lval->u.number >= v->u.string->len) { /* * The lvalue was changed. */ error("Lvalue disappeared!"); } d_assign_elt(a, v, istr(v->u.string, (unsigned short) lval->u.number, val)); i_del_value(--f->ilvp); --f->ilvp; arr_del(a); break; } } typedef struct { Int depth; /* stack depth */ Int ticks; /* ticks left */ bool nodepth; /* no depth checking */ bool noticks; /* no ticks checking */ } rlinfo; static rlinfo rlstack[ERRSTACKSZ]; /* rlimits stack */ /* * NAME: interpret->get_depth() * DESCRIPTION: get the remaining stack depth (-1: infinite) */ Int i_get_depth(f) register frame *f; { if (f->nodepth) { return -1; } return f->maxdepth - f->depth; } /* * NAME: interpret->get_ticks() * DESCRIPTION: get the remaining ticks (-1: infinite) */ Int i_get_ticks(f) register frame *f; { if (f->noticks) { return -1; } else { return (f->ticks < 0) ? 0 : f->ticks; } } /* * NAME: interpret->check_rlimits() * DESCRIPTION: check if this rlimits call is valid */ static void i_check_rlimits(f) register frame *f; { if (f->obj->count == 0) { error("Illegal use of rlimits"); } --f->sp; f->sp[0] = f->sp[1]; f->sp[1] = f->sp[2]; f->sp[2].type = T_OBJECT; f->sp[2].oindex = f->obj->index; f->sp[2].u.objcnt = f->obj->count; /* obj, stack, ticks */ call_driver_object(f, "runtime_rlimits", 3); if ((f->sp->type == T_INT && f->sp->u.number == 0) || (f->sp->type == T_FLOAT && VFLT_ISZERO(f->sp))) { error("Illegal use of rlimits"); } i_del_value(f->sp++); } /* * NAME: interpret->set_rlimits() * DESCRIPTION: set new rlimits. Return an integer that can be used in * restoring the old values */ int i_set_rlimits(f, depth, t) register frame *f; Int depth, t; { if (f->rli == ERRSTACKSZ) { error("Too deep rlimits nesting"); } rlstack[f->rli].depth = f->maxdepth; rlstack[f->rli].nodepth = f->nodepth; rlstack[f->rli].noticks = f->noticks; if (depth != 0) { if (depth < 0) { f->nodepth = TRUE; } else { f->maxdepth = f->depth + depth; f->nodepth = FALSE; } } if (t != 0) { if (t < 0) { rlstack[f->rli].ticks = f->ticks; f->noticks = TRUE; } else { rlstack[f->rli].ticks = f->ticks - t; f->ticks = t; f->noticks = FALSE; } } else { rlstack[f->rli].ticks = 0; } return f->rli++; } /* * NAME: interpret->get_rllevel() * DESCRIPTION: return the current rlimits stack level */ int i_get_rllevel(f) frame *f; { return f->rli; } /* * NAME: interpret->set_rllevel() * DESCRIPTION: restore rlimits to an earlier level */ void i_set_rllevel(f, n) register frame *f; int n; { if (n < 0) { n += f->rli; } if (f->ticks < 0) { f->ticks = 0; } while (f->rli > n) { --f->rli; f->maxdepth = rlstack[f->rli].depth; if (f->noticks) { f->ticks = rlstack[f->rli].ticks; } else { f->ticks += rlstack[f->rli].ticks; } f->nodepth = rlstack[f->rli].nodepth; f->noticks = rlstack[f->rli].noticks; } } /* * NAME: interpret->set_sp() * DESCRIPTION: set the current stack pointer */ frame *i_set_sp(ftop, sp) frame *ftop; register value *sp; { register value *v, *w; register frame *f; v = ftop->sp; w = ftop->ilvp; for (f = ftop; f != NULL; f = f->prev) { for (;;) { if (v == sp) { f->sp = v; f->ilvp = w; f->ticks = ftop->ticks; return f; } if (v == f->fp) { break; } switch (v->type) { case T_STRING: str_del(v->u.string); break; case T_ARRAY: case T_MAPPING: arr_del(v->u.array); break; case T_SALVALUE: --w; case T_ALVALUE: arr_del((--w)->u.array); break; case T_MLVALUE: case T_SMLVALUE: i_del_value(--w); arr_del((--w)->u.array); break; } v++; } v = f->argp; w = f->prev_ilvp; if (f->sos) { /* stack on stack */ AFREE(f->stack); } else if (f->obj != (object *) NULL) { FREE(f->stack); } } f->sp = v; f->ilvp = w; f->ticks = ftop->ticks; return f; } /* * NAME: interpret->prev_object() * DESCRIPTION: return the nth previous object in the call_other chain */ object *i_prev_object(f, n) register frame *f; register int n; { while (n >= 0) { /* back to last external call */ while (!f->external) { f = f->prev; } f = f->prev; if (f->obj == (object *) NULL) { return (object *) NULL; } --n; } return (f->obj->count == 0) ? (object *) NULL : f->obj; } /* * NAME: interpret->prev_program() * DESCRIPTION: return the nth previous program in the function call chain */ char *i_prev_program(f, n) register frame *f; register int n; { while (n >= 0) { f = f->prev; if (f->obj == (object *) NULL) { return (char *) NULL; } --n; } return f->p_ctrl->obj->chain.name; } /* * NAME: interpret->typecheck() * DESCRIPTION: check the argument types given to a function */ void i_typecheck(f, name, ftype, proto, nargs, strict) register frame *f; char *name, *ftype; register char *proto; int nargs; int strict; { register int i, n, atype, ptype; register char *args; i = nargs; n = PROTO_NARGS(proto); args = PROTO_ARGS(proto); while (n > 0 && i > 0) { --i; ptype = UCHAR(*args); if (ptype & T_ELLIPSIS) { ptype &= ~T_ELLIPSIS; if (ptype == T_MIXED || ptype == T_LVALUE) { return; } } else { args++; --n; } if (ptype != T_MIXED) { atype = f->sp[i].type; if (ptype != atype && (atype != T_ARRAY || !(ptype & T_REF))) { if (atype != T_INT || f->sp[i].u.number != 0 || ptype == T_FLOAT) { /* wrong type */ error("Bad argument %d (%s) for %s %s", nargs - i, i_typename(atype), ftype, name); } else if (strict) { /* zero argument */ error("Bad argument %d for %s %s", nargs - i, ftype, name); } } } } } /* * NAME: interpret->switch_int() * DESCRIPTION: handle an int switch */ static unsigned short i_switch_int(f, pc) register frame *f; register char *pc; { register unsigned short h, l, m, sz, dflt; register Int num; register char *p; FETCH2U(pc, h); sz = FETCH1U(pc); FETCH2U(pc, dflt); if (f->sp->type != T_INT) { return dflt; } l = 0; --h; switch (sz) { case 1: while (l < h) { m = (l + h) >> 1; p = pc + 3 * m; num = FETCH1S(p); if (f->sp->u.number == num) { return FETCH2U(p, l); } else if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { l = m + 1; /* search in upper half */ } } break; case 2: while (l < h) { m = (l + h) >> 1; p = pc + 4 * m; FETCH2S(p, num); if (f->sp->u.number == num) { return FETCH2U(p, l); } else if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { l = m + 1; /* search in upper half */ } } break; case 3: while (l < h) { m = (l + h) >> 1; p = pc + 5 * m; FETCH3S(p, num); if (f->sp->u.number == num) { return FETCH2U(p, l); } else if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { l = m + 1; /* search in upper half */ } } break; case 4: while (l < h) { m = (l + h) >> 1; p = pc + 6 * m; FETCH4S(p, num); if (f->sp->u.number == num) { return FETCH2U(p, l); } else if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { l = m + 1; /* search in upper half */ } } break; } return dflt; } /* * NAME: interpret->switch_range() * DESCRIPTION: handle a range switch */ static unsigned short i_switch_range(f, pc) register frame *f; register char *pc; { register unsigned short h, l, m, sz, dflt; register Int num; register char *p; FETCH2U(pc, h); sz = FETCH1U(pc); FETCH2U(pc, dflt); if (f->sp->type != T_INT) { return dflt; } l = 0; --h; switch (sz) { case 1: while (l < h) { m = (l + h) >> 1; p = pc + 4 * m; num = FETCH1S(p); if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { num = FETCH1S(p); if (f->sp->u.number <= num) { return FETCH2U(p, l); } l = m + 1; /* search in upper half */ } } break; case 2: while (l < h) { m = (l + h) >> 1; p = pc + 6 * m; FETCH2S(p, num); if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { FETCH2S(p, num); if (f->sp->u.number <= num) { return FETCH2U(p, l); } l = m + 1; /* search in upper half */ } } break; case 3: while (l < h) { m = (l + h) >> 1; p = pc + 8 * m; FETCH3S(p, num); if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { FETCH3S(p, num); if (f->sp->u.number <= num) { return FETCH2U(p, l); } l = m + 1; /* search in upper half */ } } break; case 4: while (l < h) { m = (l + h) >> 1; p = pc + 10 * m; FETCH4S(p, num); if (f->sp->u.number < num) { h = m; /* search in lower half */ } else { FETCH4S(p, num); if (f->sp->u.number <= num) { return FETCH2U(p, l); } l = m + 1; /* search in upper half */ } } break; } return dflt; } /* * NAME: interpret->switch_str() * DESCRIPTION: handle a string switch */ static unsigned short i_switch_str(f, pc) register frame *f; register char *pc; { register unsigned short h, l, m, u, u2, dflt; register int cmp; register char *p; register control *ctrl; FETCH2U(pc, h); FETCH2U(pc, dflt); if (FETCH1U(pc) == 0) { FETCH2U(pc, l); if (f->sp->type == T_INT && f->sp->u.number == 0) { return l; } --h; } if (f->sp->type != T_STRING) { return dflt; } ctrl = f->p_ctrl; l = 0; --h; while (l < h) { m = (l + h) >> 1; p = pc + 5 * m; u = FETCH1U(p); cmp = str_cmp(f->sp->u.string, d_get_strconst(ctrl, u, FETCH2U(p, u2))); if (cmp == 0) { return FETCH2U(p, l); } else if (cmp < 0) { h = m; /* search in lower half */ } else { l = m + 1; /* search in upper half */ } } return dflt; } /* * NAME: interpret->catcherr() * DESCRIPTION: handle caught error */ void i_catcherr(f, depth) frame *f; Int depth; { i_runtime_error(f, depth + 1); } /* * NAME: interpret->interpret() * DESCRIPTION: Main interpreter function. Interpret stack machine code. */ static void i_interpret(f, pc) register frame *f; register char *pc; { register unsigned short instr, u, u2; register Uint l; register char *p; register kfunc *kf; xfloat flt; int size; Int newdepth, newticks; size = 0; for (;;) { # ifdef DEBUG if (f->sp < f->ilvp + MIN_STACK) { fatal("out of value stack"); } # endif if (--f->ticks <= 0) { if (f->noticks) { f->ticks = 0x7fffffff; } else { error("Out of ticks"); } } instr = FETCH1U(pc); f->pc = pc; switch (instr & I_INSTR_MASK) { case I_PUSH_ZERO: *--f->sp = zero_value; break; case I_PUSH_ONE: (--f->sp)->type = T_INT; f->sp->u.number = 1; break; case I_PUSH_INT1: (--f->sp)->type = T_INT; f->sp->u.number = FETCH1S(pc); break; case I_PUSH_INT4: (--f->sp)->type = T_INT; f->sp->u.number = FETCH4S(pc, l); break; case I_PUSH_FLOAT: (--f->sp)->type = T_FLOAT; flt.high = FETCH2U(pc, u); flt.low = FETCH4U(pc, l); VFLT_PUT(f->sp, flt); break; case I_PUSH_STRING: (--f->sp)->type = T_STRING; str_ref(f->sp->u.string = d_get_strconst(f->p_ctrl, f->p_ctrl->ninherits - 1, FETCH1U(pc))); break; case I_PUSH_NEAR_STRING: (--f->sp)->type = T_STRING; u = FETCH1U(pc); str_ref(f->sp->u.string = d_get_strconst(f->p_ctrl, u, FETCH1U(pc))); break; case I_PUSH_FAR_STRING: (--f->sp)->type = T_STRING; u = FETCH1U(pc); str_ref(f->sp->u.string = d_get_strconst(f->p_ctrl, u, FETCH2U(pc, u2))); break; case I_PUSH_LOCAL: u = FETCH1S(pc); i_push_value(f, ((short) u < 0) ? f->fp + (short) u : f->argp + u); break; case I_PUSH_GLOBAL: u = f->ctrl->inherits[f->p_index - 1].varoffset + FETCH1U(pc); i_push_value(f, d_get_variable(f->data, u)); break; case I_PUSH_FAR_GLOBAL: u = FETCH1U(pc); if (u != 0) { u = f->ctrl->inherits[f->p_index - u].varoffset; } i_push_value(f, d_get_variable(f->data, u + FETCH1U(pc))); break; case I_PUSH_LOCAL_LVAL: (--f->sp)->type = T_LVALUE; u = FETCH1S(pc); f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0; f->sp->u.lval = ((short) u < 0) ? f->fp + (short) u : f->argp + u; continue; case I_PUSH_GLOBAL_LVAL: u = f->ctrl->inherits[f->p_index - 1].varoffset + FETCH1U(pc); (--f->sp)->type = T_LVALUE; f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0; f->sp->u.lval = d_get_variable(f->data, u); continue; case I_PUSH_FAR_GLOBAL_LVAL: u = FETCH1U(pc); if (u != 0) { u = f->ctrl->inherits[f->p_index - u].varoffset; } u += FETCH1U(pc); (--f->sp)->type = T_LVALUE; f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0; f->sp->u.lval = d_get_variable(f->data, u); continue; case I_INDEX: i_index(f); break; case I_INDEX_LVAL: i_index_lvalue(f, (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0); continue; case I_AGGREGATE: if (FETCH1U(pc) == 0) { i_aggregate(f, FETCH2U(pc, u)); } else { i_map_aggregate(f, FETCH2U(pc, u)); } break; case I_SPREAD: u = FETCH1S(pc); size = i_spread(f, (short) u, (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0); continue; case I_CAST: i_cast(f->sp, FETCH1U(pc)); break; case I_FETCH: i_fetch(f); break; case I_STORE: i_store(f, f->sp + 1, f->sp); f->sp[1] = f->sp[0]; f->sp++; break; case I_JUMP: p = f->prog + FETCH2U(pc, u); pc = p; break; case I_JUMP_ZERO: p = f->prog + FETCH2U(pc, u); if ((f->sp->type == T_INT && f->sp->u.number == 0) || (f->sp->type == T_FLOAT && VFLT_ISZERO(f->sp))) { pc = p; } break; case I_JUMP_NONZERO: p = f->prog + FETCH2U(pc, u); if ((f->sp->type != T_INT || f->sp->u.number != 0) && (f->sp->type != T_FLOAT || !VFLT_ISZERO(f->sp))) { pc = p; } break; case I_SWITCH: switch (FETCH1U(pc)) { case 0: pc = f->prog + i_switch_int(f, pc); break; case 1: pc = f->prog + i_switch_range(f, pc); break; case 2: pc = f->prog + i_switch_str(f, pc); break; } break; case I_CALL_KFUNC: kf = &KFUN(FETCH1U(pc)); if (PROTO_CLASS(kf->proto) & C_VARARGS) { /* variable # of arguments */ u = FETCH1U(pc) + size; size = 0; } else { /* fixed # of arguments */ u = PROTO_NARGS(kf->proto); } if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) { i_typecheck(f, kf->name, "kfun", kf->proto, u, TRUE); } u = (*kf->func)(f, u); if (u != 0) { if ((short) u < 0) { error("Too few arguments for kfun %s", kf->name); } else if (u <= PROTO_NARGS(kf->proto)) { error("Bad argument %d for kfun %s", u, kf->name); } else { error("Too many arguments for kfun %s", kf->name); } } break; case I_CALL_AFUNC: u = FETCH1U(pc); i_funcall(f, (object *) NULL, 0, u, FETCH1U(pc) + size); size = 0; break; case I_CALL_DFUNC: u = FETCH1U(pc); if (u != 0) { u = f->p_index - u; } u2 = FETCH1U(pc); i_funcall(f, (object *) NULL, u, u2, FETCH1U(pc) + size); size = 0; break; case I_CALL_FUNC: p = &f->ctrl->funcalls[2L * (f->foffset + FETCH2U(pc, u))]; i_funcall(f, (object *) NULL, UCHAR(p[0]), UCHAR(p[1]), FETCH1U(pc) + size); size = 0; break; case I_CATCH: p = f->prog + FETCH2U(pc, u); u = f->rli; if (!ec_push((ec_ftn) i_catcherr)) { i_interpret(f, pc); ec_pop(); pc = f->pc; *--f->sp = zero_value; } else { /* error */ f->pc = pc = p; p = errormesg(); (--f->sp)->type = T_STRING; str_ref(f->sp->u.string = str_new(p, (long) strlen(p))); i_set_rllevel(f, u); } break; case I_RLIMITS: if (f->sp[1].type != T_INT) { error("Bad rlimits depth type"); } if (f->sp->type != T_INT) { error("Bad rlimits ticks type"); } newdepth = f->sp[1].u.number; newticks = f->sp->u.number; if (!FETCH1U(pc)) { /* runtime check */ i_check_rlimits(f); } else { /* pop limits */ f->sp += 2; } i_set_rlimits(f, newdepth, newticks); i_interpret(f, pc); pc = f->pc; i_set_rllevel(f, -1); break; case I_RETURN: return; } if (instr & I_POP_BIT) { /* pop the result of the last operation (never an lvalue) */ i_del_value(f->sp++); } } } /* * NAME: interpret->funcall() * DESCRIPTION: Call a function in an object. The arguments must be on the * stack already. */ void i_funcall(prev_f, obj, p_ctrli, funci, nargs) register frame *prev_f; register object *obj; register int p_ctrli, nargs; int funci; { register char *pc; register unsigned short n; frame f; value val; f.prev = prev_f; if (prev_f->obj == (object *) NULL) { /* * top level call */ f.obj = obj; f.ctrl = obj->ctrl; f.data = o_dataspace(obj); f.depth = 0; f.external = TRUE; } else if (obj != (object *) NULL) { /* * call_other */ f.obj = obj; f.ctrl = obj->ctrl; f.data = o_dataspace(obj); f.depth = prev_f->depth + 1; f.external = TRUE; } else { /* * local function call */ f.obj = prev_f->obj; f.ctrl = prev_f->ctrl; f.data = prev_f->data; f.depth = prev_f->depth + 1; f.external = FALSE; } f.maxdepth = prev_f->maxdepth; f.nodepth = prev_f->nodepth; if (f.depth >= f.maxdepth && !f.nodepth) { error("Stack overflow"); } f.ticks = prev_f->ticks; f.noticks = prev_f->noticks; if (f.ticks < 100) { if (f.noticks) { f.ticks = 0x7fffffff; } else { error("Out of ticks"); } } f.rli = prev_f->rli; /* set the program control block */ f.foffset = f.ctrl->inherits[p_ctrli].funcoffset; f.p_ctrl = o_control(f.ctrl->inherits[p_ctrli].obj); f.p_index = p_ctrli + 1; /* get the function */ f.func = &d_get_funcdefs(f.p_ctrl)[funci]; if (f.func->class & C_UNDEFINED) { error("Undefined function %s", d_get_strconst(f.p_ctrl, f.func->inherit, f.func->index)->text); } pc = d_get_prog(f.p_ctrl) + f.func->offset; if (PROTO_CLASS(pc) & C_TYPECHECKED) { /* typecheck arguments */ i_typecheck(prev_f, d_get_strconst(f.p_ctrl, f.func->inherit, f.func->index)->text, "function", pc, nargs, FALSE); } /* handle arguments */ n = PROTO_NARGS(pc); if (n > 0 && (PROTO_ARGS(pc)[n - 1] & T_ELLIPSIS)) { register value *v; array *a; if (nargs >= n) { /* put additional arguments in array */ nargs -= n - 1; a = arr_new(f.data, (long) nargs); v = a->elts + nargs; do { *--v = *prev_f->sp++; } while (--nargs > 0); d_ref_imports(a); nargs = n; } else { /* make empty arguments array, and optionally push zeroes */ i_grow_stack(prev_f, n - nargs); while (++nargs < n) { *--prev_f->sp = zero_value; } a = arr_new(f.data, 0L); } (--prev_f->sp)->type = T_ARRAY; arr_ref(prev_f->sp->u.array = a); } else { if (nargs > n) { /* pop superfluous arguments */ i_pop(prev_f, nargs - n); nargs = n; } else if (nargs < n) { /* add missing arguments */ i_grow_stack(prev_f, n - nargs); do { *--prev_f->sp = zero_value; } while (++nargs < n); } } f.argp = prev_f->sp; cframe = &f; f.nargs = nargs; pc += PROTO_SIZE(pc); /* create new local stack */ f.prev_ilvp = prev_f->ilvp; FETCH2U(pc, n); f.stack = f.ilvp = ALLOCA(value, n + MIN_STACK + EXTRA_STACK); f.fp = f.sp = f.stack + n + MIN_STACK + EXTRA_STACK; f.sos = TRUE; /* initialize local variables */ n = FETCH1U(pc); # ifdef DEBUG nargs = n; # endif if (n > 0) { do { *--f.sp = zero_value; } while (--n > 0); } /* execute code */ i_add_ticks(&f, 10); d_get_funcalls(f.ctrl); /* make sure they are available */ if (f.func->class & C_COMPILED) { Uint l; /* compiled function */ (*pcfunctions[FETCH3U(pc, l)])(&f); } else { /* interpreted function */ f.prog = pc += 2; i_interpret(&f, pc); } /* clean up stack, move return value to outer stackframe */ val = *f.sp++; # ifdef DEBUG if (f.sp != f.fp - nargs) { fatal("bad stack pointer after function call"); } # endif i_pop(&f, f.fp - f.sp); if (f.sos) { /* still alloca'd */ AFREE(f.stack); } else { /* extended and malloced */ FREE(f.stack); } prev_f->ticks = f.ticks; cframe = prev_f; i_pop(prev_f, f.nargs); *--prev_f->sp = val; } /* * NAME: interpret->call() * DESCRIPTION: Attempt to call a function in an object. Return TRUE if * the call succeeded. */ bool i_call(f, obj, func, len, call_static, nargs) frame *f; object *obj; char *func; unsigned int len; int call_static; int nargs; { register dsymbol *symb; register dfuncdef *fdef; register control *ctrl; ctrl = o_control(obj); if (!(obj->flags & O_CREATED)) { /* * initialize the object */ obj->flags |= O_CREATED; if (i_call(f, obj, creator, clen, TRUE, 0)) { i_del_value(f->sp++); } } /* find the function in the symbol table */ symb = ctrl_symb(ctrl, func, len); if (symb == (dsymbol *) NULL) { /* function doesn't exist in symbol table */ i_pop(f, nargs); return FALSE; } ctrl = ctrl->inherits[UCHAR(symb->inherit)].obj->ctrl; fdef = &d_get_funcdefs(ctrl)[UCHAR(symb->index)]; /* check if the function can be called */ if (!call_static && (fdef->class & C_STATIC) && f->obj != obj) { i_pop(f, nargs); return FALSE; } /* call the function */ i_funcall(f, obj, UCHAR(symb->inherit), UCHAR(symb->index), nargs); return TRUE; } /* * NAME: interpret->line() * DESCRIPTION: return the line number the program counter of the specified * frame is at */ static unsigned short i_line(f) register frame *f; { register char *pc, *numbers; register int instr; register short offset; register unsigned short line, u, sz; line = 0; pc = f->p_ctrl->prog + f->func->offset; pc += PROTO_SIZE(pc) + 3; FETCH2U(pc, u); numbers = pc + u; while (pc < f->pc) { instr = FETCH1U(pc); offset = instr >> I_LINE_SHIFT; if (offset <= 2) { /* simple offset */ line += offset; } else { offset = FETCH1U(numbers); if (offset >= 128) { /* one byte offset */ line += offset - 128 - 64; } else { /* two byte offset */ line += ((offset << 8) | FETCH1U(numbers)) - 16384; } } switch (instr & I_INSTR_MASK) { case I_INDEX_LVAL: if (instr & I_TYPE_BIT) { pc++; } /* fall through */ case I_PUSH_ZERO: case I_PUSH_ONE: case I_INDEX: case I_FETCH: case I_STORE: case I_RETURN: break; case I_PUSH_LOCAL_LVAL: case I_PUSH_GLOBAL_LVAL: if (instr & I_TYPE_BIT) { pc++; } /* fall through */ case I_PUSH_INT1: case I_PUSH_STRING: case I_PUSH_LOCAL: case I_PUSH_GLOBAL: case I_SPREAD: case I_CAST: case I_RLIMITS: pc++; break; case I_PUSH_FAR_GLOBAL_LVAL: if (instr & I_TYPE_BIT) { pc++; } /* fall through */ case I_PUSH_NEAR_STRING: case I_PUSH_FAR_GLOBAL: case I_JUMP: case I_JUMP_ZERO: case I_JUMP_NONZERO: case I_CALL_AFUNC: case I_CATCH: pc += 2; break; case I_PUSH_FAR_STRING: case I_AGGREGATE: case I_CALL_DFUNC: case I_CALL_FUNC: pc += 3; break; case I_PUSH_INT4: pc += 4; break; case I_PUSH_FLOAT: pc += 6; break; case I_SWITCH: switch (FETCH1U(pc)) { case 0: FETCH2U(pc, u); sz = FETCH1U(pc); pc += 2 + (u - 1) * (sz + 2); break; case 1: FETCH2U(pc, u); sz = FETCH1U(pc); pc += 2 + (u - 1) * (2 * sz + 2); break; case 2: FETCH2U(pc, u); pc += 2; if (FETCH1U(pc) == 0) { pc += 2; --u; } pc += (u - 1) * 5; break; } break; case I_CALL_KFUNC: if (PROTO_CLASS(KFUN(FETCH1U(pc)).proto) & C_VARARGS) { pc++; } break; } } return line; } /* * NAME: interpret->func_trace() * DESCRIPTION: return the trace of a single function */ static array *i_func_trace(f, data) register frame *f; dataspace *data; { register value *v; register string *str; register char *name; register unsigned short n; register value *args; array *a; unsigned short max_args; max_args = conf_array_size() - 5; n = f->nargs; args = f->argp + n; if (n > max_args) { /* unlikely, but possible */ n = max_args; } a = arr_new(data, n + 5L); v = a->elts; /* object name */ name = o_name(f->obj); v[0].type = T_STRING; str = str_new((char *) NULL, strlen(name) + 1L); str->text[0] = '/'; strcpy(str->text + 1, name); str_ref(v[0].u.string = str); /* program name */ name = f->p_ctrl->obj->chain.name; v[1].type = T_STRING; str = str_new((char *) NULL, strlen(name) + 1L); str->text[0] = '/'; strcpy(str->text + 1, name); str_ref(v[1].u.string = str); /* function name */ v[2].type = T_STRING; str_ref(v[2].u.string = d_get_strconst(f->p_ctrl, f->func->inherit, f->func->index)); /* line number */ v[3].type = T_INT; if (f->func->class & C_COMPILED) { v[3].u.number = 0; } else { v[3].u.number = i_line(f); } /* external flag */ v[4].type = T_INT; v[4].u.number = f->external; /* arguments */ v += 5; while (n > 0) { *v++ = *--args; i_ref_value(args); --n; } d_ref_imports(a); return a; } /* * NAME: interpret->call_tracei() * DESCRIPTION: get the trace of a single function */ bool i_call_tracei(ftop, idx, v) frame *ftop; Int idx; value *v; { register frame *f; register unsigned short n; for (f = ftop, n = 0; f->obj != (object *) NULL; f = f->prev, n++) ; if (idx < 0 || idx >= n) { return FALSE; } for (f = ftop, n -= idx + 1; n != 0; f = f->prev, --n) ; v->type = T_ARRAY; arr_ref(v->u.array = i_func_trace(f, ftop->data)); return TRUE; } /* * NAME: interpret->call_trace() * DESCRIPTION: return the function call trace */ array *i_call_trace(ftop) register frame *ftop; { register frame *f; register value *v; register unsigned short n; array *a; for (f = ftop, n = 0; f->obj != (object *) NULL; f = f->prev, n++) ; a = arr_new(ftop->data, (long) n); i_add_ticks(ftop, 10 * n); for (f = ftop, v = a->elts + n; f->obj != (object *) NULL; f = f->prev) { (--v)->type = T_ARRAY; arr_ref(v->u.array = i_func_trace(f, ftop->data)); } return a; } /* * NAME: interpret->call_critical() * DESCRIPTION: Call a function in the driver object at a critical moment. * The function is called with rlimits (-1; -1) and errors * caught. */ bool i_call_critical(f, func, narg, flag) register frame *f; char *func; int narg, flag; { bool xnodepth, xnoticks, ok; Int xticks; xnodepth = f->nodepth; xnoticks = f->noticks; xticks = f->ticks; f->nodepth = TRUE; f->noticks = TRUE; f->sp += narg; /* so the error context knows what to pop */ if (ec_push((flag) ? (ec_ftn) i_catcherr : (ec_ftn) NULL)) { ok = FALSE; } else { f->sp -= narg; /* recover arguments */ call_driver_object(f, func, narg); ec_pop(); ok = TRUE; } f->nodepth = xnodepth; f->noticks = xnoticks; f->ticks = xticks; return ok; } /* * NAME: interpret->runtime_error() * DESCRIPTION: handle a runtime error */ void i_runtime_error(f, depth) register frame *f; Int depth; { char *err; err = errormesg(); (--f->sp)->type = T_STRING; str_ref(f->sp->u.string = str_new(err, (long) strlen(err))); (--f->sp)->type = T_INT; f->sp->u.number = depth; (--f->sp)->type = T_INT; f->sp->u.number = i_get_ticks(f); if (!i_call_critical(f, "runtime_error", 3, FALSE)) { message("Error within runtime_error:\012"); /* LF */ message((char *) NULL); } else { i_del_value(f->sp++); } } /* * NAME: interpret->clear() * DESCRIPTION: clean up the interpreter state */ void i_clear() { register frame *f; f = cframe; if (f->stack != stack) { FREE(f->stack); f->fp = f->sp = stack + MIN_STACK; f->stack = f->prev_ilvp = f->ilvp = stack; } f->nodepth = TRUE; f->noticks = TRUE; f->rli = 0; }