/* 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; }