progress

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);

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)
+  tmp = sexp_flatten_dot(ctx, sexp_lambda_params(res));
-    = extend_env(ctx,
+  sexp_context_env(ctx) = extend_env(ctx, sexp_context_env(ctx), tmp, res);
-                 sexp_context_env(ctx),
-                 sexp_flatten_dot(ctx, sexp_lambda_params(res)),
-                 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,
+      tmp = sexp_cons(ctx, sexp_cdadr(tmp), sexp_cddr(tmp));
-                             sexp_cons(ctx,
+      value = analyze_lambda(ctx, sexp_cons(ctx, SEXP_VOID, tmp));
-                                       SEXP_VOID,
-                                       sexp_cons(ctx,
-                                                 sexp_cdadr(tmp),
-                                                 sexp_cddr(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,14 +1762,15 @@ 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;
+    res = in;
-  }
+  } else {
     while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) {
       res = eval_in_context(ctx2, x);
       if (sexp_exceptionp(res))
@@ -1787,6 +1783,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
     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);
 }
 

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) {
+void validate_free_list (sexp ctx) {
-  sexp_uint_t freed=0, size;
+  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<stack_base; p++) {
+    if (*p == x) {
+      fprintf(stderr, "reference to freed var %p at %p: ", x, p);
+      simple_write(x, 1, stderr);
+      putc('\n', stderr);
+    }
+  }
+}
+
+sexp sexp_sweep (sexp ctx) {
+  sexp_uint_t freed, max_freed=0, sum_freed=0, size;
+  sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4));
+  sexp q=sexp_free_list, r;
+  /* scan over the whole heap */
+  while (((char*)p) < sexp_heap_end) {
+    /* find the preceding and succeeding free list pointers */
+    for (r=sexp_cdr(q); r && sexp_pairp(r) && (r<p); q=r, r=sexp_cdr(r))
+      ;
+    /* fprintf(stderr, "p: %p q: %p r: %p\n", p, q, r); */
+    if (r == p) {
+      p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
+      continue;
+    } else if (p <= q) {
+      fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q);
+    }
+    size = sexp_align(sexp_allocated_bytes(p), 4);
     if (! sexp_gc_mark(p)) {
 /*       fprintf(stderr, "\x1B[31mfreeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */
 /*       simple_write(p, 1, stderr); */
 /*       fprintf(stderr, "\x1B[0m\n"); */
-      freed += size;
+      validate_freed_pointer(p, &ctx);
+      sum_freed += size;
       if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
           && (q != sexp_free_list)) {
         /* merge q with p */
+/*         fprintf(stderr, "\x1B[34mleft merging  %lu bytes @ %p ", size, p); */
+/*         simple_write(p, 1, stderr); */
+/*         fprintf(stderr, " with %lu bytes @ %p (%p)\x1B[0m\n", */
+/*                 (sexp_uint_t)sexp_car(q), q, sexp_cdr(q)); */
         if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
           /* ... and with r */
-          sexp_car(q)
-            = (sexp)(size+(sexp_uint_t)sexp_car(q)+(sexp_uint_t)sexp_car(r));
           sexp_cdr(q) = sexp_cdr(r);
-          r = sexp_cdr(r);
+          freed = (sexp_uint_t)sexp_car(q) + size + (sexp_uint_t)sexp_car(r);
+          p = (sexp) (((char*)p)+size+(sexp_uint_t)sexp_car(r));
         } else {
-          sexp_car(q) = (sexp)(size+(sexp_uint_t)sexp_car(q));
+          freed = (sexp_uint_t)sexp_car(q) + size;
+          p = (sexp) (((char*)p)+size);
         }
+        sexp_car(q) = (sexp)freed;
       } else {
-        sexp_pointer_tag(p) = SEXP_PAIR;
         if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) {
           /* merge p with r */
+/*           fprintf(stderr, "\x1B[34mright merging %lu bytes @ %p ", size, p); */
+/*           simple_write(p, 1, stderr); */
+/*           fprintf(stderr, " with %lu bytes @ %p (%p)\x1B[0m\n", */
+/*                   (sexp_uint_t)sexp_car(r), r, sexp_cdr(r)); */
           sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r));
           sexp_cdr(p) = sexp_cdr(r);
-          r = p;
+          sexp_cdr(q) = p;
+          freed = size + (sexp_uint_t)sexp_car(r);
         } else {
           sexp_car(p) = (sexp)size;
           sexp_cdr(p) = r;
-        }
           sexp_cdr(q) = p;
+          freed = size;
         }
+        sexp_pointer_tag(p) = SEXP_PAIR;
+        p = (sexp) (((char*)p)+freed);
+      }
+      if (freed > 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);
     }
-/*   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<p); q=r, r=sexp_cdr(r))
@@ -537,7 +640,8 @@ int sexp_grow_heap (sexp ctx, size_t size) {
   sexp q;
   size_t cur_size = sexp_heap_end - sexp_heap, new_size;
   new_size = sexp_align(((cur_size > 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);
 }
 

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);

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 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);
-  return sexp_make_exception(ctx, the_read_error_symbol,
+  str = sexp_c_string(ctx, msg, -1);
-                             sexp_c_string(ctx, msg, -1),
+  res = sexp_make_exception(ctx, the_read_error_symbol,
-                             irritants, SEXP_FALSE, name,
+                            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("#<type ", out);
+      sexp_write_string(sexp_type_name(obj), out);
+      sexp_write_string(">", out);
+      break;
     case SEXP_STRING:
       sexp_write_char('"', out);
       i = sexp_string_length(obj);
@@ -1015,7 +1068,10 @@ 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 */
+      tmp = sexp_read_raw(ctx, in);   /* discard */
+      if (sexp_exceptionp(tmp))
+        res = tmp;
+      else
         goto scan_loop;
     case '\\':
       c1 = sexp_read_char(in);

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;         \
+  sexp x = SEXP_VOID;          \
-  struct sexp_gc_var_t y = {0, 0};
+  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))