diff --git a/debug.c b/debug.c index f39ba635..cd329db9 100644 --- a/debug.c +++ b/debug.c @@ -20,7 +20,7 @@ static const char* reverse_opcode_names[] = "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -static sexp sexp_disasm (sexp bc, sexp out) { +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { unsigned char *ip, opcode; if (sexp_procedurep(bc)) bc = sexp_procedure_code(bc); diff --git a/eval.c b/eval.c index ba4aa3d8..d9e8ac88 100644 --- a/eval.c +++ b/eval.c @@ -251,7 +251,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + stack = sexp_alloc_tagged(ctx, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } @@ -451,7 +451,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, defs, s_defs); - /* verify syntax */ + /* verify syntax - XXXX release! */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error(ctx, "bad lambda syntax", x); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -462,25 +462,19 @@ static sexp analyze_lambda (sexp ctx, sexp x) { /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); ctx = sexp_make_child_context(ctx, res); - sexp_context_env(ctx) - = extend_env(ctx, - sexp_context_env(ctx), - sexp_flatten_dot(ctx, sexp_lambda_params(res)), - res); + tmp = sexp_flatten_dot(ctx, sexp_lambda_params(res)); + sexp_context_env(ctx) = extend_env(ctx, sexp_context_env(ctx), tmp, res); sexp_env_lambda(sexp_context_env(ctx)) = res; body = analyze_seq(ctx, sexp_cddr(x)); analyze_check_exception(body); /* delayed analyze internal defines */ + defs = SEXP_NULL; for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - value = analyze_lambda(ctx, - sexp_cons(ctx, - SEXP_VOID, - sexp_cons(ctx, - sexp_cdadr(tmp), - sexp_cddr(tmp)))); + tmp = sexp_cons(ctx, sexp_cdadr(tmp), sexp_cddr(tmp)); + value = analyze_lambda(ctx, sexp_cons(ctx, SEXP_VOID, tmp)); } else { name = sexp_cadr(tmp); value = analyze(ctx, sexp_caddr(tmp)); @@ -1709,6 +1703,7 @@ sexp vm (sexp proc, sexp ctx) { end_loop: sexp_gc_release(ctx, self, s_self); + sexp_context_top(ctx) = top; return _ARG1; } @@ -1767,26 +1762,28 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve(ctx, x, s_x); sexp_gc_preserve(ctx, in, s_in); ctx2 = sexp_make_context(ctx, NULL, env); + sexp_context_parent(ctx2) = ctx; out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { sexp_print_exception(ctx, in, out); - return in; - } - while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { - res = eval_in_context(ctx2, x); - if (sexp_exceptionp(res)) - break; - } - if (x == SEXP_EOF) - res = SEXP_VOID; - sexp_close_port(ctx, in); + res = in; + } else { + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = eval_in_context(ctx2, x); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); #if USE_WARN_UNDEFS - if (sexp_oportp(out)) - sexp_warn_undefs(sexp_env_bindings(env), tmp, out); + if (sexp_oportp(out)) + sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif + } sexp_gc_release(ctx, ctx2, s_ctx2); return res; } @@ -1957,10 +1954,10 @@ sexp apply (sexp ctx, sexp proc, sexp args) { stack[--offset] = sexp_car(ls); stack[top] = sexp_make_integer(top); top++; + sexp_context_top(ctx) = top + 3; stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - sexp_context_top(ctx) = top; return vm(proc, ctx); } diff --git a/gc.c b/gc.c index e4ad82f0..4e5b8c48 100644 --- a/gc.c +++ b/gc.c @@ -13,11 +13,13 @@ static char* sexp_heap; static char* sexp_heap_end; static sexp sexp_free_list; -sexp_uint_t sexp_allocated_bytes (sexp x) { +static sexp* stack_base; + +sexp_uint_t sexp_allocated_bytes0 (sexp x) { switch (sexp_pointer_tag(x)) { case SEXP_PAIR: return sexp_sizeof(pair); case SEXP_SYMBOL: return sexp_sizeof(symbol); - case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); + case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x)+1; case SEXP_VECTOR: return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); case SEXP_STACK: @@ -45,6 +47,21 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { } } +sexp_uint_t sexp_allocated_bytes (sexp x) { + sexp_uint_t res, *len_ptr; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) + return sexp_align(1, 4); + t = &(sexp_types[sexp_pointer_tag(x)]); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); + res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); + if (res != sexp_allocated_bytes0(x)) { + fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res); + /* exit(1); */ + } + return res; +} + void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; @@ -433,8 +450,20 @@ void sexp_show_free_list (sexp ctx) { putc('\n', stderr); } -sexp sexp_sweep (sexp ctx) { - sexp_uint_t freed=0, size; +void validate_free_list (sexp ctx) { + sexp p=sexp_free_list, prev=NULL; + while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { + if (((char*)p < sexp_heap) || ((char*)p >= sexp_heap_end)) + fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev); + if (p < prev) + fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p)); + prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); + p = sexp_cdr(p); + } +} + +void validate_heap (sexp ctx) { + sexp_uint_t size; sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); sexp q=sexp_free_list, r; /* scan over the whole heap */ @@ -448,53 +477,128 @@ sexp sexp_sweep (sexp ctx) { continue; } size = sexp_align(sexp_allocated_bytes(p), 4); + if (sexp_pointer_tag(p) == 0) { + fprintf(stderr, "bare object found at %p\n", p); + } else if (sexp_pointer_tag(p) == 0) { + fprintf(stderr, "type object found at %p\n", p); + } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { + fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); + } + p = (sexp) (((char*)p)+size); + } +} + +void validate_gc_vars (sexp ctx) { + struct sexp_gc_var_t *saves, *prev=NULL; + if (! ctx) + return; + for (saves=sexp_context_saves(ctx); saves; saves=saves->next) { +/* if (saves->var) { */ +/* if (((char*)*(saves->var) < sexp_heap) */ +/* || ((char*)*(saves->var) >= sexp_heap_end)) */ +/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */ +/* } */ + if (prev && (prev > saves)) { + fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves); + return; + } else if (prev == saves) { + fprintf(stderr, "loop in gc vars at %p\n", saves); + return; + } + prev = saves; + } +} + +void validate_freed_pointer (sexp x, sexp *start) { + sexp *p; + for (p=start; p max_freed) + max_freed = freed; } else { /* fprintf(stderr, "\x1B[32msaving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ /* simple_write(p, 1, stderr); */ /* fprintf(stderr, "\x1B[0m\n"); */ sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); } - p = (sexp) (((char*)p)+size); } -/* fprintf(stderr, "**************** freed %ld bytes ****************\n", freed); */ - return sexp_make_integer(freed); + fprintf(stderr, "**************** freed %ld bytes, max %ld ****************\n", sum_freed, max_freed); + return sexp_make_integer(max_freed); } extern sexp continuation_resumer, final_resumer; sexp sexp_gc (sexp ctx) { int i; - /* fprintf(stderr, "************* garbage collecting *************\n"); */ + fprintf(stderr, "************* garbage collecting *************\n"); /* sexp_show_free_list(ctx); */ sexp_mark(continuation_resumer); sexp_mark(final_resumer); @@ -507,7 +611,6 @@ sexp sexp_gc (sexp ctx) { void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) { sexp p=(sexp)(start+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); sexp q=(sexp)(((char*)sexp_free_list)+offset), r; - /* fprintf(stderr, "************* adjusting heap *************\n"); */ while (((char*)p) < end) { /* find the preceding and succeeding free list pointers */ for (r=sexp_cdr(q); r && sexp_pairp(r) && (r size) ? cur_size : size) * 2, 4); - /* fprintf(stderr, "************* growing heap *************\n"); */ + fprintf(stderr, "************* growing heap *************\n"); + validate_heap(ctx); if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) { fprintf(stderr, "************* heap too large *************\n"); return 0; @@ -547,6 +651,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { return 0; } if (tmp1 != sexp_heap) { + fprintf(stderr, "************* adjusting heap pointers *************\n"); sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); tmp2 = sexp_heap; sexp_heap = tmp1; @@ -592,6 +697,9 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; + validate_heap(ctx); + validate_free_list(ctx); + validate_gc_vars(ctx); size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { @@ -606,6 +714,7 @@ void* sexp_alloc (sexp ctx, size_t size) { exit(70); } } + /* fprintf(stderr, "sexp_alloc %lu => %p\n", size, res); */ return res; } @@ -622,6 +731,7 @@ void sexp_gc_init () { sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; - /* fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); */ + stack_base = &next; + fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); } diff --git a/main.c b/main.c index 830e89f7..a9d12e04 100644 --- a/main.c +++ b/main.c @@ -18,6 +18,7 @@ void repl (sexp ctx) { sexp_print_exception(ctx, obj, err); } else { tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; res = eval_in_context(ctx, obj); #if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); diff --git a/sexp.c b/sexp.c index 04745ee1..8f7c2f24 100644 --- a/sexp.c +++ b/sexp.c @@ -56,6 +56,38 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } +static struct sexp_struct sexp_types[] = { + {.tag=SEXP_TYPE, .value={.type={SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_PAIR, 0, 0, 0, 0, sexp_sizeof(pair), 0, 0, "pair"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SYMBOL, 0, 0, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, offsetof(struct sexp_struct, value.string.length), 1, "string"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_VECTOR, 0, 0, 0, 0, sexp_sizeof(vector), offsetof(struct sexp_struct, value.vector.length), 4, "vector"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), offsetof(struct sexp_struct, value.bignum.length), 4, "bignum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_IPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "input-port"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_OPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "output-port"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_EXCEPTION, 0, 0, 0, 0, sexp_sizeof(exception), 0, 0, "exception"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_PROCEDURE, 0, 0, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_MACRO, 0, 0, 0, 0, sexp_sizeof(macro), 0, 0, "macro"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SYNCLO, 0, 0, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_ENV, 0, 0, 0, 0, sexp_sizeof(env), 0, 0, "environment"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BYTECODE, 0, 0, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_OPCODE, 0, 0, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_LAMBDA, 0, 0, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CND, 0, 0, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_REF, 0, 0, 0, 0, sexp_sizeof(ref), 0, 0, "reference"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SET, 0, 0, 0, 0, sexp_sizeof(set), 0, 0, "set!"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SEQ, 0, 0, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_LIT, 0, 0, 0, 0, sexp_sizeof(lit), 0, 0, "literal"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_STACK, 0, 0, 0, 0, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CONTEXT, 0, 0, 0, 0, sexp_sizeof(context), 0, 0, "context"}}}, +}; + #if ! USE_BOEHM #if USE_MALLOC void sexp_deep_free (sexp ctx, sexp obj) { @@ -183,12 +215,19 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { } static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { - sexp name = (sexp_port_name(port) - ? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE); - return sexp_make_exception(ctx, the_read_error_symbol, - sexp_c_string(ctx, msg, -1), - irritants, SEXP_FALSE, name, - sexp_make_integer(sexp_port_line(port))); + sexp res; + sexp_gc_var(ctx, name, s_name); + sexp_gc_var(ctx, str, s_str); + sexp_gc_preserve(ctx, name, s_name); + sexp_gc_preserve(ctx, str, s_str); + name = (sexp_port_name(port) + ? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE); + str = sexp_c_string(ctx, msg, -1); + res = sexp_make_exception(ctx, the_read_error_symbol, + str, irritants, SEXP_FALSE, name, + sexp_make_integer(sexp_port_line(port))); + sexp_gc_release(ctx, name, s_name); + return res; } /*************************** list utilities ***************************/ @@ -390,7 +429,8 @@ sexp sexp_intern(sexp ctx, char *str) { struct huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; char c, *p=str; - sexp sym, ls; + sexp ls; + sexp_gc_var(ctx, sym, s_sym); #if USE_HUFF_SYMS res = 0; @@ -418,9 +458,11 @@ sexp sexp_intern(sexp ctx, char *str) { return sexp_car(ls); /* not found, make a new symbol */ + sexp_gc_preserve(ctx, sym, s_sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_push(ctx, sexp_symbol_table[bucket], sym); + sexp_gc_release(ctx, sym, s_sym); return sym; } @@ -519,24 +561,30 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in; - sexp res, cookie; + sexp res; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)), sexp_make_integer(0)); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, NULL); sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); return res; } sexp sexp_make_output_string_port (sexp ctx) { FILE *out; - sexp res, size, cookie; + sexp res, size; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, NULL); sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); return res; } @@ -697,6 +745,11 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string(">", out); break; #endif + case SEXP_TYPE: + sexp_write_string("#", out); + break; case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); @@ -1015,8 +1068,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { /* case '0': case '1': case '2': case '3': case '4': */ /* case '5': case '6': case '7': case '8': case '9': */ case ';': - sexp_read_raw(ctx, in); /* discard */ - goto scan_loop; + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; case '\\': c1 = sexp_read_char(in); res = sexp_read_symbol(ctx, in, c1, 0); diff --git a/sexp.h b/sexp.h index 6d4b8789..65823529 100644 --- a/sexp.h +++ b/sexp.h @@ -52,6 +52,7 @@ enum sexp_types { SEXP_OBJECT, + SEXP_TYPE, SEXP_FIXNUM, SEXP_CHAR, SEXP_BOOLEAN, @@ -84,7 +85,7 @@ enum sexp_types { typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; -typedef char sexp_tag_t; +typedef unsigned char sexp_tag_t; typedef struct sexp_struct *sexp; struct sexp_gc_var_t { @@ -99,6 +100,12 @@ struct sexp_struct { union { /* basic types */ double flonum; + struct { + sexp_tag_t tag; + sexp_sint_t field_base, field_len_base, field_len_off, field_len_scale; + sexp_sint_t size_base, size_off, size_scale; + char *name; + } type; struct { sexp car, cdr; } pair; @@ -183,9 +190,9 @@ struct sexp_struct { sexp data[]; } stack; struct { - sexp bc, lambda, stack, env, fv, parent; struct sexp_gc_var_t *saves; sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent; } context; } value; }; @@ -218,29 +225,18 @@ struct sexp_struct { #else #define sexp_gc_var(ctx, x, y) \ - sexp x = SEXP_FALSE; \ - struct sexp_gc_var_t y = {0, 0}; + sexp x = SEXP_VOID; \ + struct sexp_gc_var_t y = {NULL, NULL}; + +#define sexp_gc_preserve(ctx, x, y) \ + do { \ + (y).var = &(x); \ + (y).next = sexp_context_saves(ctx); \ + sexp_context_saves(ctx) = &(y); \ + } while (0) -#define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \ - (y).next = sexp_context_saves(ctx), \ - sexp_context_saves(ctx) = &(y)) #define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next) -#define sexp_with_gc_var1(ctx, x, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); - -#define sexp_with_gc_var2(ctx, x, y, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_var(ctx, y, _sexp_gcv2); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, y, _sexp_gcv2); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); \ - sexp_gc_release(ctx, y, _sexp_gcv2); - #if USE_MALLOC #define sexp_alloc(ctx, size) malloc(size) #define sexp_alloc_atomic(ctx, size) malloc(size) @@ -258,6 +254,21 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #endif +#define sexp_with_gc_var1(ctx, x, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); + +#define sexp_with_gc_var2(ctx, x, y, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_var(ctx, y, _sexp_gcv2); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, y, _sexp_gcv2); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); \ + sexp_gc_release(ctx, y, _sexp_gcv2); + #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ @@ -279,6 +290,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) #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)) @@ -438,6 +450,16 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) + /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))