cleanup, removing mid-function returns which could corrupt

the gc_var trace.

Makefile

@@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme
 LDFLAGS=-lm
 
 # -Oz for smaller size on darwin
-CFLAGS=-Wall -g -save-temps
+CFLAGS=-Wall -O2 -g -save-temps
 
 ./gc/gc.a: ./gc/alloc.c
 	cd gc && make

eval.c

@@ -246,12 +246,14 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
   return res;
 }
 
+#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE)
+
 static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
   sexp_gc_var(ctx, res, save_res);
   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, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK);
+    stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
     sexp_stack_length(stack) = INIT_STACK_SIZE;
     sexp_stack_top(stack) = 0;
   }
@@ -354,14 +356,6 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
   return exn;
 }
 
-#define analyze_check_exception(x) do {if (sexp_exceptionp(x))          \
-                                         return (x);                    \
-                                      } while (0)
-
-#define analyze_bind(var, x, ctx) do {(var) = analyze(ctx, x);      \
-                                      analyze_check_exception(var); \
-                                     } while (0)
-
 static sexp analyze_app (sexp ctx, sexp x) {
   sexp_gc_var(ctx, res, s_res);
   sexp_gc_var(ctx, tmp, s_tmp);
@@ -429,20 +423,27 @@ static sexp analyze_set (sexp ctx, sexp x) {
   sexp_gc_var(ctx, value, s_value);
   sexp_gc_preserve(ctx, ref, s_ref);
   sexp_gc_preserve(ctx, value, s_value);
-  ref = analyze_var_ref(ctx, sexp_cadr(x));
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))
-  if (sexp_lambdap(sexp_ref_loc(ref)))
+         && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) {
-    sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
+    res = sexp_compile_error(ctx, "bad set! syntax", x);
-  value = analyze(ctx, sexp_caddr(x));
+  } else {
-  if (sexp_exceptionp(ref))
+    ref = analyze_var_ref(ctx, sexp_cadr(x));
-    res = ref;
+    if (sexp_lambdap(sexp_ref_loc(ref)))
-  else if (sexp_exceptionp(value))
+      sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
-    res = value;
+    value = analyze(ctx, sexp_caddr(x));
-  else
+    if (sexp_exceptionp(ref))
-    res = sexp_make_set(ctx, ref, value);
+      res = ref;
+    else if (sexp_exceptionp(value))
+      res = value;
+    else
+      res = sexp_make_set(ctx, ref, value);
+  }
   sexp_gc_release(ctx, ref, s_ref);
   return res;
 }
 
+#define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
+
 static sexp analyze_lambda (sexp ctx, sexp x) {
   sexp name, ls;
   sexp_gc_var(ctx, res, s_res);
@@ -457,14 +458,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
   sexp_gc_preserve(ctx, value, s_value);
   sexp_gc_preserve(ctx, defs, s_defs);
   sexp_gc_preserve(ctx, ctx2, s_ctx2);
-  /* verify syntax - XXXX release! */
+  /* verify syntax */
   if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
-    return sexp_compile_error(ctx, "bad lambda syntax", x);
+    sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x));
   for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
     if (! sexp_idp(sexp_car(ls)))
-      return sexp_compile_error(ctx, "non-symbol parameter", x);
+      sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x));
     else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
-      return sexp_compile_error(ctx, "duplicate parameter", x);
+      sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x));
   /* build lambda and analyze body */
   res = sexp_make_lambda(ctx, sexp_cadr(x));
   ctx2 = sexp_make_child_context(ctx, res);
@@ -472,7 +473,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
   sexp_context_env(ctx2) = extend_env(ctx2, sexp_context_env(ctx2), tmp, res);
   sexp_env_lambda(sexp_context_env(ctx2)) = res;
   body = analyze_seq(ctx2, sexp_cddr(x));
-  analyze_check_exception(body);
+  if (sexp_exceptionp(body)) sexp_return(res, body);
   /* delayed analyze internal defines */
   defs = SEXP_NULL;
   for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
@@ -485,7 +486,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
       name = sexp_cadr(tmp);
       value = analyze(ctx2, sexp_caddr(tmp));
     }
-    analyze_check_exception(value);
+    if (sexp_exceptionp(value)) sexp_return(res, value);
     sexp_push(ctx2, defs,
               sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value));
   }
@@ -498,6 +499,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
     sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body));
   }
   sexp_lambda_body(res) = body;
+ cleanup:
   sexp_gc_release(ctx, res, s_res);
   return res;
 }
@@ -510,11 +512,16 @@ static sexp analyze_if (sexp ctx, sexp x) {
   sexp_gc_preserve(ctx, test, s_test);
   sexp_gc_preserve(ctx, pass, s_pass);
   sexp_gc_preserve(ctx, fail, s_fail);
-  analyze_bind(test, sexp_cadr(x), ctx);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
-  analyze_bind(pass, sexp_caddr(x), ctx);
+    res = sexp_compile_error(ctx, "bad if syntax", x);
-  fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
+  } else {
-  analyze_bind(fail, fail_expr, ctx);
+    test = analyze(ctx, sexp_cadr(x));
-  res = sexp_make_cnd(ctx, test, pass, fail);
+    pass = analyze(ctx, sexp_caddr(x));
+    fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
+    fail = analyze(ctx, fail_expr);
+    res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
+           sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
+  }
   sexp_gc_release(ctx, test, s_test);
   return res;
 }
@@ -530,35 +537,40 @@ static sexp analyze_define (sexp ctx, sexp x) {
   sexp_gc_preserve(ctx, tmp, s_tmp);
   sexp_gc_preserve(ctx, env, s_env);
   env = sexp_context_env(ctx);
-  name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
-  if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
+    res = sexp_compile_error(ctx, "bad define syntax", x);
-    tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx));
-    sexp_push(ctx, sexp_env_bindings(env), tmp);
-    sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name);
-    sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
-    sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x);
-    res = SEXP_VOID;
   } else {
-    env_cell_create(ctx, env, name, SEXP_VOID);
+    name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
-    if (sexp_pairp(sexp_cadr(x))) {
+    if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
-      tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
+      tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx));
-      tmp = sexp_cons(ctx, SEXP_VOID, tmp);
+      sexp_push(ctx, sexp_env_bindings(env), tmp);
-      value = analyze_lambda(ctx, tmp);
+      sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name);
-    } else
+      sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name);
-      value = analyze(ctx, sexp_caddr(x));
+      sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x);
-    ref = analyze_var_ref(ctx, name);
+      res = SEXP_VOID;
-    if (sexp_exceptionp(ref))
+    } else {
-      res = ref;
+      env_cell_create(ctx, env, name, SEXP_VOID);
-    else if (sexp_exceptionp(value))
+      if (sexp_pairp(sexp_cadr(x))) {
-      res = value;
+        tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
-    else
+        tmp = sexp_cons(ctx, SEXP_VOID, tmp);
-      res = sexp_make_set(ctx, ref, value);
+        value = analyze_lambda(ctx, tmp);
+      } else
+        value = analyze(ctx, sexp_caddr(x));
+      ref = analyze_var_ref(ctx, name);
+      if (sexp_exceptionp(ref))
+        res = ref;
+      else if (sexp_exceptionp(value))
+        res = value;
+      else
+        res = sexp_make_set(ctx, ref, value);
+    }
   }
   sexp_gc_release(ctx, ref, s_ref);
   return res;
 }
 
 static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
+  sexp res = SEXP_VOID;
   sexp_gc_var(eval_ctx, proc, s_proc);
   sexp_gc_var(eval_ctx, mac, s_mac);
   sexp_gc_var(eval_ctx, tmp, s_tmp);
@@ -566,16 +578,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
   sexp_gc_preserve(eval_ctx, mac, s_mac);
   sexp_gc_preserve(eval_ctx, tmp, s_tmp);
   for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
-    proc = eval_in_context(eval_ctx, sexp_cadar(ls));
+    if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
-    analyze_check_exception(proc);
+           && sexp_nullp(sexp_cddar(ls)))) {
-    if (sexp_procedurep(proc)) {
+      res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls));
-      mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx));
+    } else {
-      tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
+      proc = eval_in_context(eval_ctx, sexp_cadar(ls));
-      sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
+      if (sexp_exceptionp(proc)) {
+        res = proc;
+        break;
+      } else if (sexp_procedurep(proc)) {
+        mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx));
+        tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac);
+        sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp);
+      }
     }
   }
   sexp_gc_release(eval_ctx, proc, s_proc);
-  return SEXP_VOID;
+  return res;
 }
 
 static sexp analyze_define_syntax (sexp ctx, sexp x) {
@@ -596,14 +615,17 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) {
   sexp_gc_preserve(ctx, env, s_env);
   sexp_gc_preserve(ctx, ctx2, s_ctx2);
   sexp_gc_preserve(ctx, tmp, s_tmp);
-  env = sexp_alloc_type(ctx, env, SEXP_ENV);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
-  sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx));
+    res = sexp_compile_error(ctx, "bad let-syntax", x);
-  sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx));
+  } else {
-  ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
+    env = sexp_alloc_type(ctx, env, SEXP_ENV);
-  sexp_context_env(ctx2) = env;
+    sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx));
-  tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2);
+    sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx));
-  analyze_check_exception(tmp);
+    ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
-  res = analyze_seq(ctx2, sexp_cddr(x));
+    sexp_context_env(ctx2) = env;
+    tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2);
+    res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x)));
+  }
   sexp_gc_release(ctx, env, s_env);
   return res;
 }
@@ -612,8 +634,12 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
   sexp res;
   sexp_gc_var(ctx, tmp, s_tmp);
   sexp_gc_preserve(ctx, tmp, s_tmp);
-  tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx);
+  if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
-  res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x)));
+    res = sexp_compile_error(ctx, "bad letrec-syntax", x);
+  } else {
+    tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx);
+    res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x)));
+  }
   sexp_gc_release(ctx, tmp, s_tmp);
   return res;
 }
@@ -685,8 +711,8 @@ static sexp analyze (sexp ctx, sexp object) {
             res = sexp_compile_error(ctx, "too many args for opcode", x);
           } else {
             res = analyze_app(ctx, sexp_cdr(x));
-            analyze_check_exception(res);
+            if (! sexp_exceptionp(res))
-            sexp_push(ctx, res, op);
+              sexp_push(ctx, res, op);
           }
         } else {
           res = analyze_app(ctx, x);
@@ -2031,15 +2057,19 @@ sexp compile (sexp ctx, sexp x) {
   sexp_gc_preserve(ctx, ctx2, s_ctx2);
   sexp_gc_preserve(ctx, vec, s_vec);
   sexp_gc_preserve(ctx, res, s_res);
-  analyze_bind(ast, x, ctx);
+  ast = analyze(ctx, x);
-  free_vars(ctx, ast, SEXP_NULL);    /* should return SEXP_NULL */
+  if (sexp_exceptionp(ast)) {
-  ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx));
+    res = ast;
-  sexp_context_parent(ctx2) = ctx;
+  } else {
-  generate(ctx2, ast);
+    free_vars(ctx, ast, SEXP_NULL);    /* should return SEXP_NULL */
-  res = finalize_bytecode(ctx2);
+    ctx2 = sexp_make_context(ctx,sexp_context_stack(ctx),sexp_context_env(ctx));
-  vec = sexp_make_vector(ctx, 0, SEXP_VOID);
+    sexp_context_parent(ctx2) = ctx;
-  res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
+    generate(ctx2, ast);
-                            res, vec);
+    res = finalize_bytecode(ctx2);
+    vec = sexp_make_vector(ctx, 0, SEXP_VOID);
+    res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0),
+                              res, vec);
+  }
   sexp_gc_release(ctx, ast, s_ast);
   return res;
 }

gc.c

@@ -4,9 +4,11 @@
 
 #include "sexp.h"
 
-#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
+/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */
+#define SEXP_INITIAL_HEAP_SIZE 37000
 #define SEXP_MAXIMUM_HEAP_SIZE 0
 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
+#define SEXP_GROW_HEAP_RATIO 0.8
 
 typedef struct sexp_heap *sexp_heap;
 
@@ -21,6 +23,11 @@ static sexp_heap heap;
 static sexp* stack_base;
 extern sexp continuation_resumer, final_resumer;
 
+static sexp_heap sexp_heap_last (sexp_heap h) {
+  while (h->next) h = h->next;
+  return h;
+}
+
 sexp_uint_t sexp_allocated_bytes (sexp x) {
   sexp_uint_t res, *len_ptr;
   sexp t;
@@ -57,7 +64,7 @@ void sexp_mark (sexp x) {
   }
 }
 
-#ifdef USE_DEBUG_GC
+#if USE_DEBUG_GC
 int stack_references_pointer_p (sexp ctx, sexp x) {
   sexp *p;
   for (p=&x; p<stack_base; p++)
@@ -162,9 +169,7 @@ sexp_heap sexp_make_heap (size_t size) {
 
 int sexp_grow_heap (sexp ctx, size_t size) {
   size_t cur_size, new_size;
-  sexp_heap h;
+  sexp_heap h = sexp_heap_last(heap);
-  for (h=heap; h->next; h=h->next)
-    ;
   cur_size = h->size;
   new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4);
   h->next = sexp_make_heap(new_size);
@@ -200,17 +205,20 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
 
 void* sexp_alloc (sexp ctx, size_t size) {
   void *res;
+  size_t freed;
+  sexp_heap h;
   size = sexp_align(size, 4);
   res = sexp_try_alloc(ctx, size);
   if (! res) {
-    if (sexp_unbox_integer(sexp_gc(ctx)) >= size)
+    freed = sexp_unbox_integer(sexp_gc(ctx));
-      res = sexp_try_alloc(ctx, size);
+    h = sexp_heap_last(heap);
-    if ((! res) && sexp_grow_heap(ctx, size))
+    if (((freed < size)
-      res = sexp_try_alloc(ctx, size);
+         || ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO)))
+        && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
+      sexp_grow_heap(ctx, size);
+    res = sexp_try_alloc(ctx, size);
     if (! res) {
-      fprintf(stderr,
+      fprintf(stderr, "out of memory allocating %ld bytes, aborting\n", size);
-              "chibi: out of memory trying to allocate %ld bytes, aborting\n",
-              size);
       exit(70);
     }
   }
@@ -220,6 +228,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
 void sexp_gc_init () {
   sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4);
   heap = sexp_make_heap(size);
+  /* the +32 is a hack, but this is just for debugging anyway */
   stack_base = ((sexp*)&size) + 32;
 }
 

sexp.c

@@ -10,9 +10,9 @@ struct huff_entry {
   unsigned char len;
   unsigned short bits;
 };
-#include "sexp-hufftabs.c"
+#include "opt/sexp-hufftabs.c"
 static struct huff_entry huff_table[] = {
-#include "sexp-huff.c"
+#include "opt/sexp-huff.c"
 };
 #endif
 
@@ -41,7 +41,6 @@ static int digit_value (c) {
 }
 
 static int is_separator(int c) {
-  /* return (!((c-9)&(~3))) | (~(c^4)); */
   return 0<c && c<0x60 && sexp_separators[c];
 }
 
@@ -53,70 +52,45 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
   return res;
 }
 
-#define _TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
+#define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
   {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}}
 
 static struct sexp_struct sexp_types[] = {
-  _TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
+  _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
-  _TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
+  _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
-  _TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
+  _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
-  _TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"),
+  _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"),
-  _TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"),
+  _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"),
-  _TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
+  _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
-  _TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
+  _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
-  _TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
+  _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
-  _TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"),
+  _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"),
-  _TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
+  _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
-  _TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"),
+  _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"),
-  _TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
+  _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
-  _TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
+  _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
-  _TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
+  _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
-  _TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
+  _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
-  _TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
+  _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
-  _TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
+  _DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
-  _TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
+  _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
-  _TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
+  _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
-  _TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
+  _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
-  _TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
+  _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
-  _TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
+  _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
-  _TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"),
+  _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"),
-  _TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
+  _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
-  _TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
+  _DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
-  _TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
+  _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
-  _TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
+  _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
-  _TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"),
+  _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"),
-  _TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
+  _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
 };
 
-#undef _TYPE
+#undef _DEF_TYPE
 
 #if ! USE_BOEHM
-#if USE_MALLOC
+#if ! USE_MALLOC
-void sexp_deep_free (sexp ctx, sexp obj) {
-  int len, i;
-  sexp *elts;
-  if (sexp_pointerp(obj)) {
-    switch (sexp_pointer_tag(obj)) {
-    case SEXP_PAIR:
-      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; i<len; i++)
-        sexp_deep_free(elts[i]);
-      sexp_free(ctx, elts);
-      break;
-    case SEXP_STRING:
-    case SEXP_SYMBOL:
-      sexp_free(ctx, sexp_string_data(obj));
-      break;
-    }
-    sexp_free(ctx, obj);
-  }
-}
-#else
 #include "gc.c"
 #endif
 #endif
@@ -136,18 +110,36 @@ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
 }
 
 sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) {
-  return sexp_make_exception(ctx, sexp_intern(ctx, "user"),
+  sexp res;
-                             sexp_c_string(ctx, message, -1),
+  sexp_gc_var(ctx, sym, s_sym);
-                             ((sexp_pairp(irritants) || sexp_nullp(irritants))
+  sexp_gc_var(ctx, str, s_str);
-                              ? irritants : sexp_list1(ctx, irritants)),
+  sexp_gc_var(ctx, irr, s_irr);
-                             self, SEXP_FALSE, SEXP_FALSE);
+  sexp_gc_preserve(ctx, sym, s_sym);
+  sexp_gc_preserve(ctx, str, s_str);
+  sexp_gc_preserve(ctx, irr, s_irr);
+  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"),
+                            str = sexp_c_string(ctx, message, -1),
+                            ((sexp_pairp(irritants) || sexp_nullp(irritants))
+                             ? irritants : (irr = sexp_list1(ctx, irritants))),
+                            self, SEXP_FALSE, SEXP_FALSE);
+  sexp_gc_release(ctx, sym, s_sym);
+  return res;
 }
 
 sexp sexp_type_exception (sexp ctx, char *message, sexp obj) {
-  return sexp_make_exception(ctx, sexp_intern(ctx, "type"),
+  sexp res;
-                             sexp_c_string(ctx, message, -1),
+  sexp_gc_var(ctx, sym, s_sym);
-                             sexp_list1(ctx, obj),
+  sexp_gc_var(ctx, str, s_str);
-                             SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
+  sexp_gc_var(ctx, irr, s_irr);
+  sexp_gc_preserve(ctx, sym, s_sym);
+  sexp_gc_preserve(ctx, str, s_str);
+  sexp_gc_preserve(ctx, irr, s_irr);
+  res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"),
+                            str = sexp_c_string(ctx, message, -1),
+                            irr = sexp_list1(ctx, obj),
+                            SEXP_FALSE, SEXP_FALSE, SEXP_FALSE);
+  sexp_gc_release(ctx, sym, s_sym);
+  return res;
 }
 
 sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
@@ -808,7 +800,7 @@ void sexp_write (sexp obj, sexp out) {
     if (((sexp_uint_t)obj&7)==7) {
       c = ((sexp_uint_t)obj)>>3;
       while (c) {
-#include "sexp-unhuff.c"
+#include "opt/sexp-unhuff.c"
         sexp_write_char(res, out);
       }
     }
@@ -1119,7 +1111,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
       res = sexp_read(ctx, in);
       if (sexp_listp(ctx, res) == SEXP_FALSE) {
         if (! sexp_exceptionp(res)) {
-          sexp_deep_free(ctx, res);
           res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
                                 SEXP_NULL,
                                 in);
@@ -1192,11 +1183,15 @@ sexp sexp_read (sexp ctx, sexp in) {
 
 #if USE_STRING_STREAMS
 sexp sexp_read_from_string(sexp ctx, char *str) {
-  sexp s = sexp_c_string(ctx, str, -1);
+  sexp res;
-  sexp in = sexp_make_input_string_port(ctx, s);
+  sexp_gc_var(ctx, s, s_s);
-  sexp res = sexp_read(ctx, in);
+  sexp_gc_var(ctx, in, s_in);
-  sexp_free(ctx, s);
+  sexp_gc_preserve(ctx, s, s_s);
-  sexp_deep_free(ctx, in);
+  sexp_gc_preserve(ctx, in, s_in);
+  s = sexp_c_string(ctx, str, -1);
+  in = sexp_make_input_string_port(ctx, s);
+  res = sexp_read(ctx, in);
+  sexp_gc_release(ctx, s, s_s);
   return res;
 }
 #endif

sexp.h

@@ -426,6 +426,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 #define sexp_stack_top(x)     ((x)->value.stack.top)
 #define sexp_stack_data(x)    ((x)->value.stack.data)
 
+#define sexp_context_heap(x)    ((x)->value.context.heap)
+#define sexp_context_symbols(x) ((x)->value.context.symbols)
 #define sexp_context_env(x)     ((x)->value.context.env)
 #define sexp_context_stack(x)   ((x)->value.context.stack)
 #define sexp_context_depth(x)   ((x)->value.context.depth)