diff --git a/Makefile b/Makefile index 532a3cc2..b91568d8 100644 --- a/Makefile +++ b/Makefile @@ -10,10 +10,10 @@ GC_OBJ=./gc/gc.a $GC_OBJ: ./gc/alloc.c cd gc && make test -sexp.o: sexp.c sexp.h config.h Makefile +sexp.o: sexp.c sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c eval.h sexp.h config.h Makefile +eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< # main.o: main.c eval.h sexp.h config.h Makefile diff --git a/defaults.h b/defaults.h index f48a538d..5215de72 100644 --- a/defaults.h +++ b/defaults.h @@ -41,14 +41,16 @@ #if USE_BOEHM #include "gc/include/gc.h" -#define SEXP_ALLOC GC_malloc -#define SEXP_ALLOC_ATOMIC GC_malloc_atomic -#define SEXP_REALLOC GC_realloc -#define SEXP_FREE GC_free +#define sexp_alloc GC_malloc +#define sexp_alloc_atomic GC_malloc_atomic +#define sexp_realloc GC_realloc +#define sexp_free(x) +#define sexp_deep_free(x) #else -#define SEXP_ALLOC malloc -#define SEXP_ALLOC_ATOMIC SEXP_ALLOC -#define SEXP_REALLOC realloc -#define SEXP_FREE free +#define sexp_alloc malloc +#define sexp_alloc_atomic sexp_alloc +#define sexp_realloc realloc +#define sexp_free free +void sexp_deep_free(sexp obj); #endif diff --git a/eval.c b/eval.c index 9da6bb0e..5b167112 100644 --- a/eval.c +++ b/eval.c @@ -65,8 +65,7 @@ static void env_define(sexp e, sexp key, sexp value) { static sexp extend_env (sexp e, sexp fv, int offset) { int i; - sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env)); - e2->tag = SEXP_ENV; + sexp e2 = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e2) = e; sexp_env_bindings(e2) = SEXP_NULL; for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--) @@ -98,11 +97,10 @@ static sexp sexp_flatten_dot (sexp ls) { static void shrink_bcode(sexp *bc, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(*bc) != i) { - tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + i); - tmp->tag = SEXP_BYTECODE; + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i); - SEXP_FREE(*bc); + sexp_free(*bc); *bc = tmp; } } @@ -110,14 +108,14 @@ static void shrink_bcode(sexp *bc, sexp_uint_t i) { static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(*bc) < (*i)+size) { - tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) - + sexp_bytecode_length(*bc)*2); - tmp->tag = SEXP_BYTECODE; + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + + sexp_bytecode_length(*bc)*2, + SEXP_BYTECODE); sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2; memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), sexp_bytecode_length(*bc)); - SEXP_FREE(*bc); + sexp_free(*bc); *bc = tmp; } } @@ -140,8 +138,7 @@ static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) { static sexp sexp_make_procedure(sexp flags, sexp num_args, sexp bc, sexp vars) { - sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure)); - proc->tag = SEXP_PROCEDURE; + sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE); sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; sexp_procedure_code(proc) = bc; @@ -150,8 +147,7 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args, } static sexp sexp_make_macro (sexp p, sexp e) { - sexp mac = (sexp) SEXP_ALLOC(sexp_sizeof(macro)); - mac->tag = SEXP_MACRO; + sexp mac = sexp_alloc_type(macro, SEXP_MACRO); sexp_macro_env(mac) = e; sexp_macro_proc(mac) = p; return mac; @@ -166,13 +162,12 @@ sexp sexp_compile_error(char *message, sexp irritants) { } sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { - sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); sexp_uint_t i=0; /* fprintf(stderr, "expanding: "); */ /* sexp_write(form, cur_error_port); */ /* fprintf(stderr, "\n => "); */ - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); sexp_bytecode_length(bc) = 32; emit_push(&bc, &i, sexp_macro_env(mac)); emit_push(&bc, &i, e); @@ -184,11 +179,85 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { res = vm(bc, e, stack, 0); sexp_write(res, cur_error_port); /* fprintf(stderr, "\n"); */ - SEXP_FREE(bc); - SEXP_FREE(stack); + sexp_free(bc); + sexp_free(stack); return res; } +/* sexp analyze(sexp x, sexp env) { */ +/* sexp op, cell; */ +/* loop: */ +/* if (sexp_pairp(x)) { */ +/* if (sexp_idp(sexp_car(x))) { */ +/* cell = env_cell(sexp_car(x), env); */ +/* if (! cell) return analyze_app(x, env); */ +/* op = sexp_cdr(cell); */ +/* if (sexp_corep(op)) { */ +/* switch (sexp_core_code(op)) { */ +/* case CORE_DEFINE: */ +/* if (sexp_env_global_p(env)) */ +/* return sexp_make_set(sexp_make_global_ref(sexp_cadr(x), env), */ +/* analyze(sexp_caddr(x), env)); */ +/* else */ +/* return sexp_compile_error("bad define location", sexp_list1(x)); */ +/* case CORE_SET: */ +/* return sexp_make_set(sexp_make_ref(sexp_cadr(x), env), */ +/* analyze(sexp_caddr(x), env)); */ +/* case CORE_LAMBDA: */ +/* return analyze_lambda(x, env); */ +/* case CORE_IF: */ +/* return sexp_make_cnd(analyze(sexp_car(x), env), */ +/* analyze(sexp_cadr(x), env), */ +/* (sexp_pairp(sexp_cddr(x)) */ +/* ? analyze(sexp_caddr(x), env) : SEXP_UNDEF)); */ +/* case CORE_BEGIN: */ +/* return sexp_make_seq(analyze_app(x, env)); */ +/* case CORE_QUOTE: */ +/* return sexp_make_lit(x); */ +/* default: */ +/* return sexp_compile_error("unknown core form", sexp_list1(op)); */ +/* } */ +/* } else if (sexp_macrop(op)) { */ +/* x = sexp_expand_macro(op, x, env); */ +/* goto loop; */ +/* } else { */ +/* return analyze_app(x, env); */ +/* } */ +/* } else { */ +/* return analyze_app(x, env); */ +/* } */ +/* } else if (sexp_symbolp(x)) { */ +/* return analyze_var_ref(x, env); */ +/* } else if (sexp_synclop(x)) { */ +/* env = sexp_synclo_env(x); */ +/* x = sexp_synclo_expr(x); */ +/* goto loop; */ +/* } else { */ +/* return x; */ +/* } */ +/* } */ + +/* sexp analyze_lambda(sexp x, sexp env) { */ +/* } */ + +/* sexp analyze_app(sexp x, sexp env) { */ +/* sexp res=SEXP_NULL; */ +/* for ( ; sexp_pairp(x); x=sexp_cdr(x)) */ +/* res = sexp_cons(analyze(sexp_car(x), env), res); */ +/* return sexp_nreverse(res); */ +/* } */ + +/* sexp compile(sexp x, sexp res) { */ +/* if (sexp_pairp(x)) */ +/* else if (sexp_lambdap(x)) */ +/* else if (sexp_seqp(x)) */ +/* else if (sexp_cndp(x)) */ +/* else if (sexp_refp(x)) */ +/* else if (sexp_setp(x)) */ +/* else if (sexp_litp(x)) */ +/* else */ +/* } */ + sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2; @@ -591,10 +660,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { sexp_uint_t pos=0, d=0; if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); params = make_param_list(i); e = extend_env(e, params, -4); - bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, SEXP_NULL, SEXP_NULL, &d, 0); @@ -609,9 +677,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_uint_t i=0, j=0, d=0, define_ok=1, core; - sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); + sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, + SEXP_BYTECODE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; - bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; /* box mutable vars */ for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { @@ -1119,7 +1187,7 @@ sexp sexp_close_port (sexp port) { } sexp sexp_load (sexp source) { - sexp obj, res, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + sexp obj, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); int closep = 0; if (sexp_stringp(source)) { source = sexp_open_input_file(source); @@ -1132,7 +1200,7 @@ sexp sexp_load (sexp source) { res = SEXP_UNDEF; done: if (closep) sexp_close_port(source); - SEXP_FREE(stack); + sexp_free(stack); return res; } @@ -1225,8 +1293,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), sexp make_standard_env() { sexp_uint_t i; - sexp e = (sexp) SEXP_ALLOC(sexp_sizeof(env)); - e->tag = SEXP_ENV; + sexp e = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e) = NULL; sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -1245,9 +1312,9 @@ sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) { } sexp eval(sexp obj, sexp e) { - sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + sexp* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); sexp res = eval_in_stack(obj, e, stack, 0); - SEXP_FREE(stack); + sexp_free(stack); return res; } @@ -1261,8 +1328,7 @@ void scheme_init() { cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); the_compile_error_symbol = sexp_intern("compile-error"); - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); sexp_bytecode_length(bc) = 16; emit(&bc, &i, OP_RESUMECC); continuation_resumer = (sexp) bc; @@ -1290,11 +1356,10 @@ int main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); - stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); e = make_standard_env(); interaction_environment = e; - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); sexp_bytecode_length(bc) = 16; i = 0; emit_push(&bc, &i, SEXP_UNDEF); diff --git a/sexp.c b/sexp.c index ba515524..d01b2d50 100644 --- a/sexp.c +++ b/sexp.c @@ -51,38 +51,47 @@ static unsigned long symbol_table_primes[] = { static int symbol_table_prime_index = 0; static int symbol_table_count = 0; -void sexp_free (sexp obj) { +sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { + sexp res = (sexp) sexp_alloc(size); + if (! res) + errx(EX_OSERR, "out of memory: couldn't allocate %d bytes for %d", + size ,tag); + res->tag = tag; + return res; +} + +#if ! USE_BOEHM +void sexp_deep_free (sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { switch (obj->tag) { case SEXP_PAIR: - sexp_free(sexp_car(obj)); - sexp_free(sexp_cdr(obj)); + sexp_deep_free(sexp_car(obj)); + sexp_deep_free(sexp_cdr(obj)); break; case SEXP_VECTOR: len = sexp_vector_length(obj); elts = sexp_vector_data(obj); - for (i=0; itag = SEXP_EXCEPTION; + sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION); sexp_exception_kind(exn) = kind; sexp_exception_message(exn) = message; sexp_exception_irritants(exn) = irritants; @@ -133,8 +142,7 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) { /*************************** list utilities ***************************/ sexp sexp_cons(sexp head, sexp tail) { - sexp pair = SEXP_ALLOC(sexp_sizeof(pair)); - pair->tag = SEXP_PAIR; + sexp pair = sexp_alloc_type(pair, SEXP_PAIR); sexp_car(pair) = head; sexp_cdr(pair) = tail; return pair; @@ -224,18 +232,16 @@ sexp sexp_length(sexp ls) { /********************* strings, symbols, vectors **********************/ sexp sexp_make_flonum(double f) { - sexp x = SEXP_ALLOC(sexp_sizeof(flonum)); - x->tag = SEXP_FLONUM; + sexp x = sexp_alloc_type(flonum, SEXP_FLONUM); sexp_flonum_value(x) = f; return x; } sexp sexp_make_string(char *str) { - sexp s = SEXP_ALLOC(sexp_sizeof(string)); + sexp s = sexp_alloc_type(string, SEXP_STRING); sexp_uint_t len = strlen(str); - char *mystr = SEXP_ALLOC(len+1); + char *mystr = sexp_alloc(len+1); memcpy(mystr, str, len+1); - s->tag = SEXP_STRING; sexp_string_length(s) = len; sexp_string_data(s) = mystr; return s; @@ -287,19 +293,18 @@ sexp sexp_intern(char *str) { if (symbol_table_count*5 > d*4) { fprintf(stderr, "resizing symbol table!!!!!\n"); - newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++] + newtable = sexp_alloc(symbol_table_primes[symbol_table_prime_index++] * sizeof(sexp)); /* XXXX rehash */ - SEXP_FREE(symbol_table); + sexp_free(symbol_table); symbol_table = newtable; } - sym = SEXP_ALLOC(sexp_sizeof(symbol)); + sym = sexp_alloc_type(symbol, SEXP_SYMBOL); len = strlen(str); - mystr = SEXP_ALLOC(len+1); + mystr = sexp_alloc(len+1); memcpy(mystr, str, len+1); mystr[len]=0; - sym->tag = SEXP_SYMBOL; sexp_symbol_length(sym) = len; sexp_symbol_data(sym) = mystr; symbol_table[cell] = sym; @@ -310,12 +315,11 @@ sexp sexp_make_vector(sexp len, sexp dflt) { sexp v, *x; int i, clen = sexp_unbox_integer(len); if (! clen) return the_empty_vector; - v = SEXP_ALLOC(sexp_sizeof(vector)); - x = (sexp*) SEXP_ALLOC(clen*sizeof(sexp)); + v = sexp_alloc_type(vector, SEXP_VECTOR); + x = (sexp*) sexp_alloc(clen*sizeof(sexp)); for (i=0; itag = SEXP_VECTOR; sexp_vector_length(v) = clen; sexp_vector_data(v) = x; return v; @@ -375,7 +379,7 @@ off_t sstream_seek(void *vec, off_t offset, int whence) { } int sstream_close(void *vec) { - sexp_free((sexp)vec); + sexp_deep_free((sexp)vec); return 0; } @@ -395,16 +399,14 @@ sexp sexp_get_output_string(sexp port) { #endif sexp sexp_make_input_port(FILE* in) { - sexp p = SEXP_ALLOC(sexp_sizeof(port)); - p->tag = SEXP_IPORT; + sexp p = sexp_alloc_type(port, SEXP_IPORT); sexp_port_stream(p) = in; sexp_port_line(p) = 0; return p; } sexp sexp_make_output_port(FILE* out) { - sexp p = SEXP_ALLOC(sexp_sizeof(port)); - p->tag = SEXP_OPORT; + sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; sexp_port_line(p) = 0; return p; @@ -419,7 +421,7 @@ void sexp_write (sexp obj, sexp out) { if (! obj) { sexp_write_string("#", out); } else if (sexp_pointerp(obj)) { - switch (obj->tag) { + switch (sexp_tag(obj)) { case SEXP_PAIR: sexp_write_char('(', out); sexp_write(sexp_car(obj), out); @@ -474,7 +476,7 @@ void sexp_write (sexp obj, sexp out) { str = sexp_string_data(obj); /* ... FALLTHROUGH ... */ case SEXP_SYMBOL: - if (obj->tag != SEXP_STRING) { + if (! sexp_stringp(obj)) { i = sexp_symbol_length(obj); str = sexp_symbol_data(obj); } @@ -483,7 +485,7 @@ void sexp_write (sexp obj, sexp out) { sexp_write_char('\\', out); sexp_write_char(str[0], out); } - if (obj->tag == SEXP_STRING) + if (sexp_stringp(obj)) sexp_write_char('"', out); break; } @@ -530,12 +532,12 @@ char* sexp_read_string(sexp in) { char *buf, *tmp, *res; int c, len, size=128; - buf = SEXP_ALLOC(size); /* XXXX grow! */ + buf = sexp_alloc(size); /* XXXX grow! */ tmp = buf; for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { if (c == EOF) { - SEXP_FREE(buf); + sexp_free(buf); return NULL; } else if (c == '\\') { c=sexp_read_char(in); @@ -551,9 +553,9 @@ char* sexp_read_string(sexp in) { *tmp++ = '\0'; len = tmp - buf; - res = SEXP_ALLOC(len); + res = sexp_alloc(len); memcpy(res, buf, len); - SEXP_FREE(buf); + sexp_free(buf); return res; } @@ -561,7 +563,7 @@ char* sexp_read_symbol(sexp in, int init) { char *buf, *tmp, *res; int c, len, size=128; - buf = SEXP_ALLOC(size); + buf = sexp_alloc(size); tmp = buf; if (init != EOF) @@ -578,9 +580,9 @@ char* sexp_read_symbol(sexp in, int init) { *tmp++ = '\0'; len = tmp - buf; - res = SEXP_ALLOC(len); + res = sexp_alloc(len); memcpy(res, buf, len); - SEXP_FREE(buf); + sexp_free(buf); return res; } @@ -666,7 +668,7 @@ sexp sexp_read_raw (sexp in) { case '"': str = sexp_read_string(in); res = sexp_make_string(str); - SEXP_FREE(str); + sexp_free(str); break; case '(': res = SEXP_NULL; @@ -679,7 +681,7 @@ sexp sexp_read_raw (sexp in) { } else { tmp = sexp_read_raw(in); if (sexp_read_raw(in) != SEXP_CLOSE) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("multiple tokens in dotted tail", SEXP_NULL, in); } else { @@ -695,7 +697,7 @@ sexp sexp_read_raw (sexp in) { } } if (tmp != SEXP_CLOSE) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("missing trailing ')'", SEXP_NULL, in); } res = (sexp_pairp(res) ? sexp_nreverse(res) : res); @@ -759,7 +761,7 @@ sexp sexp_read_raw (sexp in) { res = sexp_read(in); if (! sexp_listp(res)) { if (! sexp_exceptionp(res)) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("dotted list not allowed in vector syntax", SEXP_NULL, in); @@ -784,7 +786,7 @@ sexp sexp_read_raw (sexp in) { sexp_push_char(c1, in); str = sexp_read_symbol(in, '.'); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); } break; case ')': @@ -802,7 +804,7 @@ sexp sexp_read_raw (sexp in) { sexp_push_char(c2, in); str = sexp_read_symbol(in, c1); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); } break; case '0': case '1': case '2': case '3': case '4': @@ -813,7 +815,7 @@ sexp sexp_read_raw (sexp in) { default: str = sexp_read_symbol(in, c1); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); break; } return res; @@ -832,8 +834,8 @@ sexp sexp_read_from_string(char *str) { sexp s = sexp_make_string(str); sexp in = sexp_make_input_string_port(s); sexp res = sexp_read(in); - sexp_free(s); - sexp_free(in); + sexp_deep_free(s); + sexp_deep_free(in); return res; } @@ -843,15 +845,14 @@ void sexp_init() { #if USE_BOEHM GC_init(); #endif - symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); + symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp)); the_dot_symbol = sexp_intern("."); the_quote_symbol = sexp_intern("quote"); the_quasiquote_symbol = sexp_intern("quasiquote"); the_unquote_symbol = sexp_intern("unquote"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); the_read_error_symbol = sexp_intern("read-error"); - the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector)); - the_empty_vector->tag = SEXP_VECTOR; + the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR); sexp_vector_length(the_empty_vector) = 0; sexp_vector_data(the_empty_vector) = NULL; } diff --git a/sexp.h b/sexp.h index ba1afd88..9bc01269 100644 --- a/sexp.h +++ b/sexp.h @@ -10,6 +10,7 @@ #include #include #include +#include #include "config.h" #include "defaults.h" @@ -17,7 +18,7 @@ /* tagging system * bits end in 00: pointer * 01: fixnum - * 011: symbol + * 011: * 111: immediate symbol * 0110: char * 1110: other immediate object (NULL, TRUE, FALSE) @@ -54,10 +55,17 @@ enum sexp_types { /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_MACRO, + SEXP_SYNCLO, SEXP_ENV, SEXP_BYTECODE, SEXP_CORE, SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, }; typedef unsigned long sexp_uint_t; @@ -68,6 +76,7 @@ typedef struct sexp_struct *sexp; struct sexp_struct { sexp_tag_t tag; union { + /* basic types */ double flonum; struct { sexp car, cdr; @@ -92,6 +101,7 @@ struct sexp_struct { struct { sexp kind, message, irritants, file, line; } exception; + /* runtime types */ struct { char flags; sexp parent, bindings; @@ -110,7 +120,7 @@ struct sexp_struct { } macro; struct { sexp env, free_vars, expr; - } sc; + } synclo; struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; @@ -121,13 +131,37 @@ struct sexp_struct { char code; char *name; } core; + /* ast types */ + struct { + sexp name, params, flags, body, fv, sv; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp var, value; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp x; + } lit; } value; }; -#define sexp_sizeof_field(field) (sizeof((sexp)NULL)->value.field) -#define sexp_sizeof(field) (sizeof(struct sexp_struct)-sexp_sizeof_field(exception)+sexp_sizeof_field(field)) +/* #define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) */ -#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag == (t)) +#define sexp_tag(x) ((x)->tag) -#define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) -#define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) -#define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) -#define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) -#define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) -#define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) -#define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) -#define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) -#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) -#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) -#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) -#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) -#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) -#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_tag(x) == (t))) + +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) @@ -293,6 +329,7 @@ void sexp_printf(sexp port, sexp fmt, ...); #define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) +sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); @@ -311,7 +348,6 @@ sexp sexp_make_vector(sexp len, sexp dflt); sexp sexp_list_to_vector(sexp ls); sexp sexp_vector(int count, ...); void sexp_write(sexp obj, sexp out); -void sexp_free(sexp obj); char* sexp_read_string(sexp in); char* sexp_read_symbol(sexp in, int init); sexp sexp_read_number(sexp in, int base);