/*
* This file is part of DGD, http://dgd-osr.sourceforge.net/
* Copyright (C) 1993-2010 Dworkin B.V.
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU Affero General Public License as
* published by the Free Software Foundation, either version 3 of the
* License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Affero General Public License for more details.
*
* You should have received a copy of the GNU Affero General Public License
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
# 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
typedef struct _inhash_ {
Uint ocount; /* object count */
uindex iindex; /* inherit index */
uindex coindex; /* class name program reference */
Uint class; /* class name string reference */
} inhash;
static value stack[MIN_STACK]; /* initial stack */
static frame topframe; /* top frame */
static rlinfo rlim; /* top rlimits info */
frame *cframe; /* current frame */
static char *creator; /* creator function name */
static unsigned int clen; /* creator function name length */
static bool stricttc; /* strict typechecking */
static inhash ihash[INHASHSZ]; /* instanceof hashtable */
int nil_type; /* type of nil value */
value zero_int = { T_INT, TRUE };
value zero_float = { T_FLOAT, TRUE };
value nil_value = { T_NIL, TRUE };
/*
* NAME: interpret->init()
* DESCRIPTION: initialize the interpreter
*/
void i_init(create, flag)
char *create;
int flag;
{
topframe.oindex = OBJ_NONE;
topframe.fp = topframe.sp = stack + MIN_STACK;
topframe.stack = topframe.lip = stack;
rlim.nodepth = TRUE;
rlim.noticks = TRUE;
topframe.rlim = &rlim;
topframe.level = 0;
topframe.atomic = FALSE;
cframe = &topframe;
creator = create;
clen = strlen(create);
stricttc = flag;
nil_value.type = nil_type = (stricttc) ? T_NIL : T_INT;
}
/*
* 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_ARRAY:
case T_MAPPING:
case T_LWOBJECT:
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:
case T_LWOBJECT:
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;
{
register value *o;
for ( ; len != 0; --len) {
switch (w->type) {
case T_STRING:
str_ref(w->u.string);
break;
case T_OBJECT:
if (DESTRUCTED(w)) {
*v++ = nil_value;
w++;
continue;
}
break;
case T_LWOBJECT:
o = d_get_elts(w->u.array);
if (DESTRUCTED(o)) {
*v++ = nil_value;
w++;
continue;
}
/* fall through */
case T_ARRAY:
case T_MAPPING:
arr_ref(w->u.array);
break;
}
*v++ = *w++;
}
}
/*
* 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->lip + size + MIN_STACK) {
register int spsize, lisize;
register value *v, *stk;
register long offset;
/*
* extend the local stack
*/
spsize = f->fp - f->sp;
lisize = f->lip - f->stack;
size = ALGN(spsize + lisize + size + MIN_STACK, 8);
stk = ALLOC(value, size);
offset = (long) (stk + size) - (long) f->fp;
/* move lvalue index stack values */
if (lisize != 0) {
memcpy(stk, f->stack, lisize * sizeof(value));
}
f->lip = stk + lisize;
/* move stack values */
v = stk + size;
if (spsize != 0) {
memcpy(v - spsize, f->sp, spsize * sizeof(value));
do {
--v;
if ((v->type == T_LVALUE || v->type == T_SLVALUE) &&
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;
{
register value *o;
*--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 = nil_value;
}
break;
case T_LWOBJECT:
o = d_get_elts(v->u.array);
if (DESTRUCTED(o)) {
/*
* can't wipe out the original, since it may be a value from a
* mapping
*/
*f->sp = nil_value;
break;
}
/* fall through */
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_LVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
break;
case T_ALVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
--f->lip;
case T_ARRAY:
case T_MAPPING:
case T_LWOBJECT:
arr_del(v->u.array);
break;
case T_SLVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
str_del((--f->lip)->u.string);
break;
case T_MLVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
i_del_value(--f->lip);
arr_del(v->u.array);
break;
case T_SALVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
str_del((--f->lip)->u.string);
--f->lip;
arr_del(v->u.array);
break;
case T_SMLVALUE:
if (v->oindex == T_CLASS) {
--f->lip;
}
str_del((--f->lip)->u.string);
i_del_value(--f->lip);
arr_del(v->u.array);
break;
}
}
f->sp = v;
}
/*
* NAME: interpret->reverse()
* DESCRIPTION: reverse the order of arguments on the stack
*/
void i_reverse(f, n)
frame *f;
register int n;
{
value sp[MAX_LOCALS];
value lip[3 * MAX_LOCALS];
register value *v1, *v2, *w1, *w2;
if (n > 1) {
/*
* more than one argument
*/
v1 = f->sp;
v2 = sp;
w1 = lip;
w2 = f->lip;
memcpy(v2, v1, n * sizeof(value));
v1 += n;
do {
switch (v2->type) {
case T_LVALUE:
if (v2->oindex == T_CLASS) {
*w1++ = *--w2;
}
break;
case T_SLVALUE:
case T_ALVALUE:
case T_MLVALUE:
if (v2->oindex == T_CLASS) {
w2 -= 2;
*w1++ = w2[0];
*w1++ = w2[1];
} else {
*w1++ = *--w2;
}
break;
case T_SALVALUE:
case T_SMLVALUE:
if (v2->oindex == T_CLASS) {
w2 -= 3;
*w1++ = w2[0];
*w1++ = w2[1];
*w1++ = w2[2];
} else {
w2 -= 2;
*w1++ = w2[0];
*w1++ = w2[1];
}
break;
}
*--v1 = *v2++;
} while (--n != 0);
/*
* copy back lvalue indices, if needed
*/
n = f->lip - w2;
if (n > 1) {
memcpy(w2, lip, n * sizeof(value));
}
}
}
/*
* NAME: interpret->odest()
* DESCRIPTION: replace all occurrances of an object on the stack by nil
*/
void i_odest(prev, obj)
register frame *prev;
object *obj;
{
register frame *f;
register Uint count;
register value *v;
register unsigned short n;
count = obj->count;
/* wipe out objects in stack frames */
for (;;) {
f = prev;
for (v = f->sp; v < f->fp; v++) {
switch (v->type) {
case T_OBJECT:
if (v->u.objcnt == count) {
*v = nil_value;
}
break;
case T_LWOBJECT:
if (v->u.array->elts[0].u.objcnt == count) {
arr_del(v->u.array);
*v = nil_value;
}
break;
}
}
for (v = f->lip; --v >= f->stack; ) {
switch (v->type) {
case T_OBJECT:
if (v->u.objcnt == count) {
*v = nil_value;
}
break;
case T_LWOBJECT:
if (v->u.array->elts[0].u.objcnt == count) {
arr_del(v->u.array);
*v = nil_value;
}
break;
}
}
prev = f->prev;
if (prev == (frame *) NULL) {
break;
}
if ((f->func->class & C_ATOMIC) && !prev->atomic) {
/*
* wipe out objects in arguments to atomic function call
*/
for (n = f->nargs, v = prev->sp; n != 0; --n, v++) {
switch (v->type) {
case T_OBJECT:
if (v->u.objcnt == count) {
*v = nil_value;
}
break;
case T_LWOBJECT:
if (v->u.array->elts[0].u.objcnt == count) {
arr_del(v->u.array);
*v = nil_value;
}
break;
}
}
break;
}
}
}
/*
* NAME: interpret->string()
* DESCRIPTION: push a string constant on the stack
*/
void i_string(f, inherit, index)
frame *f;
int inherit;
unsigned int index;
{
PUSH_STRVAL(f, 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;
}
PUSH_ARRVAL(f, 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);
}
PUSH_MAPVAL(f, 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, class)
register frame *f;
register int n, vtype;
Uint class;
{
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->sp)->type = T_ALVALUE;
f->sp->oindex = vtype;
f->sp->u.array = a;
f->lip->type = T_INT;
(f->lip++)->u.number = i;
if (vtype == T_CLASS) {
f->lip->type = T_INT;
(f->lip++)->u.number = class;
}
}
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);
inherit = UCHAR(f->ctrl->imap[f->p_index + inherit]);
inherit = f->ctrl->inherits[inherit].varoffset;
if (f->lwobj == (array *) NULL) {
i_push_value(f, d_get_variable(f->data, inherit + index));
} else {
i_push_value(f, &f->lwobj->elts[2 + inherit + index]);
}
}
/*
* NAME: interpret->global_lvalue()
* DESCRIPTION: push a global lvalue on the stack
*/
void i_global_lvalue(f, inherit, index, vtype, class)
register frame *f;
register int inherit;
int index, vtype;
Uint class;
{
i_add_ticks(f, 4);
inherit = UCHAR(f->ctrl->imap[f->p_index + inherit]);
inherit = f->ctrl->inherits[inherit].varoffset;
if (f->lwobj == (array *) NULL) {
(--f->sp)->type = T_LVALUE;
f->sp->oindex = vtype;
f->sp->u.lval = d_get_variable(f->data, inherit + index);
} else {
(--f->sp)->type = T_ALVALUE;
f->sp->oindex = vtype;
arr_ref(f->sp->u.array = f->lwobj);
f->lip->type = T_INT;
(f->lip++)->u.number = 2 + inherit + index;
}
if (vtype == T_CLASS) {
f->lip->type = T_INT;
(f->lip++)->u.number = class;
}
}
/*
* NAME: interpret->index()
* DESCRIPTION: index a value, REPLACING it with 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);
PUT_INTVAL(aval, 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(f->data, 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 = &nil_value;
}
break;
case T_LWOBJECT:
ival = d_get_elts(val->u.array);
if (DESTRUCTED(ival)) {
val = &nil_value;
break;
}
/* fall through */
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, class)
register frame *f;
int vtype;
Uint class;
{
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);
lval->type = T_ALVALUE;
lval->oindex = vtype;
f->lip->type = T_INT;
(f->lip++)->u.number = i;
break;
case T_MAPPING:
lval->type = T_MLVALUE;
lval->oindex = vtype;
*f->lip++ = *ival;
break;
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(lval->u.lval->u.string, (long) ival->u.number);
lval->type = T_SLVALUE;
lval->oindex = vtype;
f->lip->type = T_STRING;
f->lip->oindex = i;
str_ref((f->lip++)->u.string = lval->u.lval->u.string);
break;
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);
lval->type = T_ALVALUE;
lval->oindex = vtype;
arr_ref(lval->u.array = lval->u.lval->u.array);
f->lip->type = T_INT;
(f->lip++)->u.number = i;
break;
case T_MAPPING:
lval->type = T_MLVALUE;
lval->oindex = vtype;
arr_ref(lval->u.array = lval->u.lval->u.array);
*f->lip++ = *ival;
break;
default:
i_del_value(ival);
error("Index on bad type");
}
break;
case T_ALVALUE:
val = &d_get_elts(lval->u.array)[f->lip[-1].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(val->u.string, (long) ival->u.number);
lval->type = T_SALVALUE;
lval->oindex = vtype;
f->lip->type = T_STRING;
f->lip->oindex = i;
str_ref((f->lip++)->u.string = val->u.string);
break;
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(lval->u.array); /* has to be second */
lval->oindex = vtype;
lval->u.array = val->u.array;
f->lip[-1].u.number = i;
break;
case T_MAPPING:
arr_ref(val->u.array); /* has to be first */
arr_del(lval->u.array); /* has to be second */
lval->type = T_MLVALUE;
lval->oindex = vtype;
lval->u.array = val->u.array;
f->lip[-1] = *ival;
break;
default:
i_del_value(ival);
error("Index on bad type");
}
break;
case T_MLVALUE:
val = map_index(f->data, lval->u.array, &f->lip[-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(val->u.string, (long) ival->u.number);
lval->type = T_SMLVALUE;
lval->oindex = vtype;
f->lip->type = T_STRING;
f->lip->oindex = i;
str_ref((f->lip++)->u.string = val->u.string);
break;
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(lval->u.array); /* has to be second */
lval->type = T_ALVALUE;
lval->oindex = vtype;
lval->u.array = val->u.array;
i_del_value(&f->lip[-1]);
f->lip[-1].type = T_INT;
f->lip[-1].u.number = i;
break;
case T_MAPPING:
arr_ref(val->u.array); /* has to be first */
arr_del(lval->u.array); /* has to be second */
lval->oindex = vtype;
lval->u.array = val->u.array;
i_del_value(&f->lip[-1]);
f->lip[-1] = *ival;
break;
default:
i_del_value(ival);
error("Index on bad type");
}
break;
}
if (vtype == T_CLASS) {
f->lip->type = T_INT;
(f->lip++)->u.number = class;
}
}
/*
* NAME: interpret->typename()
* DESCRIPTION: return the name of the argument type
*/
char *i_typename(buf, type)
register char *buf;
register unsigned int type;
{
static char *name[] = TYPENAMES;
if ((type & T_TYPE) == T_CLASS) {
type = (type & T_REF) | T_OBJECT;
}
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->instanceof()
* DESCRIPTION: is an object an instance of the named program?
*/
int i_instanceof(f, oindex, class)
register frame *f;
unsigned int oindex;
Uint class;
{
register inhash *h;
register char *prog;
register unsigned short i;
register dinherit *inh;
object *obj;
control *ctrl;
/* first try hash table */
obj = OBJR(oindex);
ctrl = o_control(obj);
prog = d_get_strconst(f->p_ctrl, class >> 16, class & 0xffff)->text;
h = &ihash[(obj->count ^ (oindex << 2) ^ (f->p_ctrl->oindex << 4) ^ class) %
INHASHSZ];
if (h->ocount == obj->count && h->coindex == f->p_ctrl->oindex &&
h->class == class && h->iindex < ctrl->ninherits) {
oindex = ctrl->inherits[h->iindex].oindex;
if (strcmp(OBJR(oindex)->chain.name, prog) == 0) {
return (ctrl->inherits[h->iindex].priv) ? -1 : 1; /* found it */
}
}
/* next, search for it the hard way */
for (i = ctrl->ninherits, inh = ctrl->inherits + i; i != 0; ) {
--i;
--inh;
if (strcmp(prog, OBJR(inh->oindex)->chain.name) == 0) {
/* found it; update hashtable */
h->ocount = obj->count;
h->coindex = f->p_ctrl->oindex;
h->class = class;
h->iindex = i;
return (ctrl->inherits[i].priv) ? -1 : 1;
}
}
return FALSE;
}
/*
* NAME: interpret->cast()
* DESCRIPTION: cast a value to a type
*/
void i_cast(f, val, type, class)
frame *f;
register value *val;
register unsigned int type;
Uint class;
{
char tnbuf[8];
if (type == T_CLASS) {
if (val->type == T_OBJECT || val->type == T_LWOBJECT) {
if (!i_instanceof(f,
(val->type == T_OBJECT) ?
val->oindex : d_get_elts(val->u.array)->oindex,
class)) {
error("Value is not of object type /%s",
d_get_strconst(f->p_ctrl, class >> 16,
class & 0xffff)->text);
}
return;
}
type = T_OBJECT;
}
if (val->type != type && (val->type != T_LWOBJECT || type != T_OBJECT) &&
(!VAL_NIL(val) || !T_POINTER(type))) {
i_typename(tnbuf, type);
if (strchr("aeiuoy", tnbuf[0]) != (char *) NULL) {
error("Value is not an %s", tnbuf);
} else {
error("Value is not a %s", tnbuf);
}
}
}
/*
* NAME: interpret->dup()
* DESCRIPTION: duplicate the value of an lvalue
*/
void i_dup(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->sp->u.array) + f->lip[-1].u.number);
break;
case T_MLVALUE:
i_push_value(f, map_index(f->data, f->sp->u.array, &f->lip[-1],
(value *) NULL));
break;
default:
/*
* Indexed string.
*/
PUSH_INTVAL(f, UCHAR(f->lip[-1].u.string->text[f->lip[-1].oindex]));
break;
}
}
/*
* NAME: istr()
* DESCRIPTION: create a copy of the argument string, with one char replaced
*/
static value *istr(val, str, i, v)
register value *val, *v;
register string *str;
ssizet i;
{
if (v->type != T_INT) {
error("Non-numeric value in indexed string assignment");
}
PUT_STRVAL_NOREF(val, (str->primary == (strref *) NULL && str->ref == 1) ?
str : str_new(str->text, (long) str->len));
val->u.string->text[i] = v->u.number;
return val;
}
/*
* NAME: interpret->store()
* DESCRIPTION: Perform an assignment. This invalidates the lvalue.
*/
void i_store(f)
register frame *f;
{
register value *lval, *val;
register array *a;
Uint class;
value ival;
lval = f->sp + 1;
val = f->sp;
if (lval->oindex != 0) {
if (lval->oindex == T_CLASS) {
--f->lip;
class = f->lip->u.number;
} else {
class = 0;
}
i_cast(f, val, lval->oindex, class);
}
i_add_ticks(f, 1);
switch (lval->type) {
case T_LVALUE:
d_assign_var(f->data, lval->u.lval, val);
break;
case T_SLVALUE:
d_assign_var(f->data, lval->u.lval,
istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex, val));
str_del((--f->lip)->u.string);
break;
case T_ALVALUE:
a = lval->u.array;
d_assign_elt(f->data, a, &d_get_elts(a)[(--f->lip)->u.number], val);
arr_del(a);
break;
case T_MLVALUE:
map_index(f->data, a = lval->u.array, &f->lip[-1], val);
i_del_value(--f->lip);
arr_del(a);
break;
case T_SALVALUE:
a = lval->u.array;
d_assign_elt(f->data, a, &a->elts[f->lip[-2].u.number],
istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex, val));
str_del((--f->lip)->u.string);
--f->lip;
arr_del(a);
break;
case T_SMLVALUE:
map_index(f->data, a = lval->u.array, &f->lip[-2],
istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex, val));
str_del((--f->lip)->u.string);
i_del_value(--f->lip);
arr_del(a);
break;
}
}
/*
* NAME: interpret->get_depth()
* DESCRIPTION: get the remaining stack depth (-1: infinite)
*/
Int i_get_depth(f)
frame *f;
{
register rlinfo *rlim;
rlim = f->rlim;
if (rlim->nodepth) {
return -1;
}
return rlim->maxdepth - f->depth;
}
/*
* NAME: interpret->get_ticks()
* DESCRIPTION: get the remaining ticks (-1: infinite)
*/
Int i_get_ticks(f)
frame *f;
{
register rlinfo *rlim;
rlim = f->rlim;
if (rlim->noticks) {
return -1;
} else {
return (rlim->ticks < 0) ? 0 : rlim->ticks << f->level;
}
}
/*
* NAME: interpret->check_rlimits()
* DESCRIPTION: check if this rlimits call is valid
*/
static void i_check_rlimits(f)
register frame *f;
{
object *obj;
obj = OBJR(f->oindex);
if (obj->count == 0) {
error("Illegal use of rlimits");
}
--f->sp;
f->sp[0] = f->sp[1];
f->sp[1] = f->sp[2];
if (f->lwobj == (array *) NULL) {
PUT_OBJVAL(&f->sp[2], obj);
} else {
PUT_LWOVAL(&f->sp[2], f->lwobj);
}
/* obj, stack, ticks */
call_driver_object(f, "runtime_rlimits", 3);
if (!VAL_TRUE(f->sp)) {
error("Illegal use of rlimits");
}
i_del_value(f->sp++);
}
/*
* NAME: interpret->new_rlimits()
* DESCRIPTION: create new rlimits scope
*/
void i_new_rlimits(f, depth, t)
register frame *f;
Int depth, t;
{
register rlinfo *rlim;
rlim = ALLOC(rlinfo, 1);
if (depth != 0) {
if (depth < 0) {
rlim->nodepth = TRUE;
} else {
rlim->maxdepth = f->depth + depth;
rlim->nodepth = FALSE;
}
} else {
rlim->maxdepth = f->rlim->maxdepth;
rlim->nodepth = f->rlim->nodepth;
}
if (t != 0) {
if (t < 0) {
rlim->noticks = TRUE;
} else {
t >>= f->level;
f->rlim->ticks -= t;
rlim->ticks = t;
rlim->noticks = FALSE;
}
} else {
f->rlim->ticks = 0;
rlim->ticks = f->rlim->ticks;
rlim->noticks = f->rlim->noticks;
}
rlim->next = f->rlim;
f->rlim = rlim;
}
/*
* NAME: interpret->set_rlimits()
* DESCRIPTION: restore rlimits to an earlier state
*/
void i_set_rlimits(f, rlim)
frame *f;
register rlinfo *rlim;
{
register rlinfo *r, *next;
r = f->rlim;
if (r->ticks < 0) {
r->ticks = 0;
}
while (r != rlim) {
next = r->next;
if (!r->noticks) {
next->ticks += r->ticks;
}
FREE(r);
r = next;
}
f->rlim = rlim;
}
/*
* 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;
for (f = ftop; ; f = f->prev) {
v = f->sp;
w = f->lip;
for (;;) {
if (v == sp) {
f->sp = v;
f->lip = w;
return f;
}
if (v == f->fp) {
break;
}
switch (v->type) {
case T_STRING:
str_del(v->u.string);
break;
case T_LVALUE:
if (v->oindex == T_CLASS) {
--w;
}
break;
case T_SLVALUE:
if (v->oindex == T_CLASS) {
--w;
}
str_del((--w)->u.string);
break;
case T_ALVALUE:
if (v->oindex == T_CLASS) {
--w;
}
--w;
case T_ARRAY:
case T_MAPPING:
case T_LWOBJECT:
arr_del(v->u.array);
break;
case T_MLVALUE:
if (v->oindex == T_CLASS) {
--w;
}
i_del_value(--w);
arr_del(v->u.array);
break;
case T_SALVALUE:
if (v->oindex == T_CLASS) {
--w;
}
str_del((--w)->u.string);
--w;
arr_del(v->u.array);
break;
case T_SMLVALUE:
if (v->oindex == T_CLASS) {
--w;
}
str_del((--w)->u.string);
i_del_value(--w);
arr_del(v->u.array);
break;
}
v++;
}
if (f->lwobj != (array *) NULL) {
arr_del(f->lwobj);
}
if (f->sos) {
/* stack on stack */
AFREE(f->stack);
} else if (f->oindex != OBJ_NONE) {
FREE(f->stack);
}
}
}
/*
* NAME: interpret->prev_object()
* DESCRIPTION: return the nth previous object in the call_other chain
*/
frame *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->oindex == OBJ_NONE) {
return (frame *) NULL;
}
--n;
}
return f;
}
/*
* 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->oindex == OBJ_NONE) {
return (char *) NULL;
}
--n;
}
return OBJR(f->p_ctrl->oindex)->chain.name;
}
/*
* NAME: interpret->typecheck()
* DESCRIPTION: check the argument types given to a function
*/
void i_typecheck(f, prog_f, name, ftype, proto, nargs, strict)
register frame *f;
frame *prog_f;
char *name, *ftype;
register char *proto;
int nargs;
int strict;
{
char tnbuf[8];
register int i, n, atype, ptype;
register char *args;
bool ellipsis;
Uint class;
i = nargs;
n = PROTO_NARGS(proto) + PROTO_VARGS(proto);
ellipsis = (PROTO_CLASS(proto) & C_ELLIPSIS);
args = PROTO_ARGS(proto);
while (n > 0 && i > 0) {
--i;
ptype = *args++;
if ((ptype & T_TYPE) == T_CLASS) {
FETCH3U(args, class);
}
if (n == 1 && ellipsis) {
if (ptype == T_MIXED || ptype == T_LVALUE) {
return;
}
if ((ptype & T_TYPE) == T_CLASS) {
args -= 4;
} else {
--args;
}
} else {
--n;
}
if (ptype != T_MIXED) {
atype = f->sp[i].type;
if (atype == T_LWOBJECT) {
atype = T_OBJECT;
}
if ((ptype & T_TYPE) == T_CLASS && ptype == T_CLASS &&
atype == T_OBJECT) {
if (!i_instanceof(prog_f,
(f->sp[i].type == T_OBJECT) ?
f->sp[i].oindex :
d_get_elts(f->sp[i].u.array)->oindex,
class)) {
error("Bad object argument %d for function %s",
nargs - i, name);
}
continue;
}
if (ptype != atype && (atype != T_ARRAY || !(ptype & T_REF))) {
if (!VAL_NIL(f->sp + i) || !T_POINTER(ptype)) {
/* wrong type */
error("Bad argument %d (%s) for %s %s", nargs - i,
i_typename(tnbuf, atype), ftype, name);
} else if (strict) {
/* nil 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 (VAL_NIL(f->sp)) {
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);
}
/*
* 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;
int size;
Int newdepth, newticks;
size = 0;
for (;;) {
# ifdef DEBUG
if (f->sp < f->lip + MIN_STACK) {
fatal("out of value stack");
}
# endif
if (--f->rlim->ticks <= 0) {
if (f->rlim->noticks) {
f->rlim->ticks = 0x7fffffff;
} else {
error("Out of ticks");
}
}
instr = FETCH1U(pc);
f->pc = pc;
switch (instr & I_INSTR_MASK) {
case I_PUSH_ZERO:
PUSH_INTVAL(f, 0);
break;
case I_PUSH_ONE:
PUSH_INTVAL(f, 1);
break;
case I_PUSH_INT1:
PUSH_INTVAL(f, FETCH1S(pc));
break;
case I_PUSH_INT4:
PUSH_INTVAL(f, FETCH4S(pc, l));
break;
case I_PUSH_FLOAT:
FETCH2U(pc, u);
PUSH_FLTCONST(f, u, FETCH4U(pc, l));
break;
case I_PUSH_STRING:
PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, f->p_ctrl->ninherits - 1,
FETCH1U(pc)));
break;
case I_PUSH_NEAR_STRING:
u = FETCH1U(pc);
PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH1U(pc)));
break;
case I_PUSH_FAR_STRING:
u = FETCH1U(pc);
PUSH_STRVAL(f, 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:
i_global(f, f->p_ctrl->progindex, FETCH1U(pc));
break;
case I_PUSH_FAR_GLOBAL:
u = FETCH1U(pc);
i_global(f, u, FETCH1U(pc));
break;
case I_PUSH_LOCAL_LVAL:
u = FETCH1S(pc);
if (instr & I_TYPE_BIT) {
instr = FETCH1U(pc);
if (instr == T_CLASS) {
FETCH3U(pc, l);
f->lip->type = T_INT;
(f->lip++)->u.number = l;
}
} else {
instr = 0;
}
(--f->sp)->type = T_LVALUE;
f->sp->oindex = instr;
f->sp->u.lval = ((short) u < 0) ? f->fp + (short) u : f->argp + u;
continue;
case I_PUSH_GLOBAL_LVAL:
u = FETCH1U(pc);
if (instr & I_TYPE_BIT) {
instr = FETCH1U(pc);
if (instr == T_CLASS) {
FETCH3U(pc, l);
}
} else {
instr = 0;
}
i_global_lvalue(f, f->p_ctrl->progindex, u, instr, l);
continue;
case I_PUSH_FAR_GLOBAL_LVAL:
u = FETCH1U(pc);
u2 = FETCH1U(pc);
if (instr & I_TYPE_BIT) {
instr = FETCH1U(pc);
if (instr == T_CLASS) {
FETCH3U(pc, l);
}
} else {
instr = 0;
}
i_global_lvalue(f, u, u2, instr, l);
continue;
case I_INDEX:
i_index(f);
break;
case I_INDEX_LVAL:
if (instr & I_TYPE_BIT) {
instr = FETCH1U(pc);
if (instr == T_CLASS) {
FETCH3U(pc, l);
}
} else {
instr = 0;
}
i_index_lvalue(f, instr, l);
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);
if (instr & I_TYPE_BIT) {
instr = FETCH1U(pc);
if (instr == T_CLASS) {
FETCH3U(pc, l);
}
} else {
instr = 0;
}
size = i_spread(f, (short) u, instr, l);
continue;
case I_CAST:
u = FETCH1U(pc);
if (u == T_CLASS) {
FETCH3U(pc, l);
}
i_cast(f, f->sp, u, l);
break;
case I_DUP:
i_dup(f);
break;
case I_STORE:
i_store(f);
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 (!VAL_TRUE(f->sp)) {
pc = p;
}
break;
case I_JUMP_NONZERO:
p = f->prog + FETCH2U(pc, u);
if (VAL_TRUE(f->sp)) {
pc = p;
}
break;
case I_SWITCH:
switch (FETCH1U(pc)) {
case SWITCH_INT:
pc = f->prog + i_switch_int(f, pc);
break;
case SWITCH_RANGE:
pc = f->prog + i_switch_range(f, pc);
break;
case SWITCH_STRING:
pc = f->prog + i_switch_str(f, pc);
break;
}
break;
case I_CALL_KFUNC:
kf = &KFUN(FETCH1U(pc));
if (PROTO_VARGS(kf->proto) != 0) {
/* 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, (frame *) NULL, kf->name, "kfun", kf->proto, u,
TRUE);
}
u = (*kf->func)(f, u, kf);
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, (array *) NULL, 0, u,
FETCH1U(pc) + size);
size = 0;
break;
case I_CALL_DFUNC:
u = UCHAR(f->ctrl->imap[f->p_index + FETCH1U(pc)]);
u2 = FETCH1U(pc);
i_funcall(f, (object *) NULL, (array *) 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, (array *) NULL, UCHAR(p[0]),
UCHAR(p[1]), FETCH1U(pc) + size);
size = 0;
break;
case I_CATCH:
p = f->prog + FETCH2U(pc, u);
if (!ec_push((ec_ftn) i_catcherr)) {
f->atomic = FALSE;
i_interpret(f, pc);
ec_pop();
pc = f->pc;
*--f->sp = nil_value;
} else {
/* error */
f->pc = pc = p;
PUSH_STRVAL(f, errorstr());
}
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_new_rlimits(f, newdepth, newticks);
i_interpret(f, pc);
pc = f->pc;
i_set_rlimits(f, f->rlim->next);
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, lwobj, p_ctrli, funci, nargs)
register frame *prev_f;
register object *obj;
array *lwobj;
register int p_ctrli, nargs;
int funci;
{
register char *pc;
register unsigned short n;
frame f;
bool ellipsis;
value val;
f.prev = prev_f;
if (prev_f->oindex == OBJ_NONE) {
/*
* top level call
*/
f.oindex = obj->index;
f.lwobj = (array *) NULL;
f.ctrl = obj->ctrl;
f.data = o_dataspace(obj);
f.external = TRUE;
} else if (lwobj != (array *) NULL) {
/*
* call_other to lightweight object
*/
f.oindex = obj->index;
f.lwobj = lwobj;
f.ctrl = obj->ctrl;
f.data = lwobj->primary->data;
f.external = TRUE;
} else if (obj != (object *) NULL) {
/*
* call_other to persistent object
*/
f.oindex = obj->index;
f.lwobj = (array *) NULL;
f.ctrl = obj->ctrl;
f.data = o_dataspace(obj);
f.external = TRUE;
} else {
/*
* local function call
*/
f.oindex = prev_f->oindex;
f.lwobj = prev_f->lwobj;
f.ctrl = prev_f->ctrl;
f.data = prev_f->data;
f.external = FALSE;
}
f.depth = prev_f->depth + 1;
f.rlim = prev_f->rlim;
if (f.depth >= f.rlim->maxdepth && !f.rlim->nodepth) {
error("Stack overflow");
}
if (f.rlim->ticks < 100) {
if (f.rlim->noticks) {
f.rlim->ticks = 0x7fffffff;
} else {
error("Out of ticks");
}
}
/* set the program control block */
obj = OBJR(f.ctrl->inherits[p_ctrli].oindex);
f.foffset = f.ctrl->inherits[p_ctrli].funcoffset;
f.p_ctrl = o_control(obj);
f.p_index = f.ctrl->inherits[p_ctrli].progoffset;
/* 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 (f.func->class & C_TYPECHECKED) {
/* typecheck arguments */
i_typecheck(prev_f, &f,
d_get_strconst(f.p_ctrl, f.func->inherit,
f.func->index)->text,
"function", pc, nargs, FALSE);
}
/* handle arguments */
ellipsis = (PROTO_CLASS(pc) & C_ELLIPSIS);
n = PROTO_NARGS(pc) + PROTO_VARGS(pc);
if (nargs < n) {
register int i;
/* if fewer actual than formal parameters, check for varargs */
if (nargs < PROTO_NARGS(pc) && stricttc) {
error("Insufficient arguments for function %s",
d_get_strconst(f.p_ctrl, f.func->inherit,
f.func->index)->text);
}
/* add missing arguments */
i_grow_stack(prev_f, n - nargs);
if (ellipsis) {
--n;
}
pc = &PROTO_FTYPE(pc);
i = nargs;
do {
if ((FETCH1U(pc) & T_TYPE) == T_CLASS) {
pc += 3;
}
} while (--i >= 0);
while (nargs < n) {
switch (i=FETCH1U(pc)) {
case T_INT:
*--prev_f->sp = zero_int;
break;
case T_FLOAT:
*--prev_f->sp = zero_float;
break;
default:
if ((i & T_TYPE) == T_CLASS) {
pc += 3;
}
*--prev_f->sp = nil_value;
break;
}
nargs++;
}
if (ellipsis) {
PUSH_ARRVAL(prev_f, arr_new(f.data, 0));
nargs++;
if ((FETCH1U(pc) & T_TYPE) == T_CLASS) {
pc += 3;
}
}
} else if (ellipsis) {
register value *v;
array *a;
/* put additional arguments in array */
nargs -= n - 1;
a = arr_new(f.data, nargs);
v = a->elts + nargs;
do {
*--v = *prev_f->sp++;
} while (--nargs > 0);
d_ref_imports(a);
PUSH_ARRVAL(prev_f, a);
nargs = n;
pc += PROTO_SIZE(pc);
} else if (nargs > n) {
if (stricttc) {
error("Too many arguments for function %s",
d_get_strconst(f.p_ctrl, f.func->inherit,
f.func->index)->text);
}
/* pop superfluous arguments */
i_pop(prev_f, nargs - n);
nargs = n;
pc += PROTO_SIZE(pc);
} else {
pc += PROTO_SIZE(pc);
}
f.sp = prev_f->sp;
f.nargs = nargs;
cframe = &f;
if (f.lwobj != (array *) NULL) {
arr_ref(f.lwobj);
}
/* deal with atomic functions */
f.level = prev_f->level;
if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
o_new_plane();
d_new_plane(f.data, ++f.level);
f.atomic = TRUE;
if (!f.rlim->noticks) {
f.rlim->ticks >>= 1;
}
} else {
if (f.level != f.data->plane->level) {
d_new_plane(f.data, f.level);
}
f.atomic = prev_f->atomic;
}
i_add_ticks(&f, 10);
/* create new local stack */
f.argp = f.sp;
FETCH2U(pc, n);
f.stack = f.lip = 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 = nil_value;
} while (--n > 0);
}
/* execute code */
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 || f.lip != f.stack) {
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);
}
if (f.lwobj != (array *) NULL) {
arr_del(f.lwobj);
}
cframe = prev_f;
i_pop(prev_f, f.nargs);
*--prev_f->sp = val;
if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
d_commit_plane(f.level, &val);
o_commit_plane();
if (!f.rlim->noticks) {
f.rlim->ticks *= 2;
}
}
}
/*
* NAME: interpret->call()
* DESCRIPTION: Attempt to call a function in an object. Return TRUE if
* the call succeeded.
*/
bool i_call(f, obj, lwobj, func, len, call_static, nargs)
frame *f;
object *obj;
array *lwobj;
char *func;
unsigned int len;
int call_static;
int nargs;
{
register dsymbol *symb;
register dfuncdef *fdef;
register control *ctrl;
if (lwobj != (array *) NULL) {
uindex oindex;
xfloat flt;
value val;
oindex = lwobj->elts[0].oindex;
obj = OBJR(oindex);
GET_FLT(&lwobj->elts[1], flt);
if (obj->update != flt.low) {
d_upgrade_lwobj(lwobj, obj);
}
if (flt.high != FALSE) {
/*
* touch the light-weight object
*/
flt.high = FALSE;
PUT_FLTVAL(&val, flt);
d_assign_elt(f->data, lwobj, &lwobj->elts[1], &val);
PUSH_LWOVAL(f, lwobj);
PUSH_STRVAL(f, str_new(func, len));
call_driver_object(f, "touch", 2);
if (VAL_TRUE(f->sp)) {
/* preserve through call */
flt.high = TRUE;
PUT_FLT(&lwobj->elts[1], flt);
}
i_del_value(f->sp++);
}
} else if (!(obj->flags & O_TOUCHED)) {
/*
* initialize/touch the object
*/
obj = OBJW(obj->index);
obj->flags |= O_TOUCHED;
if (O_HASDATA(obj)) {
PUSH_OBJVAL(f, obj);
PUSH_STRVAL(f, str_new(func, len));
call_driver_object(f, "touch", 2);
if (VAL_TRUE(f->sp)) {
obj->flags &= ~O_TOUCHED; /* preserve though call */
}
i_del_value(f->sp++);
} else {
obj->data = d_new_dataspace(obj);
if (func != (char *) NULL &&
i_call(f, obj, (array *) NULL, creator, clen, TRUE, 0)) {
i_del_value(f->sp++);
}
}
}
if (func == (char *) NULL) {
func = creator;
len = clen;
}
/* find the function in the symbol table */
ctrl = o_control(obj);
symb = ctrl_symb(ctrl, func, len);
if (symb == (dsymbol *) NULL) {
/* function doesn't exist in symbol table */
i_pop(f, nargs);
return FALSE;
}
ctrl = OBJR(ctrl->inherits[UCHAR(symb->inherit)].oindex)->ctrl;
fdef = &d_get_funcdefs(ctrl)[UCHAR(symb->index)];
/* check if the function can be called */
if (!call_static && (fdef->class & C_STATIC) &&
((lwobj != (array *) NULL) ?
lwobj != f->lwobj : f->oindex != obj->index)) {
i_pop(f, nargs);
return FALSE;
}
/* call the function */
i_funcall(f, obj, lwobj, 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) && FETCH1U(pc) == T_CLASS) {
pc += 3;
}
/* fall through */
case I_PUSH_ZERO:
case I_PUSH_ONE:
case I_INDEX:
case I_DUP:
case I_STORE:
case I_RETURN:
break;
case I_PUSH_INT1:
case I_PUSH_STRING:
case I_PUSH_LOCAL:
case I_PUSH_GLOBAL:
case I_RLIMITS:
pc++;
break;
case I_CAST:
if (FETCH1U(pc) == T_CLASS) {
pc += 3;
}
break;
case I_PUSH_LOCAL_LVAL:
case I_PUSH_GLOBAL_LVAL:
case I_SPREAD:
pc++;
if ((instr & I_TYPE_BIT) && FETCH1U(pc) == T_CLASS) {
pc += 3;
}
break;
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_GLOBAL_LVAL:
pc += 2;
if ((instr & I_TYPE_BIT) && FETCH1U(pc) == T_CLASS) {
pc += 3;
}
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_VARGS(KFUN(FETCH1U(pc)).proto) != 0) {
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;
{
char buffer[STRINGSZ + 12];
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(buffer, OBJR(f->oindex));
if (f->lwobj == (array *) NULL) {
PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
v++;
str->text[0] = '/';
strcpy(str->text + 1, name);
} else {
PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 4L));
v++;
str->text[0] = '/';
strcpy(str->text + 1, name);
strcpy(str->text + str->len - 3, "#-1");
}
/* program name */
name = OBJR(f->p_ctrl->oindex)->chain.name;
PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
v++;
str->text[0] = '/';
strcpy(str->text + 1, name);
/* function name */
PUT_STRVAL(v, d_get_strconst(f->p_ctrl, f->func->inherit, f->func->index));
v++;
/* line number */
PUT_INTVAL(v, (f->func->class & C_COMPILED) ? 0 : i_line(f));
v++;
/* external flag */
PUT_INTVAL(v, f->external);
v++;
/* arguments */
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->oindex != OBJ_NONE; f = f->prev, n++) ;
if (idx < 0 || idx >= n) {
return FALSE;
}
for (f = ftop, n -= idx + 1; n != 0; f = f->prev, --n) ;
PUT_ARRVAL(v, 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->oindex != OBJ_NONE; 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->oindex != OBJ_NONE; f = f->prev) {
--v;
PUT_ARRVAL(v, i_func_trace(f, ftop->data));
}
return a;
}
/*
* NAME: emptyhandler()
* DESCRIPTION: fake error handler
*/
static void emptyhandler(f, depth)
frame *f;
Int depth;
{
}
/*
* 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 ok;
i_new_rlimits(f, -1, -1);
f->sp += narg; /* so the error context knows what to pop */
if (ec_push((flag) ? (ec_ftn) NULL : (ec_ftn) emptyhandler)) {
ok = FALSE;
} else {
f->sp -= narg; /* recover arguments */
call_driver_object(f, func, narg);
ec_pop();
ok = TRUE;
}
i_set_rlimits(f, f->rlim->next);
return ok;
}
/*
* NAME: interpret->runtime_error()
* DESCRIPTION: handle a runtime error
*/
void i_runtime_error(f, depth)
register frame *f;
Int depth;
{
PUSH_STRVAL(f, errorstr());
PUSH_INTVAL(f, depth);
PUSH_INTVAL(f, 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->atomic_error()
* DESCRIPTION: handle error in atomic code
*/
void i_atomic_error(ftop, level)
register frame *ftop;
Int level;
{
register frame *f;
for (f = ftop; f->level != level; f = f->prev) ;
PUSH_STRVAL(ftop, errorstr());
PUSH_INTVAL(ftop, f->depth);
PUSH_INTVAL(ftop, i_get_ticks(ftop));
if (!i_call_critical(ftop, "atomic_error", 3, FALSE)) {
message("Error within atomic_error:\012"); /* LF */
message((char *) NULL);
} else {
i_del_value(ftop->sp++);
}
}
/*
* NAME: interpret->restore()
* DESCRIPTION: restore state to given level
*/
frame *i_restore(ftop, level)
register frame *ftop;
Int level;
{
register frame *f;
for (f = ftop; f->level != level; f = f->prev) ;
if (f->rlim != ftop->rlim) {
i_set_rlimits(ftop, f->rlim);
}
if (!f->rlim->noticks) {
f->rlim->ticks *= 2;
}
i_set_sp(ftop, f->sp);
d_discard_plane(ftop->level);
o_discard_plane();
return f;
}
/*
* 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->lip = stack;
}
f->rlim = &rlim;
}