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