/* load executable name */
static
int evalload(Xpost_Context *ctx)
{
int ret;
if (_xpost_interpreter_is_tracing)
{
Xpost_Object s = xpost_name_get_string(ctx, xpost_stack_topdown_fetch(ctx->lo, ctx->es, 0));
XPOST_LOG_DUMP("evalload <name \"%*s\">", s.comp_.sz, xpost_string_get_pointer(ctx, s));
}
if (!xpost_stack_push(ctx->lo, ctx->os,
xpost_stack_pop(ctx->lo, ctx->es)))
return stackoverflow;
assert(ctx->gl->base);
/*xpost_operator_exec(ctx, xpost_operator_cons(ctx, "load", NULL,0,0).mark_.padw); */
ret = xpost_operator_exec(ctx, ctx->opcode_shortcuts.load);
if (ret)
return ret;
if (xpost_object_is_exe(xpost_stack_topdown_fetch(ctx->lo, ctx->os, 0)))
{
Xpost_Object q;
q = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(q) == invalidtype)
return undefined;
if (!xpost_stack_push(ctx->lo, ctx->es, q))
return ret;
}
return 0;
}
/* a(n-1)..a(0) n j roll a((j-1)mod n)..a(0) a(n-1)..a(j mod n)
roll n elements j times */
static
int IIroll (Xpost_Context *ctx,
Xpost_Object N,
Xpost_Object J)
{
Xpost_Object *t;
Xpost_Object r;
int i;
int n = N.int_.val;
int j = J.int_.val;
if (n < 0)
return rangecheck;
if (n == 0) return 0;
if (j < 0) j = n - ( (- j) % n);
j %= n;
if (j == 0) return 0;
t = alloca((n-j) * sizeof(Xpost_Object));
for (i = 0; i < n-j; i++)
{
r = xpost_stack_topdown_fetch(ctx->lo, ctx->os, n - 1 - i);
if (xpost_object_get_type(r) == invalidtype)
return stackunderflow;
t[i] = r;
}
for (i = 0; i < j; i++)
{
r = xpost_stack_topdown_fetch(ctx->lo, ctx->os, j - 1 - i);
if (xpost_object_get_type(r) == invalidtype)
return stackunderflow;
if (!xpost_stack_topdown_replace(ctx->lo, ctx->os, n - 1 - i, r))
return stackunderflow;
}
for (i = 0; i < n-j; i++)
{
if (!xpost_stack_topdown_replace(ctx->lo, ctx->os, n - j - 1 - i, t[i]))
return stackunderflow;
}
return 0;
}
/* mark obj1..objN counttomark N
count elements down to mark */
int xpost_op_counttomark (Xpost_Context *ctx)
{
unsigned i;
unsigned z;
z = xpost_stack_count(ctx->lo, ctx->os);
for (i = 0; i < z; i++) {
if (xpost_stack_topdown_fetch(ctx->lo, ctx->os, i).tag == marktype) {
xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(i));
return 0;
}
}
return unmatchedmark;
}
/* anyN..any0 N index anyN..any0 anyN
duplicate arbitrary element */
static
int Iindex (Xpost_Context *ctx,
Xpost_Object n)
{
if (n.int_.val < 0)
return rangecheck;
if (n.int_.val >= xpost_stack_count(ctx->lo, ctx->os))
return stackunderflow;
//printf("index %d\n", n.int_.val);
if (!xpost_stack_push(ctx->lo, ctx->os,
xpost_stack_topdown_fetch(ctx->lo, ctx->os, n.int_.val)))
return stackoverflow;
return 0;
}
/* any1..anyN N copy any1..anyN any1..anyN
duplicate top n elements */
static
int Icopy (Xpost_Context *ctx,
Xpost_Object n)
{
int i;
if (n.int_.val < 0)
return rangecheck;
if (n.int_.val > xpost_stack_count(ctx->lo, ctx->os))
return stackunderflow;
for (i=0; i < n.int_.val; i++)
if (!xpost_stack_push(ctx->lo, ctx->os,
xpost_stack_topdown_fetch(ctx->lo, ctx->os, n.int_.val - 1)))
return stackoverflow;
return 0;
}
/*
one iteration of the central loop
called repeatedly by mainloop()
*/
int eval(Xpost_Context *ctx)
{
int ret;
Xpost_Object t = xpost_stack_topdown_fetch(ctx->lo, ctx->es, 0);
ctx->currentobject = t; /* for _onerror to determine if hold stack contents are restoreable.
if opexec(opcode) discovers opcode != ctx->currentobject.mark_.padw
it sets a flag indicating the hold stack does not contain
ctx->currentobject's arguments.
if an error is encountered, currentobject is reported as the
errant object since it is the "entry point" to the interpreter.
*/
if (!validate_context(ctx))
return unregistered;
if (_xpost_interpreter_is_tracing)
{
XPOST_LOG_DUMP("eval(): Executing: ");
xpost_object_dump(t);
XPOST_LOG_DUMP("Stack: ");
xpost_stack_dump(ctx->lo, ctx->os);
XPOST_LOG_DUMP("Dict Stack: ");
xpost_stack_dump(ctx->lo, ctx->ds);
XPOST_LOG_DUMP("Exec Stack: ");
xpost_stack_dump(ctx->lo, ctx->es);
}
ret = idleproc(ctx); /* periodically process asynchronous events */
if (ret)
return ret;
{ /* check object for sanity before using jump table */
Xpost_Object_Type type = xpost_object_get_type(t);
if (type == invalidtype || type >= XPOST_OBJECT_NTYPES)
return unregistered;
}
if ( xpost_object_is_exe(t) ) /* if executable */
ret = evaltype[xpost_object_get_type(t)](ctx);
else
ret = evalpush(ctx);
return ret;
}
/* - currentfile file
return topmost file from the exec stack */
static
int xpost_op_currentfile (Xpost_Context *ctx)
{
int z = xpost_stack_count(ctx->lo, ctx->es);
int i;
Xpost_Object o;
for (i = 0; i<z; i++)
{
o = xpost_stack_topdown_fetch(ctx->lo, ctx->es, i);
if (xpost_object_get_type(o) == filetype)
{
xpost_stack_push(ctx->lo, ctx->os, o);
return 0;
}
}
o = xpost_file_cons(ctx->lo, NULL);
if (xpost_object_get_type(o) == invalidtype)
return VMerror;
xpost_stack_push(ctx->lo, ctx->os, o);
return 0;
}
/* initialize the name special entities XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, NAME_TREE */
int xpost_name_init(Xpost_Context *ctx)
{
Xpost_Memory_Table *tab;
unsigned int ent;
unsigned int t;
unsigned int mode;
unsigned int nstk;
int ret;
mode = ctx->vmmode;
ctx->vmmode = GLOBAL;
ret = xpost_memory_table_alloc(ctx->gl, 0, 0, &ent); //gl:NAMES
if (!ret)
{
return 0;
}
//assert(ent == XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK);
if (ent != XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)
XPOST_LOG_ERR("Warning: name stack is not in special position");
ret = xpost_memory_table_alloc(ctx->gl, 0, 0, &ent); //gl:NAMET
if (!ret)
{
return 0;
}
//assert(ent == XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE);
if (ent != XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE)
XPOST_LOG_ERR("Warning: name tree is not in special position");
xpost_stack_init(ctx->gl, &t);
tab = &ctx->gl->table; //recalc pointer
tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK].adr = t;
tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE].adr = 0;
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &nstk);
xpost_stack_push(ctx->gl, nstk, xpost_string_cons(ctx, CNT_STR("_not_a_name_")));
assert (xpost_object_get_ent(xpost_stack_topdown_fetch(ctx->gl, nstk, 0)) == XPOST_MEMORY_TABLE_SPECIAL_BOGUS_NAME);
ctx->vmmode = LOCAL;
ret = xpost_memory_table_alloc(ctx->lo, 0, 0, &ent); //lo:NAMES
if (!ret)
{
return 0;
}
//assert(ent == XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK);
if (ent != XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)
XPOST_LOG_ERR("Warning: name stack is not in special position");
ret = xpost_memory_table_alloc(ctx->lo, 0, 0, &ent); //lo:NAMET
if (!ret)
{
return 0;
}
//assert(ent == XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE);
if (ent != XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE)
XPOST_LOG_ERR("Warning: name tree is not in special position");
xpost_stack_init(ctx->lo, &t);
tab = &ctx->lo->table; //recalc pointer
tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK].adr = t;
tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE].adr = 0;
xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &nstk);
xpost_stack_push(ctx->lo, nstk, xpost_string_cons(ctx, CNT_STR("_not_a_name_")));
//assert (xpost_object_get_ent(xpost_stack_topdown_fetch(ctx->lo, nstk, 0)) == XPOST_MEMORY_TABLE_SPECIAL_BOGUS_NAME);
if (xpost_object_get_ent(xpost_stack_topdown_fetch(ctx->lo, nstk, 0)) != XPOST_MEMORY_TABLE_SPECIAL_BOGUS_NAME)
XPOST_LOG_ERR("Warning: bogus name not in special position");
ctx->vmmode = mode;
return 1;
}
