/* 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);
}
}
/* 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;
}
/* |- any1..anyN count |- any1..anyN N
count elements on stack */
static
int Zcount (Xpost_Context *ctx)
{
if (!xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(xpost_stack_count(ctx->lo, ctx->os))))
return stackoverflow;
return 0;
}
/* mark all allocations referred to by objects in save stack */
static
int _xpost_garbage_mark_save(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;
#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]); */
if (!_xpost_garbage_mark_save_stack(ctx, mem, s->data[i].save_.stk))
return 0;
}
if (i==XPOST_STACK_SEGMENT_SIZE) { /* ie. s->top == XPOST_STACK_SEGMENT_SIZE */
s = (void *)(mem->base + s->nextseg);
goto next;
}
}
return 1;
}
/* mark all allocations referred to by objects in stack */
static
int _xpost_garbage_mark_stack(Xpost_Context *ctx,
Xpost_Memory_File *mem,
unsigned int stackadr,
int markall)
{
if (!mem) return 0;
{
Xpost_Stack *s = (Xpost_Stack *)(mem->base + stackadr);
unsigned int i;
#ifdef DEBUG_GC
printf("marking stack of size %u\n", xpost_stack_count(mem, stackadr));
#endif
next:
for (i=0; i < s->top; i++) {
if (!_xpost_garbage_mark_object(ctx, mem, s->data[i], markall))
return 0;
}
if (i==XPOST_STACK_SEGMENT_SIZE) { /* ie. s->top == XPOST_STACK_SEGMENT_SIZE */
if (s->nextseg == 0)
return 0;
s = (Xpost_Stack *)(mem->base + s->nextseg);
goto next;
}
/* if (s->nextseg) { /\* maybe not. this is a MARK phase, after all *\/ */
/* xpost_stack_free(mem, s->nextseg); */
/* s->nextseg = 0; */
/* } */
}
return 1;
}
/* - 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;
}
/* 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;
}
/* 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;
}
/* 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;
}
/* - 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;
}
/* 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;
}
/*
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;
}
/* 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;
}
