/* 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;
}
int main(void)
{
if (!xpost_init())
{
fprintf(stderr, "Fail to initialize xpost dict test\n");
return -1;
}
init();
printf("\n^test gc.c\n");
ctx = &itpdata->ctab[0];
mem = ctx->lo;
stac = ctx->os;
xpost_stack_push(mem, stac, xpost_int_cons(5));
xpost_stack_push(mem, stac, xpost_int_cons(6));
xpost_stack_push(mem, stac, xpost_real_cons(7.0));
Xpost_Object ar;
ar = xpost_array_cons_memory(mem, 3);
int i;
for (i=0; i < 3; i++)
xpost_array_put_memory(mem, ar, i, xpost_stack_pop(mem, stac));
xpost_stack_push(mem, stac, ar); /* array on stack */
xpost_stack_push(mem, stac, xpost_int_cons(1));
xpost_stack_push(mem, stac, xpost_int_cons(2));
xpost_stack_push(mem, stac, xpost_int_cons(3));
ar = xpost_array_cons_memory(mem, 3);
for (i=0; i < 3; i++)
xpost_array_put_memory(mem, ar, i, xpost_stack_pop(mem, stac));
xpost_object_dump(ar);
/* array not on stack */
#define CNT_STR(x) sizeof(x), x
xpost_stack_push(mem, stac, xpost_string_cons_memory(mem, CNT_STR("string on stack")));
xpost_object_dump(xpost_string_cons_memory(mem, CNT_STR("string not on stack")));
collect(mem);
xpost_stack_push(mem, stac, xpost_string_cons_memory(mem, CNT_STR("string on stack")));
xpost_object_dump(xpost_string_cons_memory(mem, CNT_STR("string not on stack")));
collect(mem);
xpost_memory_file_dump(mem);
printf("stackaedr: %04x\n", stac);
dumpmtab(mem, 0);
/* ^ent 8 (8): adr 3404 0x0d4c, sz [24], mark _ */
/* ^ 06 00 00 00 6en 67g 20 6en 6fo 74t 20 */
printf("gc: look at the mark field . . . . . . . .^\n");
printf("also, see that the first 4 bytes of strings not on stack\n"
"have been obliterated to link-up the free list.\n");
xpost_quit();
}
static
Xpost_Object get_token(Xpost_Context *ctx, char *str){
Xpost_Object o;
xpost_stack_push(ctx->lo, ctx->os, xpost_string_cons(ctx, strlen(str), str));
xpost_operator_exec(ctx, xpost_operator_cons(ctx, "token",NULL,0,0).mark_.padw);
if (xpost_stack_pop(ctx->lo, ctx->os).int_.val){
o = xpost_stack_pop(ctx->lo, ctx->os);
xpost_stack_pop(ctx->lo, ctx->os);
} else {
o = null;
}
return o;
}
/* pop the execution stack */
static
int evalpop(Xpost_Context *ctx)
{
if (!xpost_object_get_type(xpost_stack_pop(ctx->lo, ctx->es)) == invalidtype)
return stackunderflow;
return 0;
}
/* pop the execution stack onto the operand stack */
static
int evalpush(Xpost_Context *ctx)
{
if (!xpost_stack_push(ctx->lo, ctx->os,
xpost_stack_pop(ctx->lo, ctx->es)))
return stackoverflow;
return 0;
}
/* mark obj1..objN cleartomark -
discard elements down through mark */
int xpost_op_cleartomark (Xpost_Context *ctx)
{
Xpost_Object o;
do {
o = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(o) == invalidtype)
return unmatchedmark;
} while (o.tag != marktype);
return 0;
}
/* extract token from string */
static
int evalstring(Xpost_Context *ctx)
{
Xpost_Object b,t,s;
int ret;
s = xpost_stack_pop(ctx->lo, ctx->es);
if (!xpost_stack_push(ctx->lo, ctx->os, s))
return stackoverflow;
assert(ctx->gl->base);
/*xpost_operator_exec(ctx, xpost_operator_cons(ctx, "token",NULL,0,0).mark_.padw); */
ret = xpost_operator_exec(ctx, ctx->opcode_shortcuts.token);
if (ret)
return ret;
b = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(b) == invalidtype)
return stackunderflow;
if (b.int_.val)
{
t = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(t) == invalidtype)
return stackunderflow;
s = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(s) == invalidtype)
return stackunderflow;
if (!xpost_stack_push(ctx->lo, ctx->es, s))
return execstackoverflow;
if (xpost_object_get_type(t)==arraytype)
{
if (!xpost_stack_push(ctx->lo, ctx->os , t))
return stackoverflow;
}
else
{
if (!xpost_stack_push(ctx->lo, ctx->es , t))
return execstackoverflow;
}
}
return 0;
}
/* extract token from file */
static
int evalfile(Xpost_Context *ctx)
{
Xpost_Object b,f,t;
int ret;
f = xpost_stack_pop(ctx->lo, ctx->es);
if (!xpost_stack_push(ctx->lo, ctx->os, f))
return stackoverflow;
assert(ctx->gl->base);
/*xpost_operator_exec(ctx, xpost_operator_cons(ctx, "token",NULL,0,0).mark_.padw); */
ret = xpost_operator_exec(ctx, ctx->opcode_shortcuts.token);
if (ret)
return ret;
b = xpost_stack_pop(ctx->lo, ctx->os);
if (b.int_.val)
{
t = xpost_stack_pop(ctx->lo, ctx->os);
if (!xpost_stack_push(ctx->lo, ctx->es, f))
return execstackoverflow;
if (xpost_object_get_type(t)==arraytype)
{
if (!xpost_stack_push(ctx->lo, ctx->os, t))
return stackoverflow;
}
else
{
if (!xpost_stack_push(ctx->lo, ctx->es, t))
return execstackoverflow;
}
}
else
{
ret = xpost_file_object_close(ctx->lo, f);
if (ret)
XPOST_LOG_ERR("%s error closing file", errorname[ret]);
}
return 0;
}
/* execute operator */
static
int evaloperator(Xpost_Context *ctx)
{
int ret;
Xpost_Object op = xpost_stack_pop(ctx->lo, ctx->es);
if (xpost_object_get_type(op) == invalidtype)
return stackunderflow;
if (_xpost_interpreter_is_tracing)
xpost_operator_dump(ctx, op.mark_.padw);
ret = xpost_operator_exec(ctx, op.mark_.padw);
if (ret)
return ret;
return 0;
}
static
int packedarray (Xpost_Context *ctx,
Xpost_Object n)
{
int i;
Xpost_Object a, v;
a = xpost_array_cons(ctx, n.int_.val);
if (xpost_object_get_type(a) == nulltype)
return VMerror;
for (i=n.int_.val; i > 0; i--) {
v = xpost_stack_pop(ctx->lo, ctx->os);
if (xpost_object_get_type(v) == invalidtype)
return stackunderflow;
xpost_array_put(ctx, a, i-1, v);
}
a = xpost_object_set_access(ctx, xpost_object_cvlit(a), XPOST_OBJECT_TAG_ACCESS_READ_ONLY);
xpost_stack_push(ctx->lo, ctx->os, a);
return 0;
}
/* extract head (&tail) of array */
static
int evalarray(Xpost_Context *ctx)
{
Xpost_Object a = xpost_stack_pop(ctx->lo, ctx->es);
Xpost_Object b;
if (xpost_object_get_type(a) == invalidtype)
return stackunderflow;
switch (a.comp_.sz)
{
default /* > 1 */:
{
Xpost_Object interval;
interval = xpost_object_get_interval(a, 1, a.comp_.sz - 1);
if (xpost_object_get_type(interval) == invalidtype)
return rangecheck;
xpost_stack_push(ctx->lo, ctx->es, interval);
}
/*@fallthrough@*/
case 1:
b = xpost_array_get(ctx, a, 0);
if (xpost_object_get_type(b) == arraytype)
{
if (!xpost_stack_push(ctx->lo, ctx->os, b))
return stackoverflow;
}
else
{
if (!xpost_stack_push(ctx->lo, ctx->es, b))
return execstackoverflow;
}
/*@fallthrough@*/
case 0: /* drop */;
}
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;
}
int test_garbage_collect(int (*xpost_interpreter_cid_init)(unsigned int *cid),
Xpost_Context *(*xpost_interpreter_cid_get_context)(unsigned int cid),
int (*xpost_interpreter_get_initializing)(void),
void (*xpost_interpreter_set_initializing)(int),
Xpost_Memory_File *(*xpost_interpreter_alloc_local_memory)(void),
Xpost_Memory_File *(*xpost_interpreter_alloc_global_memory)(void))
{
if (!init_test_garbage(xpost_interpreter_cid_init,
xpost_interpreter_cid_get_context,
xpost_interpreter_get_initializing,
xpost_interpreter_set_initializing,
xpost_interpreter_alloc_local_memory,
xpost_interpreter_alloc_global_memory))
return 0;
{
Xpost_Object str;
unsigned int pre, post, sz, ret;
pre = ctx->lo->used;
str = xpost_string_cons(ctx, 7, "0123456");
post = ctx->lo->used;
sz = post-pre;
/* printf("str sz=%u\n", sz); */
xpost_stack_push(ctx->lo, ctx->os, str);
_clear_hold(ctx);
ret = collect(ctx->lo, 1, 0);
//assert(ret == 0);
if (ret != 0)
{
XPOST_LOG_ERR("Warning: collect returned %d, expected %d", ret, 0);
}
xpost_stack_pop(ctx->lo, ctx->os);
_clear_hold(ctx);
ret = collect(ctx->lo, 1, 0);
/* printf("collect returned %u\n", ret); */
//assert(ret >= sz);
if (! (ret >= sz) )
{
XPOST_LOG_ERR("Warning: collect returned %d, expected >= %d", ret, sz);
}
}
{
Xpost_Object arr;
unsigned int pre, post, sz, ret;
pre = ctx->lo->used;
arr = xpost_array_cons(ctx, 5);
xpost_array_put(ctx, arr, 0, xpost_int_cons(12));
xpost_array_put(ctx, arr, 1, xpost_int_cons(13));
xpost_array_put(ctx, arr, 2, xpost_int_cons(14));
xpost_array_put(ctx, arr, 3, xpost_string_cons(ctx, 5, "fubar"));
xpost_array_put(ctx, arr, 4, xpost_string_cons(ctx, 4, "buzz"));
post = ctx->lo->used;
sz = post-pre;
xpost_stack_push(ctx->lo, ctx->os, arr);
_clear_hold(ctx);
ret = collect(ctx->lo, 1, 0);
//assert(ret == 0);
if (ret != 0)
{
XPOST_LOG_ERR("Warning: collect returned %d, expected %d", ret, 0);
}
xpost_stack_pop(ctx->lo, ctx->os);
_clear_hold(ctx);
ret = collect(ctx->lo, 1, 0);
//assert(ret >= sz);
if (! (ret >= sz) )
{
XPOST_LOG_ERR("Warning: collect returned %d, expected >= %d", ret, sz);
}
}
exit_test_garbage();
return 1;
}
