/* print a dump of the name string stacks, global and local */
void xpost_name_dump_names(Xpost_Context *ctx)
{
unsigned int stk;
unsigned int cnt, i;
Xpost_Object str;
char *s;
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &stk);
cnt = xpost_stack_count(ctx->gl, stk);
printf("global names:\n");
for (i=0; i < cnt; i++){
str = xpost_stack_bottomup_fetch(ctx->gl, stk, i);
s = xpost_string_get_pointer(ctx, str);
printf("%u: %*s\n", i, str.comp_.sz, s);
}
xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &stk);
cnt = xpost_stack_count(ctx->lo, stk);
printf("local names:\n");
for (i=0; i < cnt; i++) {
str = xpost_stack_bottomup_fetch(ctx->lo, stk, i);
s = xpost_string_get_pointer(ctx, str);
printf("%u: %*s\n", i, str.comp_.sz, s);
}
}
int xpost_oper_init_stack_ops (Xpost_Context *ctx,
Xpost_Object sd)
{
Xpost_Operator *optab;
Xpost_Object n,op;
unsigned int optadr;
assert(ctx->gl->base);
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_OPERATOR_TABLE, &optadr);
optab = (void *)(ctx->gl->base + optadr);
op = xpost_operator_cons(ctx, "pop", (Xpost_Op_Func)Apop, 0, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "exch", (Xpost_Op_Func)AAexch, 2, 2, anytype, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "dup", (Xpost_Op_Func)Adup, 2, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "copy", (Xpost_Op_Func)Icopy, 0, 1, integertype);
INSTALL;
op = xpost_operator_cons(ctx, "index", (Xpost_Op_Func)Iindex, 1, 1, integertype);
INSTALL;
//xpost_dict_dump_memory (ctx->gl, sd); fflush(NULL);
op = xpost_operator_cons(ctx, "roll", (Xpost_Op_Func)IIroll, 0, 2, integertype, integertype);
INSTALL;
op = xpost_operator_cons(ctx, "clear", (Xpost_Op_Func)Zclear, 0, 0);
INSTALL;
op = xpost_operator_cons(ctx, "count", (Xpost_Op_Func)Zcount, 1, 0);
INSTALL;
xpost_dict_put(ctx, sd, xpost_name_cons(ctx, "mark"), mark);
op = xpost_operator_cons(ctx, "cleartomark", (Xpost_Op_Func)xpost_op_cleartomark, 0, 0);
INSTALL;
op = xpost_operator_cons(ctx, "counttomark", (Xpost_Op_Func)xpost_op_counttomark, 1, 0);
INSTALL;
return 0;
}
/* discard the free list.
iterate through tables,
if element is unmarked and not zero-sized,
free it.
return reclaimed size
*/
static
unsigned int _xpost_garbage_sweep(Xpost_Memory_File *mem)
{
Xpost_Memory_Table *tab;
int ntab;
unsigned int zero = 0;
unsigned int z;
unsigned int i;
unsigned int sz = 0;
int ret;
ret = xpost_memory_table_get_addr(mem, XPOST_MEMORY_TABLE_SPECIAL_FREE, &z); /* address of the free list head */
if (!ret)
{
XPOST_LOG_ERR("cannot load free list head");
return 0;
}
memcpy(mem->base+z, &zero, sizeof(unsigned int)); /* discard list */
/* *(unsigned int *)(mem->base+z) = 0; */
/* scan first table */
tab = (void *)(mem->base);
ntab = 0;
for (i = mem->start; i < tab->nextent; i++) {
if ( (tab->tab[i].mark & XPOST_MEMORY_TABLE_MARK_DATA_MARK_MASK) == 0
&& tab->tab[i].sz != 0)
{
ret = xpost_free_memory_ent(mem, i);
if (ret < 0)
{
XPOST_LOG_ERR("cannot free ent");
return sz;
}
sz += (unsigned int)ret;
}
}
/* scan linked tables */
while (i < XPOST_MEMORY_TABLE_SIZE && tab->nexttab != 0) {
tab = (void *)(mem->base + tab->nexttab);
++ntab;
for (i = mem->start; i < tab->nextent; i++) {
if ( (tab->tab[i].mark & XPOST_MEMORY_TABLE_MARK_DATA_MARK_MASK) == 0
&& tab->tab[i].sz != 0)
{
ret = xpost_free_memory_ent(mem, i + ntab*XPOST_MEMORY_TABLE_SIZE);
if (ret < 0)
{
XPOST_LOG_ERR("cannot free ent");
return sz;
}
sz += (unsigned int)ret;
}
}
}
return sz;
}
int xpost_oper_init_save_ops (Xpost_Context *ctx,
Xpost_Object sd)
{
Xpost_Operator *optab;
Xpost_Object n,op;
unsigned int optadr;
assert(ctx->gl->base);
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_OPERATOR_TABLE, &optadr);
optab = (void *)(ctx->gl->base + optadr);
op = xpost_operator_cons(ctx, "save", (Xpost_Op_Func)Zsave, 1, 0);
INSTALL;
op = xpost_operator_cons(ctx, "restore", (Xpost_Op_Func)Vrestore, 0, 1, savetype);
INSTALL;
op = xpost_operator_cons(ctx, "setglobal", (Xpost_Op_Func)Bsetglobal, 0, 1, booleantype);
INSTALL;
op = xpost_operator_cons(ctx, "currentglobal", (Xpost_Op_Func)Zcurrentglobal, 1, 0);
INSTALL;
op = xpost_operator_cons(ctx, "gcheck", (Xpost_Op_Func)Agcheck, 1, 1, anytype);
INSTALL;
#if 0
op = xpost_operator_cons(ctx, "vmstatus", (Xpost_Op_Func)Zvmstatus, 3, 0);
INSTALL;
#endif
/* xpost_dict_dump_memory (ctx->gl, sd); fflush(NULL);
xpost_dict_put(ctx, sd, xpost_name_cons(ctx, "mark"), mark); */
return 0;
}
/* add the name to the name stack, return index */
static
unsigned int addname(Xpost_Context *ctx,
const char *s)
{
Xpost_Memory_File *mem = ctx->vmmode==GLOBAL?ctx->gl:ctx->lo;
unsigned int names;
unsigned int u;
Xpost_Object str;
xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &names);
u = xpost_stack_count(mem, names);
//xpost_memory_file_dump(ctx->gl);
//dumpmtab(ctx->gl, 0);
//unsigned int vmmode = ctx->vmmode;
//ctx->vmmode = GLOBAL;
str = xpost_string_cons(ctx, strlen(s), s);
if (xpost_object_get_type(str) == nulltype)
{
XPOST_LOG_ERR("cannot allocate name string");
return 0;
}
xpost_stack_push(mem, names, str);
//ctx->vmmode = vmmode;
return u;
}
/* construct a name object from a string
searches and if necessary installs string
in ternary search tree,
adding string to stack if so.
returns a generic object with
nametype tag with FBANK flag,
mark_.pad0 set to zero
mark_.padw contains XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK stack index
*/
Xpost_Object xpost_name_cons(Xpost_Context *ctx,
const char *s)
{
unsigned int u;
unsigned int t;
Xpost_Object o;
unsigned int tstk;
int ret;
xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE, &tstk);
u = tstsearch(ctx->lo, tstk, s);
if (!u) {
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE, &tstk);
u = tstsearch(ctx->gl, tstk, s);
if (!u) {
Xpost_Memory_File *mem = ctx->vmmode==GLOBAL?ctx->gl:ctx->lo;
Xpost_Memory_Table *tab = &mem->table;
ret = tstinsert(mem, tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE].adr, s, &t);
if (ret)
{
//this can only be a VMerror
return invalid;
}
tab = &mem->table; //recalc pointer
tab->tab[XPOST_MEMORY_TABLE_SPECIAL_NAME_TREE].adr = t;
u = addname(ctx, s); // obeys vmmode
o.mark_.tag = nametype | (ctx->vmmode==GLOBAL?XPOST_OBJECT_TAG_DATA_FLAG_BANK:0);
o.mark_.pad0 = 0;
o.mark_.padw = u;
} else {
o.mark_.tag = nametype | XPOST_OBJECT_TAG_DATA_FLAG_BANK; // global
o.mark_.pad0 = 0;
o.mark_.padw = u;
}
} else {
o.mark_.tag = nametype; // local
o.mark_.pad0 = 0;
o.mark_.padw = u;
}
return o;
}
/* - vmstatus level used max
return size information for (local) vm */
static
int Zvmstatus (Xpost_Context *ctx)
{
unsigned int vs;
xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_SAVE_STACK, &vs);
xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(xpost_stack_count(ctx->lo, vs)));
xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(ctx->lo->used));
xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(ctx->lo->max));
return 0;
}
/* yield the string object from the name string stack
*/
Xpost_Object xpost_name_get_string(Xpost_Context *ctx,
Xpost_Object n)
{
Xpost_Memory_File *mem = xpost_context_select_memory(ctx, n);
unsigned int names;
Xpost_Object str;
xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &names);
str = xpost_stack_bottomup_fetch(mem, names, n.mark_.padw);
//str.tag |= XPOST_OBJECT_TAG_DATA_FLAG_BANK;
return str;
}
int xpost_oper_init_type_ops (Xpost_Context *ctx,
Xpost_Object sd)
{
Xpost_Operator *optab;
Xpost_Object n,op;
unsigned int optadr;
assert(ctx->gl->base);
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_OPERATOR_TABLE, &optadr);
optab = (void *)(ctx->gl->base + optadr);
op = xpost_operator_cons(ctx, "type", (Xpost_Op_Func)Atype, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "cvlit", (Xpost_Op_Func)Acvlit, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "cvx", (Xpost_Op_Func)Acvx, 1, 1, anytype);
INSTALL;
ctx->opcode_shortcuts.cvx = op.mark_.padw;
op = xpost_operator_cons(ctx, "xcheck", (Xpost_Op_Func)Axcheck, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "executeonly", (Xpost_Op_Func)Aexecuteonly, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "noaccess", (Xpost_Op_Func)Anoaccess, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "readonly", (Xpost_Op_Func)Areadonly, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "rcheck", (Xpost_Op_Func)Archeck, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "wcheck", (Xpost_Op_Func)Awcheck, 1, 1, anytype);
INSTALL;
op = xpost_operator_cons(ctx, "cvi", (Xpost_Op_Func)Ncvi, 1, 1, numbertype);
INSTALL;
op = xpost_operator_cons(ctx, "cvi", (Xpost_Op_Func)Scvi, 1, 1, stringtype);
INSTALL;
op = xpost_operator_cons(ctx, "cvn", (Xpost_Op_Func)Scvn, 1, 1, stringtype);
INSTALL;
op = xpost_operator_cons(ctx, "cvn", (Xpost_Op_Func)Ncvn, 1, 1, nametype);
INSTALL;
op = xpost_operator_cons(ctx, "cvr", (Xpost_Op_Func)Ncvr, 1, 1, numbertype);
INSTALL;
op = xpost_operator_cons(ctx, "cvr", (Xpost_Op_Func)Scvr, 1, 1, stringtype);
INSTALL;
op = xpost_operator_cons(ctx, "cvrs", (Xpost_Op_Func)NRScvrs, 1, 3, numbertype, integertype, stringtype);
INSTALL;
op = xpost_operator_cons(ctx, "cvs", (Xpost_Op_Func)AScvs, 1, 2, anytype, stringtype);
INSTALL;
/* xpost_dict_dump_memory (ctx->gl, sd); fflush(NULL);
*/
return 0;
}
/* add a string to the ternary search tree */
static
int tstinsert(Xpost_Memory_File *mem,
unsigned int tadr,
const char *s,
unsigned int *retval)
{
tst *p;
unsigned int t; //temporary
unsigned int nstk;
int ret;
if (!tadr) {
if (!xpost_memory_file_alloc(mem, sizeof(tst), &tadr))
{
XPOST_LOG_ERR("cannot allocate tree node");
return VMerror;
}
p = (void *)(mem->base + tadr);
p->val = *s;
p->lo = p->eq = p->hi = 0;
}
p = (void *)(mem->base + tadr);
if ((unsigned int)*s < p->val) {
ret = tstinsert(mem, p->lo, s, &t);
if (ret)
return ret;
p = (void *)(mem->base + tadr); //recalc pointer
p->lo = t;
} else if ((unsigned int)*s == p->val) {
if (*s) {
ret = tstinsert(mem, p->eq, ++s, &t);
if (ret)
return ret;
p = (void *)(mem->base + tadr); //recalc pointer
p->eq = t;
}else {
xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &nstk);
p->eq = xpost_stack_count(mem, nstk); /* payload when val == '\0' */
}
} else {
ret = tstinsert(mem, p->hi, s, &t);
if (ret)
return ret;
p = (void *)(mem->base + tadr); //recalc pointer
p->hi = t;
}
//return tadr;
*retval = tadr;
return 0;
}
int xpost_oper_init_packedarray_ops (Xpost_Context *ctx,
Xpost_Object sd)
{
Xpost_Operator *optab;
Xpost_Object n,op;
unsigned int optadr;
assert(ctx->gl->base);
xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_OPERATOR_TABLE, &optadr);
optab = (void *)(ctx->gl->base + optadr);
op = xpost_operator_cons(ctx, "packedarray", (Xpost_Op_Func)packedarray, 1, 1, integertype);
INSTALL;
xpost_dict_put(ctx, sd, xpost_name_cons(ctx, "currentpacking"), xpost_bool_cons(0));
op = xpost_operator_cons(ctx, "setpacking", (Xpost_Op_Func)setpacking, 0, 1, booleantype);
INSTALL;
/* xpost_dict_dump_memory (ctx->gl, sd); fflush(NULL);
xpost_dict_put(ctx, sd, xpost_name_cons(ctx, "mark"), mark); */
return 0;
}
/* save restore -
rewind vm to saved state */
static
int Vrestore (Xpost_Context *ctx,
Xpost_Object V)
{
int z;
unsigned int vs;
int ret;
ret = xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_SAVE_STACK, &vs);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for save stack");
return VMerror;
}
z = xpost_stack_count(ctx->lo, vs);
while(z > V.save_.lev) {
xpost_save_restore_snapshot(ctx->lo);
z--;
}
printf("restore\n");
return 0;
}
/* traverse the contents of composite objects
if markall is true, this is a collection of global vm,
so we must mark objects and recurse
even if it means switching memory files
*/
static
int _xpost_garbage_mark_object(Xpost_Context *ctx,
Xpost_Memory_File *mem,
Xpost_Object o,
int markall)
{
unsigned int ad;
int ret;
if (!mem) return 0;
switch(xpost_object_get_type(o)) {
default: break;
case arraytype:
#ifdef DEBUG_GC
printf("markobject: %d, %s (size %d)\n",
xpost_object_get_ent(o),
xpost_object_type_names[xpost_object_get_type(o)],
o.comp_.sz);
#endif
if (xpost_context_select_memory(ctx, o) != mem) {
if (markall)
mem = xpost_context_select_memory(ctx, o);
else
break;
}
if (!mem) return 0;
if (!_xpost_garbage_ent_is_marked(mem, xpost_object_get_ent(o), &ret))
return 0;
if (!ret) {
ret = _xpost_garbage_mark_ent(mem, xpost_object_get_ent(o));
if (!ret)
{
XPOST_LOG_ERR("cannot mark array");
return 0;
}
ret = xpost_memory_table_get_addr(mem, xpost_object_get_ent(o), &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for array ent %u", xpost_object_get_ent(o));
return 0;
}
if (!_xpost_garbage_mark_array(ctx, mem, ad, o.comp_.sz, markall))
return 0;
}
break;
case dicttype:
#ifdef DEBUG_GC
printf("markobject: %d, %s (size %d)\n",
xpost_object_get_ent(o),
xpost_object_type_names[xpost_object_get_type(o)],
o.comp_.sz);
#endif
if (xpost_context_select_memory(ctx, o) != mem) {
if (markall)
mem = xpost_context_select_memory(ctx, o);
else
break;
}
if (!_xpost_garbage_ent_is_marked(mem, xpost_object_get_ent(o), &ret))
return 0;
if (!ret) {
ret = _xpost_garbage_mark_ent(mem, xpost_object_get_ent(o));
if (!ret)
{
XPOST_LOG_ERR("cannot mark dict");
return 0;
}
ret = xpost_memory_table_get_addr(mem, xpost_object_get_ent(o), &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for dict ent %u", xpost_object_get_ent(o));
return 0;
}
if (!_xpost_garbage_mark_dict(ctx, mem, ad, markall))
return 0;
}
break;
case stringtype:
#ifdef DEBUG_GC
printf("markobject: %d, %s (size %d)\n",
xpost_object_get_ent(o),
xpost_object_type_names[xpost_object_get_type(o)],
o.comp_.sz);
#endif
if (xpost_context_select_memory(ctx, o) != mem) {
if (markall)
mem = xpost_context_select_memory(ctx, o);
else
break;
}
ret = _xpost_garbage_mark_ent(mem, xpost_object_get_ent(o));
if (!ret)
{
XPOST_LOG_ERR("cannot mark string");
return 0;
}
break;
case filetype:
if (mem == ctx->gl) {
printf("file found in global vm\n");
} else {
ret = _xpost_garbage_mark_ent(mem, o.mark_.padw);
if (!ret)
{
XPOST_LOG_ERR("cannot mark file");
return 0;
}
}
break;
}
return 1;
}
/* any string cvs string
convert any object to string representation */
static
int AScvs (Xpost_Context *ctx,
Xpost_Object any,
Xpost_Object str)
{
char nostringval[] = "-nostringval-";
char strue[] = "true";
char sfalse[] = "false";
char smark[] = "-mark-";
char ssave[] = "-save-";
int n;
int ret;
switch(xpost_object_get_type(any)) {
default:
if (str.comp_.sz < sizeof(nostringval)-1)
return rangecheck;
memcpy(xpost_string_get_pointer(ctx, str), nostringval, sizeof(nostringval)-1);
str.comp_.sz = sizeof(nostringval)-1;
break;
case savetype:
if (str.comp_.sz < sizeof(ssave)-1)
return rangecheck;
memcpy(xpost_string_get_pointer(ctx, str), ssave, sizeof(ssave)-1);
str.comp_.sz = sizeof(ssave)-1;
break;
case marktype:
if (str.comp_.sz < sizeof(smark)-1)
return rangecheck;
memcpy(xpost_string_get_pointer(ctx, str), smark, sizeof(smark)-1);
str.comp_.sz = sizeof(smark)-1;
break;
case booleantype:
{
if (any.int_.val) {
if (str.comp_.sz < sizeof(strue)-1)
return rangecheck;
memcpy(xpost_string_get_pointer(ctx, str), strue, sizeof(strue)-1);
str.comp_.sz = sizeof(strue)-1;
} else {
if (str.comp_.sz < sizeof(sfalse)-1)
return rangecheck;
memcpy(xpost_string_get_pointer(ctx, str), sfalse, sizeof(sfalse)-1);
str.comp_.sz = sizeof(sfalse)-1;
}
}
break;
case integertype:
{
//n = conv_rad(any.int_.val, 10, xpost_string_get_pointer(ctx, str), str.comp_.sz);
char *s = xpost_string_get_pointer(ctx, str);
int sz = str.comp_.sz;
n = 0;
if (any.int_.val < 0) {
s[n++] = '-';
any.int_.val = abs(any.int_.val);
--sz;
}
n += conv_integ((real)any.int_.val, s + n, sz);
if (n == -1)
return rangecheck;
if (n < str.comp_.sz) str.comp_.sz = n;
break;
}
case realtype:
n = conv_real(any.real_.val, xpost_string_get_pointer(ctx, str), str.comp_.sz);
if (n == -1)
return rangecheck;
if (n < str.comp_.sz) str.comp_.sz = n;
break;
case operatortype:
{
unsigned int optadr;
Xpost_Operator *optab;
Xpost_Operator op;
Xpost_Object_Mark nm;
ret = xpost_memory_table_get_addr(ctx->gl,
XPOST_MEMORY_TABLE_SPECIAL_OPERATOR_TABLE, &optadr);
if (!ret)
{
XPOST_LOG_ERR("cannot load optab!");
return VMerror;
}
optab = (void *)(ctx->gl->base + optadr);
op = optab[any.mark_.padw];
nm.tag = nametype | XPOST_OBJECT_TAG_DATA_FLAG_BANK;
nm.pad0 = 0;
nm.padw = op.name;
any.mark_ = nm;
}
/*@fallthrough@*/
case nametype:
any = xpost_name_get_string(ctx, any);
/*@fallthrough@*/
case stringtype:
if (any.comp_.sz > str.comp_.sz)
return rangecheck;
if (any.comp_.sz < str.comp_.sz) str.comp_.sz = any.comp_.sz;
memcpy(xpost_string_get_pointer(ctx, str), xpost_string_get_pointer(ctx, any), any.comp_.sz);
break;
}
xpost_stack_push(ctx->lo, ctx->os, str);
return 0;
}
/* mark all allocations referred to by objects in save object's stack of saverec_'s */
static
int _xpost_garbage_mark_save_stack(Xpost_Context *ctx,
Xpost_Memory_File *mem,
unsigned int stackadr)
{
if (!mem) return 0;
{
Xpost_Stack *s = (Xpost_Stack *)(mem->base + stackadr);
unsigned int i;
unsigned int ad;
int ret;
(void)ctx;
#ifdef DEBUG_GC
printf("marking save stack of size %u\n", xpost_stack_count(mem, stackadr));
#endif
next:
for (i=0; i < s->top; i++) {
/* _xpost_garbage_mark_object(ctx, mem, s->data[i]); */
/* _xpost_garbage_mark_save_stack(ctx, mem, s->data[i].save_.stk); */
ret = _xpost_garbage_mark_ent(mem, s->data[i].saverec_.src);
if (!ret)
{
XPOST_LOG_ERR("cannot mark array");
return 0;
}
ret = _xpost_garbage_mark_ent(mem, s->data[i].saverec_.cpy);
if (!ret)
{
XPOST_LOG_ERR("cannot mark array");
return 0;
}
if (s->data[i].saverec_.tag == dicttype) {
ret = xpost_memory_table_get_addr(mem, s->data[i].saverec_.src, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for ent %u",
s->data[i].saverec_.src);
return 0;
}
if (!_xpost_garbage_mark_dict(ctx, mem, ad, 0))
return 0;
ret = xpost_memory_table_get_addr(mem, s->data[i].saverec_.cpy, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for ent %u",
s->data[i].saverec_.cpy);
return 0;
}
if (!_xpost_garbage_mark_dict(ctx, mem, ad, 0))
return 0;
}
if (s->data[i].saverec_.tag == arraytype) {
unsigned int sz = s->data[i].saverec_.pad;
ret = xpost_memory_table_get_addr(mem, s->data[i].saverec_.src, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for array ent %u",
s->data[i].saverec_.src);
return 0;
}
if (!_xpost_garbage_mark_array(ctx, mem, ad, sz, 0))
return 0;
ret = xpost_memory_table_get_addr(mem, s->data[i].saverec_.cpy, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot retrieve address for array ent %u",
s->data[i].saverec_.cpy);
return 0;
}
if (!_xpost_garbage_mark_array(ctx, mem, ad, sz, 0))
return 0;
}
}
if (i==XPOST_STACK_SEGMENT_SIZE) { /* ie. s->top == XPOST_STACK_SEGMENT_SIZE */
s = (Xpost_Stack *)(mem->base + s->nextseg);
goto next;
}
if (s->nextseg) {
xpost_stack_free(mem, s->nextseg);
s->nextseg = 0;
}
}
return 1;
}
/*
execute ps program until quit, fall-through to quit,
SHOWPAGE_RETURN semantic, or error (default action: message, purge and quit).
*/
XPAPI int xpost_run(Xpost_Context *ctx, Xpost_Input_Type input_type, const void *inputptr, size_t set_size)
{
Xpost_Object lsav = null;
int llev = 0;
unsigned int vs;
const char *ps_str = NULL;
const char *ps_file = NULL;
const FILE *ps_file_ptr = NULL;
int ret;
Xpost_Object device;
Xpost_Object semantic;
switch(input_type)
{
case XPOST_INPUT_FILENAME:
ps_file = inputptr;
break;
case XPOST_INPUT_STRING:
ps_str = inputptr;
ps_file_ptr = tmpfile();
if (set_size)
fwrite(ps_str, 1, set_size, (FILE*)ps_file_ptr);
else
fwrite(ps_str, 1, strlen(ps_str), (FILE*)ps_file_ptr);
rewind((FILE*)ps_file_ptr);
break;
case XPOST_INPUT_FILEPTR:
ps_file_ptr = inputptr;
break;
case XPOST_INPUT_RESUME: /* resuming a returned session, skip startup */
goto run;
}
/* prime the exec stack
so it starts with a 'start*' procedure,
and if it ever gets to the bottom, it quits.
These procedures are all defined in data/init.ps
*/
xpost_stack_push(ctx->lo, ctx->es, xpost_operator_cons(ctx, "quit", NULL,0,0));
/*
if ps_file is NULL:
if stdin is a tty
`start` proc defined in init.ps runs `executive` which prompts for user input
else
'startstdin' executes stdin but does not prompt
if ps_file is not NULL:
'startfile' executes a named file wrapped in a stopped context with handleerror
*/
if (ps_file)
{
/*printf("ps_file\n"); */
xpost_stack_push(ctx->lo, ctx->os, xpost_object_cvlit(xpost_string_cons(ctx, strlen(ps_file), ps_file)));
xpost_stack_push(ctx->lo, ctx->es, xpost_object_cvx(xpost_name_cons(ctx, "startfilename")));
}
else if (ps_file_ptr)
{
xpost_stack_push(ctx->lo, ctx->os, xpost_object_cvlit(xpost_file_cons(ctx->lo, ps_file_ptr)));
xpost_stack_push(ctx->lo, ctx->es, xpost_object_cvx(xpost_name_cons(ctx, "startfile")));
}
else
{
if (xpost_isatty(fileno(stdin)))
xpost_stack_push(ctx->lo, ctx->es, xpost_object_cvx(xpost_name_cons(ctx, "start")));
else
xpost_stack_push(ctx->lo, ctx->es, xpost_object_cvx(xpost_name_cons(ctx, "startstdin")));
}
(void) xpost_save_create_snapshot_object(ctx->gl);
lsav = xpost_save_create_snapshot_object(ctx->lo);
/* Run! */
run:
ctx->quit = 0;
ctx->state = C_RUN;
ret = mainloop(ctx);
semantic = xpost_dict_get(ctx,
xpost_stack_bottomup_fetch(ctx->lo, ctx->ds, 0),
xpost_name_cons(ctx, "ShowpageSemantics"));
if (semantic.int_.val == XPOST_SHOWPAGE_RETURN)
return ret == 1 ? yieldtocaller : 0;
XPOST_LOG_INFO("destroying device");
device = xpost_dict_get(ctx,
xpost_stack_bottomup_fetch(ctx->lo, ctx->ds, 2),
xpost_name_cons(ctx, "DEVICE"));
XPOST_LOG_INFO("device type=%s", xpost_object_type_names[xpost_object_get_type(device)]);
/*xpost_operator_dump(ctx, 1); // is this pointer value constant? */
if (xpost_object_get_type(device) == arraytype){
XPOST_LOG_INFO("running proc");
xpost_stack_push(ctx->lo, ctx->es, xpost_operator_cons(ctx, "quit", NULL,0,0));
xpost_stack_push(ctx->lo, ctx->es, device);
ctx->quit = 0;
mainloop(ctx);
device = xpost_stack_pop(ctx->lo, ctx->os);
}
if (xpost_object_get_type(device) == dicttype)
{
Xpost_Object Destroy;
XPOST_LOG_INFO("destroying device dict");
Destroy = xpost_dict_get(ctx, device, xpost_name_cons(ctx, "Destroy"));
if (xpost_object_get_type(Destroy) == operatortype)
{
int res;
xpost_stack_push(ctx->lo, ctx->os, device);
res = xpost_operator_exec(ctx, Destroy.mark_.padw);
if (res)
XPOST_LOG_ERR("%s error destroying device", errorname[res]);
else
XPOST_LOG_INFO("destroyed device");
}
}
xpost_save_restore_snapshot(ctx->gl);
xpost_memory_table_get_addr(ctx->lo,
XPOST_MEMORY_TABLE_SPECIAL_SAVE_STACK, &vs);
if (xpost_object_get_type(lsav) == savetype)
{
for ( llev = xpost_stack_count(ctx->lo, vs);
llev > lsav.save_.lev;
llev-- )
{
xpost_save_restore_snapshot(ctx->lo);
}
}
return noerror;
}
/* 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;
}
/*
determine GLOBAL/LOCAL
clear all marks,
mark all root stacks,
sweep.
return reclaimed size or -1 if error occured.
*/
int xpost_garbage_collect(Xpost_Memory_File *mem, int dosweep, int markall)
{
unsigned int i;
unsigned int *cid;
Xpost_Context *ctx = NULL;
int isglobal;
unsigned int sz = 0;
unsigned int ad;
int ret;
if (mem->interpreter_get_initializing()) /* do not collect while initializing */
return 0;
/* printf("\ncollect:\n"); */
/* determine global/local */
isglobal = 0;
ret = xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_CONTEXT_LIST, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot load context list");
return -1;
}
cid = (void *)(mem->base + ad);
for (i = 0; i < MAXCONTEXT && cid[i]; i++) {
ctx = mem->interpreter_cid_get_context(cid[i]);
if (ctx->state != 0) {
if (mem == ctx->gl) {
isglobal = 1;
break;
}
}
}
#ifdef DEBUG_GC
printf("using cid=%d\n", ctx->id);
#endif
if (isglobal) {
return 0; /* do not perform global collections at this time */
_xpost_garbage_unmark(mem);
ret = xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_SAVE_STACK, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot load save stack for %s memory",
mem == ctx->gl? "global" : "local");
return -1;
}
if (!_xpost_garbage_mark_save(ctx, mem, ad))
return -1;
ret = xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot load name stack for %s memory",
mem == ctx->gl? "global" : "local");
return -1;
}
if (!_xpost_garbage_mark_stack(ctx, mem, ad, markall))
return -1;
for (i = 0; i < MAXCONTEXT && cid[i]; i++) {
ctx = mem->interpreter_cid_get_context(cid[i]);
xpost_garbage_collect(ctx->lo, 0, markall);
}
} else { /* local */
//printf("collect!\n");
_xpost_garbage_unmark(mem);
ret = xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_SAVE_STACK, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot load save stack for %s memory",
mem == ctx->gl? "global" : "local");
return -1;
}
if (!_xpost_garbage_mark_save(ctx, mem, ad))
return -1;
ret = xpost_memory_table_get_addr(mem,
XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK, &ad);
if (!ret)
{
XPOST_LOG_ERR("cannot load name stack for %s memory",
mem == ctx->gl? "global" : "local");
return -1;
}
#ifdef DEBUG_GC
printf("marking name stack\n");
#endif
if (!_xpost_garbage_mark_stack(ctx, mem, ad, markall))
return -1;
for (i = 0; i < MAXCONTEXT && cid[i]; i++) {
ctx = mem->interpreter_cid_get_context(cid[i]);
#ifdef DEBUG_GC
printf("marking os\n");
#endif
if (!_xpost_garbage_mark_stack(ctx, mem, ctx->os, markall))
return -1;
#ifdef DEBUG_GC
printf("marking ds\n");
#endif
if (!_xpost_garbage_mark_stack(ctx, mem, ctx->ds, markall))
return -1;
#ifdef DEBUG_GC
printf("marking es\n");
#endif
if (!_xpost_garbage_mark_stack(ctx, mem, ctx->es, markall))
return -1;
#ifdef DEBUG_GC
printf("marking hold\n");
#endif
if (!_xpost_garbage_mark_stack(ctx, mem, ctx->hold, markall))
return -1;
#ifdef DEBUG_GC
printf("marking window device\n");
#endif
if (!_xpost_garbage_mark_object(ctx, mem, ctx->window_device, markall))
return -1;
}
}
if (dosweep) {
#ifdef DEBUG_GC
printf("sweep\n");
#endif
sz += _xpost_garbage_sweep(mem);
if (isglobal) {
for (i = 0; i < MAXCONTEXT && cid[i]; i++) {
ctx = mem->interpreter_cid_get_context(cid[i]);
sz += _xpost_garbage_sweep(ctx->lo);
}
}
}
printf("collect recovered %u bytes\n", sz);
return sz;
}
int main(void)
{
if (!xpost_init())
{
fprintf(stderr, "Fail to initialize xpost name test\n");
return -1;
}
printf("\n^test nm\n");
//init(&ctx);
init();
ctx->vmmode = LOCAL;
printf("pop ");
xpost_object_dump(xpost_name_cons(ctx, "pop"));
printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
//xpost_stack_dump(ctx->gl, xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)); puts("");
printf("apple ");
xpost_object_dump(xpost_name_cons(ctx, "apple"));
xpost_object_dump(xpost_name_cons(ctx, "apple"));
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
//xpost_stack_dump(ctx->gl, xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)); puts("");
printf("banana ");
xpost_object_dump(xpost_name_cons(ctx, "banana"));
xpost_object_dump(xpost_name_cons(ctx, "banana"));
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
//xpost_stack_dump(ctx->gl, xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)); puts("");
printf("currant ");
xpost_object_dump(xpost_name_cons(ctx, "currant"));
xpost_object_dump(xpost_name_cons(ctx, "currant"));
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
//xpost_stack_dump(ctx->gl, xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)); puts("");
printf("apple ");
xpost_object_dump(xpost_name_cons(ctx, "apple"));
printf("banana ");
xpost_object_dump(xpost_name_cons(ctx, "banana"));
printf("currant ");
xpost_object_dump(xpost_name_cons(ctx, "currant"));
printf("date ");
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
xpost_object_dump(xpost_name_cons(ctx, "date"));
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
xpost_stack_dump(ctx->gl, xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK)); puts("");
//printf("NAMES at %u\n", xpost_memory_table_get_addr(ctx->gl, XPOST_MEMORY_TABLE_SPECIAL_NAME_STACK));
printf("elderberry ");
xpost_object_dump(xpost_name_cons(ctx, "elderberry"));
printf("pop ");
xpost_object_dump(xpost_name_cons(ctx, "pop"));
//xpost_memory_file_dump(ctx->gl);
//dumpmtab(ctx->gl, 0);
puts("");
xpost_quit();
return 0;
}
