#define DEBUG 0 #include "debug.h" #include "obj.h" /* IMPLEMENTATION CONSTANTS */ OBJ null, nullvec, nullstr, false, true, eof; void tree_copy (void) { /* COPIES TREE ACC INTO ACC */ if (is_pair(acc)) { push(cdr(acc)); /* SAVE CDR STATE */ acc=car(acc); /* RECURSE ON CAR */ tree_copy(); r1=acc; /* RESTORE CDR, STORE CAR */ acc=pop(); push(r1); tree_copy(); /* RECURSE ON CDR */ push(acc); /* FORM NEW PAIR */ new_pair(); } } void new_integer (S64 l) { mem_new_ary(TINTEGER, sizeof(S64)); *(S64*)mem_ary_ref(acc, 0) = l; } void new_real (R64 r) { mem_new_ary(TREAL, sizeof(R64)); *(R64*)mem_ary_ref(acc, 0) = r; } void new_string (char *s, U32 len) { char *a, *as; a=as=(char*)malloc(len); while(len--) { if (*s=='\\' && len>0) { len--; s++; switch(*s) { case 'a' : *as = '\a'; break; case 'e' : *as = '\e'; break; case 'c' : *as = '\233'; break; case 'n' : *as = '\n'; break; case 'r' : *as = '\r'; break; case 't' : *as = '\t'; break; default : *as = *s; } } else *as = *s; as++; s++; } mem_new_ary(TSTRING, as-a); memcpy((char*)mem_ary_ref(acc, 0), a, as-a); free(a); } void new_symbol (char *s, U32 len) { char *a, *as; a=as=(char*)malloc(len); while(len--) { if (*s=='\\' && len>0) { len--; s++; switch(*s) { case 'e' : *as = '\e'; break; case 'n' : *as = '\n'; break; case 'r' : *as = '\r'; break; case 't' : *as = '\t'; break; default : *as = *s; } } else *as = *s; as++; s++; } mem_new_ary(TSYMBOL, as-a); memcpy((char*)mem_ary_ref(acc, 0), a, as-a); free(a); } void new_prim (void(*fp)()){ mem_new_static(TPRIM, 4); *((void(**)())acc) = fp; } void new_syntax (void(*fp)()){ mem_new_static(TSYNTAX, 4); *((void(**)())acc) = fp; } void new_opcode (void(*fp)()){ mem_new_static(TOPCODE, 4); *((void(**)())acc) = fp; } void new_reference (U32 generation, U32 offset) { mem_new_ary(TREFERENCE, 2*sizeof(U32)); *(U32*)mem_ary_ref(acc, 0) = generation; *(U32*)mem_ary_ref(acc, sizeof(U32)) = offset; } void new_pair (void) { mem_new_vec(TPAIR, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_vector (U32 l) { mem_new_vec(TVECTOR, l); } void list_to_vector_ (U32 c) { static U32 len; if (!is_pair(r1)) { r1=pop(); /* LIST */ if(c) { new_vector(c);/* NOW EMPTY VECTOR */ len=c-1; } else acc = nullvec; /* EMPTY VECTOR IS SPECIAL */ } else { r1=cdr(r1); list_to_vector_(c+1); mem_vec_set(acc, len-c, car(r1)); r1=cdr(r1); } } void list_to_vector (void) { push(r1=acc); list_to_vector_(0); /* ACCUMULATOR ASSUMED TO HOLD LIST */ } void new_procedure (void) { mem_new_vec(TPROCEDURE, 2); mem_vec_set(acc, 1, pop()); /* BODY */ mem_vec_set(acc, 0, pop()); /* ARGS */ } void new_closure (void) { mem_new_vec(TCLOSURE, 3); mem_vec_set(acc, 2, pop()); /* BODY */ mem_vec_set(acc, 1, pop()); /* ARGS */ mem_vec_set(acc, 0, pop()); /* EXTENDED ENV */ } void new_binding (void) { mem_new_vec(TBINDING, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_continuation(void) { U32 length = mem_stk_count(stack); mem_new_vec(TCONTINUATION, length); memcpy(acc, stack+sizeof(OBJ), length*sizeof(OBJ)); /* IS THIS NAUGHTY? */ } void new_push (void) { mem_new_vec(TPUSH, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_setbinding (void) { mem_new_vec(TSETBINDING, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_setreference (void) { mem_new_vec(TSETREFERENCE, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_apply (void) { mem_new_vec(TAPPLY, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_comb (void) { mem_new_vec(TCOMB, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_popacc (void) { mem_new_vec(TPOPACC, 1); mem_vec_set(acc, 0, pop()); } void new_if (void) { mem_new_vec(TIF, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_or (void) { mem_new_vec(TOR, 1); mem_vec_set(acc, 0, pop()); } void new_define (void) { mem_new_vec(TDEFINE, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_call (void) { mem_new_vec(TCALL, 2); mem_vec_set(acc, 1, pop()); mem_vec_set(acc, 0, pop()); } void new_stack(U32 size) { mem_new_stk(TSTACK, size); } /* MAKE SURE WE CLOSE THE FILE* ONCE IN IT'S LIFETIME */ /* BF: SHOULDN'T I DECREMENT THE DIRTY COUNT ALSO? SINC IT'S NOT DIRTY ANYMORE? AS WELL AS MUTATE THE TYPE TO NOT DIRTY? */ void close_port(void *data) { void *dp; if (*(int*)data) { close(*(int*)data); free(*((char**)data+1)); *(int*)data = -1; } } void new_port(int fp, char *filename, int flags, int mode) { void *dp; mem_new_drt(TPORT, sizeof(int) + sizeof(char*) + sizeof(int) + sizeof(int)); *(CFP*)mem_drt_clnr(acc) = close_port; /* SET CLEANER FUNCTION */ dp = mem_drt_ref(acc, 0); *(int*)dp = fp; /* SET OBJECT'S VALUE */ *((char**)dp+1) = filename; *((int*)dp+2) = flags; *((int*)dp+3) = mode; } /* OBJECT SELECTORS */ S64 obj_integer (OBJ a) {return *(S64*)mem_ary_ref(a, 0);} R64 obj_real (OBJ a) {return *(R64*)mem_ary_ref(a, 0);} char* obj_symbol (OBJ a) {return (char*)mem_ary_ref(a, 0);} U32 obj_symbol_len (OBJ o) {return obj_len(o);} U32 obj_vector_len (OBJ o) {return obj_len(o);} OBJ* obj_vector_ref (OBJ o, U32 i) {return mem_vec_ref(o, i);} U32 reference_generation (OBJ o) {return *(U32*)mem_ary_ref(o, 0);} U32 reference_offset (OBJ o) {return *(U32*)mem_ary_ref(o, sizeof(U32));} FP obj_function(OBJ a) {return *(FP*)mem_ary_ref(a, 0);} OBJ closure_env (OBJ p) {return mem_vec_obj(p, 0);} OBJ closure_args (OBJ p) {return mem_vec_obj(p, 1);} OBJ closure_body (OBJ p) {return mem_vec_obj(p, 2);} OBJ env_parent (OBJ e) {return mem_vec_obj(e, 0);} OBJ env_symbols (OBJ e) {return mem_vec_obj(e, 1);} OBJ env_value (OBJ e, U32 i) {return mem_vec_obj(e, i+2);} OBJ binding_symbol (OBJ o) {return mem_vec_obj(o, 0);} OBJ binding_value (OBJ o) {return mem_vec_obj(o, 1);} int obj_port (OBJ o) {return *(int*)mem_drt_ref(o, 0);}