/* file string readstring substring true false read from file into string */ static int xpost_op_file_readstring (Xpost_Context *ctx, Xpost_Object F, Xpost_Object S) { int n; Xpost_File *f; char *s; if (!xpost_file_get_status(ctx->lo, F)) return ioerror; if (!xpost_object_is_readable(ctx,F)) return invalidaccess; f = xpost_file_get_file_pointer(ctx->lo, F); s = xpost_string_get_pointer(ctx, S); n = xpost_file_read(s, 1, S.comp_.sz, f); if (n == S.comp_.sz) { xpost_stack_push(ctx->lo, ctx->os, S); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(1)); } else { S.comp_.sz = n; xpost_stack_push(ctx->lo, ctx->os, S); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(0)); } return 0; }
/* file string readline substring true false read a line of text from file */ static int xpost_op_file_readline (Xpost_Context *ctx, Xpost_Object F, Xpost_Object S) { Xpost_File *f; char *s; int n, c = ' '; if (!xpost_file_get_status(ctx->lo, F)) return ioerror; if (!xpost_object_is_readable(ctx,F)) return invalidaccess; f = xpost_file_get_file_pointer(ctx->lo, F); s = xpost_string_get_pointer(ctx, S); for (n = 0; n < S.comp_.sz; n++) { c = xpost_file_getc(f); if (c == EOF || c == '\n') break; s[n] = c; } if (n == S.comp_.sz && c != '\n') return rangecheck; S.comp_.sz = n; xpost_stack_push(ctx->lo, ctx->os, S); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(c != EOF)); return 0; }
/* 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; }
/* any1 any2 exch any2 any1 exchange top two elements */ static int AAexch (Xpost_Context *ctx, Xpost_Object x, Xpost_Object y) { xpost_stack_push(ctx->lo, ctx->os, y); xpost_stack_push(ctx->lo, ctx->os, x); return 0; }
/* any dup any any duplicate top element */ static int Adup (Xpost_Context *ctx, Xpost_Object x) { xpost_stack_push(ctx->lo, ctx->os, x); if (!xpost_stack_push(ctx->lo, ctx->os, x)) return stackoverflow; return 0; }
/* - 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; }
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(); }
/* file status bool return bool indicating whether file object is active or closed */ static int xpost_op_file_status (Xpost_Context *ctx, Xpost_Object F) { xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(xpost_file_get_status(ctx->lo, F))); return 0; }
/* |- 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; }
/* obj cvlit obj set executable attribute in obj to literal (quoted) */ static int Acvlit(Xpost_Context *ctx, Xpost_Object o) { xpost_stack_push(ctx->lo, ctx->os, xpost_object_cvlit(o)); 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; }
static int Ncvn(Xpost_Context *ctx, Xpost_Object n) { xpost_stack_push(ctx->lo, ctx->os, n); return 0; }
/* string cvi int convert initial portion of string to integer */ static int Scvi(Xpost_Context *ctx, Xpost_Object s) { double dbl; long num; char *t = alloca(s.comp_.sz+1); memcpy(t, xpost_string_get_pointer(ctx, s), s.comp_.sz); t[s.comp_.sz] = '\0'; dbl = strtod(t, NULL); if ((dbl == HUGE_VAL || dbl -HUGE_VAL) && errno==ERANGE) return limitcheck; if (dbl >= LONG_MAX || dbl <= LONG_MIN) return limitcheck; num = (long)dbl; /* num = strtol(t, NULL, 10); if ((num == LONG_MAX || num == LONG_MIN) && errno==ERANGE) return limitcheck; */ xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(num)); return 0; }
/* obj xcheck bool test executable attribute in obj */ static int Axcheck(Xpost_Context *ctx, Xpost_Object o) { xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(xpost_object_is_exe(o))); return 0; }
/* obj wcheck bool test obj for write-access */ static int Awcheck(Xpost_Context *ctx, Xpost_Object o) { //xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons( (o.tag & XPOST_OBJECT_TAG_DATA_FLAG_ACCESS_MASK) >> XPOST_OBJECT_TAG_DATA_FLAG_ACCESS_OFFSET == XPOST_OBJECT_TAG_ACCESS_UNLIMITED )); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons( xpost_object_get_access(ctx, o) == XPOST_OBJECT_TAG_ACCESS_UNLIMITED)); return 0; }
/* - save save create save object representing vm contents */ static int Zsave (Xpost_Context *ctx) { if (!xpost_stack_push(ctx->lo, ctx->os, xpost_save_create_snapshot_object(ctx->lo))) return stackoverflow; printf("save\n"); 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; }
/* number cvi int convert number to integer */ static int Ncvi(Xpost_Context *ctx, Xpost_Object n) { if (xpost_object_get_type(n) == realtype) n = xpost_int_cons((integer)n.real_.val); xpost_stack_push(ctx->lo, ctx->os, n); return 0; }
/* number cvr real convert number to real */ static int Ncvr(Xpost_Context *ctx, Xpost_Object n) { if (xpost_object_get_type(n) == integertype) n = xpost_real_cons((real)n.int_.val); xpost_stack_push(ctx->lo, ctx->os, n); return 0; }
/* file string readhexstring substring true false read hex-encoded data from file into string */ static int xpost_op_file_readhexstring (Xpost_Context *ctx, Xpost_Object F, Xpost_Object S) { int n; int c[2]; int eof = 0; Xpost_File *f; char *s; if (!xpost_file_get_status(ctx->lo, F)) return ioerror; if (!xpost_object_is_readable(ctx,F)) return invalidaccess; f = xpost_file_get_file_pointer(ctx->lo, F); s = xpost_string_get_pointer(ctx, S); for (n = 0; !eof && n < S.comp_.sz; n++) { do { c[0] = xpost_file_getc(f); if (c[0] == EOF) ++eof; } while(!eof && strchr(hex, c[0]) != NULL); if (!eof) { do { c[1] = xpost_file_getc(f); if (c[1] == EOF) ++eof; } while(!eof && strchr(hex, c[1]) != NULL); } else { c[1] = '0'; } s[n] = ((strchr(hex, toupper(c[0])) - hex) << 4) | (strchr(hex, toupper(c[1])) - hex); } S.comp_.sz = n; xpost_stack_push(ctx->lo, ctx->os, S); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(!eof)); return 0; }
/* obj readonly obj reduce access attribute for obj to read-only */ static int Areadonly(Xpost_Context *ctx, Xpost_Object o) { //o.tag &= ~XPOST_OBJECT_TAG_DATA_FLAG_ACCESS_MASK; //o.tag |= (XPOST_OBJECT_TAG_ACCESS_READ_ONLY << XPOST_OBJECT_TAG_DATA_FLAG_ACCESS_OFFSET); o = xpost_object_set_access(ctx, o, XPOST_OBJECT_TAG_ACCESS_READ_ONLY); xpost_stack_push(ctx->lo, ctx->os, o); return 0; }
/* any type name return type of any as a nametype object */ static int Atype(Xpost_Context *ctx, Xpost_Object o) { if (xpost_object_get_type(o) >= XPOST_OBJECT_NTYPES) //return unregistered; o = invalid; /* normalize to the all-zero invalid object */ xpost_stack_push(ctx->lo, ctx->os, xpost_object_cvx(xpost_name_cons(ctx, xpost_object_type_names[xpost_object_get_type(o)]))); return 0; }
/* file fileposition int return position of read/write head for file */ static int xpost_op_fileposition (Xpost_Context *ctx, Xpost_Object F) { long pos; pos = xpost_file_tell(xpost_file_get_file_pointer(ctx->lo, F)); if (pos == -1) return ioerror; else xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(pos)); 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; }
/* file bytesavailable int return number of bytes available to read or -1 if not known */ static int xpost_op_file_bytesavailable (Xpost_Context *ctx, Xpost_Object F) { int bytes; int ret; ret = xpost_file_get_bytes_available(ctx->lo, F, &bytes); if (ret) return ret; xpost_stack_push(ctx->lo, ctx->os, xpost_int_cons(bytes)); return 0; }
/* file read int true false read a byte from file */ static int xpost_op_file_read(Xpost_Context *ctx, Xpost_Object f) { Xpost_Object b; if (!xpost_object_is_readable(ctx,f)) return invalidaccess; b = xpost_file_read_byte(ctx->lo, f); if (xpost_object_get_type(b) == invalidtype) return ioerror; if (b.int_.val != EOF) { xpost_stack_push(ctx->lo, ctx->os, b); xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(1)); } else { xpost_stack_push(ctx->lo, ctx->os, xpost_bool_cons(0)); } 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; }
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; }
/* 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; }