Added full support for packed images, both for static and dynamic libraries.

Makefile

@@ -115,8 +115,8 @@ sexp-ulimit.o: sexp.c $(BASE_INCLUDES)
 main.o: main.c $(INCLUDES)
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
-SEXP_OBJS = gc.o sexp.o bignum.o
+SEXP_OBJS = gc.o sexp.o bignum.o gc_heap.o 
-SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o
+SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o gc_heap.o
 EVAL_OBJS = opcodes.o vm.o eval.o simplify.o
 
 libchibi-sexp$(SO): $(SEXP_OBJS)

bignum.c

@@ -43,10 +43,10 @@ sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
     res = sexp_make_bignum(ctx, 1);
     if (x < 0) {
       sexp_bignum_sign(res) = -1;
-      sexp_bignum_data(res)[0] = -x;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)-x;
     } else {
       sexp_bignum_sign(res) = 1;
-      sexp_bignum_data(res)[0] = x;
+      sexp_bignum_data(res)[0] = (sexp_uint_t)x;
     }
   }
   return res;
@@ -59,7 +59,7 @@ sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
   } else {
     res = sexp_make_bignum(ctx, 1);
     sexp_bignum_sign(res) = 1;
-    sexp_bignum_data(res)[0] = x;
+    sexp_bignum_data(res)[0] = (sexp_uint_t)x;
   }
   return res;
 }
@@ -75,7 +75,7 @@ sexp sexp_double_to_bignum (sexp ctx, double f) {
   scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
   sign = (f < 0 ? -1 : 1);
   for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
-    tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
+    tmp = sexp_bignum_fxmul(ctx, NULL, scale, (sexp_uint_t)double_10s_digit(f), 0);
     res = sexp_bignum_add(ctx, res, res, tmp);
     scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
   }
@@ -217,8 +217,8 @@ sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
   sexp_luint_t n = 0;
   for (i=len-1; i>=offset; i--) {
     n = (n << sizeof(sexp_uint_t)*8) + data[i];
-    q = n / b;
+    q = (sexp_uint_t)(n / b);
-    r = n - (sexp_luint_t)q * b;
+    r = (sexp_uint_t)(n - (sexp_luint_t)q * b);
     data[i] = q;
     n = r;
   }
@@ -235,9 +235,12 @@ sexp sexp_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) {
       return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q));
   }
   b0 = (b >= 0) ? b : -b;
+  if (b0 == 0) {
+    return sexp_xtype_exception(ctx, NULL, "divide by zero", a);
+  }
   for (i=len-1; i>=0; i--) {
     n = (n << sizeof(sexp_uint_t)*8) + data[i];
-    q = n / b0;
+    q = (sexp_uint_t)(n / b0);
     n -= (sexp_luint_t)q * b0;
   }
   return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n);
@@ -253,7 +256,7 @@ sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
   sexp_bignum_data(res)[0] = init;
   for (c=sexp_read_char(ctx, in); sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
     digit = digit_value(c);
-    if ((digit < 0) || (digit >= base))
+    if ((digit < 0) || (digit >= (int)base))
       break;
     res = sexp_bignum_fxmul(ctx, res, res, base, 0);
     res = sexp_bignum_fxadd(ctx, res, digit);
@@ -303,6 +306,9 @@ sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
   sexp_gc_preserve2(ctx, b, str);
   b = sexp_copy_bignum(ctx, NULL, a, 0);
   sexp_bignum_sign(b) = 1;
+  if (lg_base < 1) {
+    return sexp_xtype_exception(ctx, NULL, "number base too small", a);
+  }
   i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
     / lg_base + 1;
   str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
@@ -563,7 +569,7 @@ sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
     }
     /* flip the sign if we overshot in our estimate */
     if (sexp_bignum_sign(a1) != sign) {
-      sexp_bignum_sign(a1) = -sign;
+      sexp_bignum_sign(a1) = (char)(-sign);
       sign *= -1;
     }
   }
@@ -710,7 +716,7 @@ sexp sexp_double_to_ratio (sexp ctx, double f) {
   for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) {
     res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0);
     f = f * 10;
-    res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f));
+    res = sexp_bignum_fxadd(ctx, res, (sexp_uint_t)double_10s_digit(f));
     f = f - trunc(f);
     scale = sexp_mul(ctx, scale, SEXP_TEN);
   }

chibi-osx

@@ -0,0 +1 @@
+LD_LIBRARY_PATH=.: DYLD_LIBRARY_PATH=.: CHIBI_MODULE_PATH=lib ./chibi-scheme "$@"

eval.c

@@ -236,6 +236,7 @@ sexp sexp_extend_synclo_env (sexp ctx, sexp env) {
       sexp_env_renames(e2) = sexp_env_renames(e1);
 #endif
     }
+    if (!e2) { return sexp_global(ctx, SEXP_G_OOM_ERROR); }
     sexp_env_parent(e2) = sexp_context_env(ctx);
   }
   sexp_gc_release1(ctx);
@@ -261,7 +262,6 @@ int sexp_param_index (sexp ctx, sexp lambda, sexp name) {
   sexp ls;
   int i;
   while (1) {
-    i = 0;
     ls = sexp_lambda_params(lambda);
     for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
       if (sexp_car(ls) == name)
@@ -304,7 +304,7 @@ void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) {
 
 void sexp_expand_bcode (sexp ctx, sexp_sint_t size) {
   sexp tmp;
-  if (sexp_bytecode_length(sexp_context_bc(ctx))
+  if ((sexp_sint_t)sexp_bytecode_length(sexp_context_bc(ctx))
       < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) {
     tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2);
     if (sexp_exceptionp(tmp)) {
@@ -1766,7 +1766,7 @@ sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, s
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   off = sexp_string_index_to_offset(ctx, self, n, str, i);
   if (sexp_exceptionp(off)) return off;
-  if (sexp_unbox_fixnum(off) >= sexp_string_size(str))
+  if (sexp_unbox_fixnum(off) >= (sexp_sint_t)sexp_string_size(str))
     return sexp_user_exception(ctx, self, "string-ref: index out of range", i);
   return sexp_string_utf8_ref(ctx, str, off);
 }
@@ -1821,7 +1821,7 @@ sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, s
   sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
   off = sexp_string_index_to_offset(ctx, self, n, str, i);
   if (sexp_exceptionp(off)) return off;
-  if (sexp_unbox_fixnum(off) >= sexp_string_size(str))
+  if (sexp_unbox_fixnum(off) >= (sexp_sint_t)sexp_string_size(str))
     return sexp_user_exception(ctx, self, "string-set!: index out of range", i);
   sexp_string_utf8_set(ctx, str, off, ch);
   return SEXP_VOID;
@@ -1937,13 +1937,13 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
     res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code);
   else {
     res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
-    sexp_opcode_class(res) = sexp_unbox_fixnum(op_class);
+    sexp_opcode_class(res) = (unsigned char)sexp_unbox_fixnum(op_class);
-    sexp_opcode_code(res) = sexp_unbox_fixnum(code);
+    sexp_opcode_code(res) = (unsigned char)sexp_unbox_fixnum(code);
-    sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args);
+    sexp_opcode_num_args(res) = (unsigned char)sexp_unbox_fixnum(num_args);
-    sexp_opcode_flags(res) = sexp_unbox_fixnum(flags);
+    sexp_opcode_flags(res) = (unsigned char)sexp_unbox_fixnum(flags);
     sexp_opcode_arg1_type(res) = arg1t;
     sexp_opcode_arg2_type(res) = arg2t;
-    sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp);
+    sexp_opcode_inverse(res) = (unsigned char)sexp_unbox_fixnum(invp);
     sexp_opcode_data(res) = data;
     sexp_opcode_data2(res) = data2;
     sexp_opcode_func(res) = func;
@@ -1956,7 +1956,7 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
 }
 
 sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
-                        int flags, sexp_proc1 f, sexp data) {
+                        int flags, const char *fname, sexp_proc1 f, sexp data) {
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
 #if ! SEXP_USE_EXTENDED_FCALL
@@ -1978,6 +1978,9 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
   sexp_opcode_name(res) = sexp_c_string(ctx, name, -1);
   sexp_opcode_data(res) = data;
   sexp_opcode_func(res) = f;
+  if (fname) {
+    sexp_opcode_data2(res) = sexp_c_string(ctx, fname, -1);
+  }
 #if SEXP_USE_DL
   sexp_opcode_dl(res) = sexp_context_dl(ctx);
 #endif
@@ -1986,25 +1989,25 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
 }
 
 sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args,
-                              int flags, sexp_proc1 f, sexp data) {
+                              int flags, const char *fname, sexp_proc1 f, sexp data) {
   sexp_gc_var2(sym, res);
   sexp_gc_preserve2(ctx, sym, res);
-  res = sexp_make_foreign(ctx, name, num_args, flags, f, data);
+  res = sexp_make_foreign(ctx, name, num_args, flags, fname, f, data);
   if (!sexp_exceptionp(res))
     sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
   sexp_gc_release2(ctx);
   return res;
 }
 
-sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name,
+sexp sexp_define_foreign_param_aux (sexp ctx, sexp env, const char *name,
-                                int num_args, sexp_proc1 f, const char *param) {
+                                    int num_args, const char *fname, sexp_proc1 f, const char *param) {
   sexp res = SEXP_FALSE;
   sexp_gc_var1(tmp);
   sexp_gc_preserve1(ctx, tmp);
   tmp = sexp_intern(ctx, param, -1);
   tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE);
   if (sexp_opcodep(tmp))
-    res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp);
+    res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, fname, f, tmp);
   sexp_gc_release1(ctx);
   return res;
 }
@@ -2311,7 +2314,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
   sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
 #if SEXP_USE_SIMPLIFY
   op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0,
-                         (sexp_proc1)sexp_simplify, SEXP_VOID);
+                         NULL, (sexp_proc1)sexp_simplify, SEXP_VOID);
   tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
   sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
 #endif
@@ -2320,7 +2323,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
   /* load init-7.scm */
   len = strlen(sexp_init_file);
   strncpy(init_file, sexp_init_file, len);
-  init_file[len] = sexp_unbox_fixnum(version) + '0';
+  init_file[len] = (char)sexp_unbox_fixnum(version) + '0';
   strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix));
   init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0;
   tmp = sexp_load_module_file(ctx, init_file, e);

gc.c

@@ -14,12 +14,6 @@
 #include <sys/mman.h>
 #endif
 
-#ifdef __APPLE__
-#define SEXP_RTLD_DEFAULT RTLD_SELF
-#else
-#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
-#endif
-
 #define SEXP_BANNER(x) ("**************** GC "x"\n")
 
 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(1))
@@ -362,10 +356,13 @@ sexp sexp_finalize (sexp ctx) {
       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
         ;
       if ((char*)r == (char*)p) { /* this is a free block, skip it */
-        p = (sexp) (((char*)p) + r->size);
+        p = (sexp) (((char*)p) + (r ? r->size : 0));
         continue;
       }
       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
+      if (size == 0) {
+        return SEXP_FALSE;
+      }
       if (!sexp_markedp(p)) {
         t = sexp_object_type(ctx, p);
         finalizer = sexp_type_finalize(t);
@@ -404,7 +401,7 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
       for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
         ;
       if ((char*)r == (char*)p) { /* this is a free block, skip it */
-        p = (sexp) (((char*)p) + r->size);
+        p = (sexp) (((char*)p) + (r ? r->size : 0));
         continue;
       }
       size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
@@ -606,174 +603,6 @@ void* sexp_alloc (sexp ctx, size_t size) {
   return res;
 }
 
-#if ! SEXP_USE_GLOBAL_HEAP
-
-void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) {
-  sexp_sint_t i, off, len, freep, loadp;
-  sexp_free_list q;
-  sexp p, t, end, *v;
-#if SEXP_USE_DL
-  sexp name;
-#endif
-  freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
-  loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP);
-
-  off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap);
-  heap->data += off;
-  end = (sexp) (heap->data + heap->size);
-
-  /* adjust the free list */
-  heap->free_list = (sexp_free_list) ((char*)heap->free_list + off);
-  for (q=heap->free_list; q->next; q=q->next)
-    q->next = (sexp_free_list) ((char*)q->next + off);
-
-  /* adjust data by traversing over the new heap */
-  p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
-  q = heap->free_list;
-  while (p < end) {
-    /* find the next free list pointer */
-    for ( ; q && ((char*)q < (char*)p); q=q->next)
-      ;
-    if ((char*)q == (char*)p) { /* this is a free block, skip it */
-      p = (sexp) (((char*)p) + q->size);
-    } else {
-      t = (sexp)((char*)(types[sexp_pointer_tag(p)])
-                 + ((char*)types > (char*)p ? off : 0));
-      len = sexp_type_num_slots_of_object(t, p);
-      v = (sexp*) ((char*)p + sexp_type_field_base(t));
-      /* offset any pointers in the _destination_ heap */
-      for (i=0; i<len; i++)
-        if (v[i] && sexp_pointerp(v[i]))
-          v[i] = (sexp) ((char*)v[i] + off);
-      /* don't free unless specified - only the original cleans up */
-      if (! freep)
-        sexp_freep(p) = 0;
-      /* adjust context heaps, don't copy saved sexp_gc_vars */
-      if (sexp_contextp(p)) {
-#if SEXP_USE_GREEN_THREADS
-        sexp_context_ip(p) += off;
-#endif
-        sexp_context_last_fp(p) += off;
-        sexp_stack_top(sexp_context_stack(p)) = 0;
-        sexp_context_saves(p) = NULL;
-        sexp_context_heap(p) = heap;
-      } else if (sexp_bytecodep(p) && off != 0) {
-        for (i=0; i<sexp_bytecode_length(p); ) {
-          switch (sexp_bytecode_data(p)[i++]) {
-            case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
-            case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
-            case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
-            case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
-            case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
-#if SEXP_USE_GREEN_THREADS
-            case SEXP_OP_PARAMETER_REF:
-#endif
-#if SEXP_USE_EXTENDED_FCALL
-            case SEXP_OP_FCALLN:
-#endif
-              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
-              if (v[0] && sexp_pointerp(v[0])) v[0] = (sexp) (((char*)v[0]) + off);
-              /* ... FALLTHROUGH ... */
-            case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
-            case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
-            case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
-            case SEXP_OP_TYPEP:
-#if SEXP_USE_RESERVE_OPCODE
-            case SEXP_OP_RESERVE:
-#endif
-              i += sizeof(sexp); break;
-            case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
-              i += 2*sizeof(sexp); break;
-            case SEXP_OP_MAKE_PROCEDURE:
-              v = (sexp*)(&(sexp_bytecode_data(p)[i]));
-              if (v[2] && sexp_pointerp(v[2])) v[2] = (sexp) (((char*)v[2]) + off);
-              i += 3*sizeof(sexp); break;
-          }
-        }
-      } else if (sexp_portp(p) && sexp_port_stream(p)) {
-        sexp_port_stream(p) = 0;
-        sexp_port_openp(p) = 0;
-        sexp_freep(p) = 0;
-#if SEXP_USE_DL
-      } else if (loadp && sexp_dlp(p)) {
-        sexp_dl_handle(p) = NULL;
-#endif
-      }
-      p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p))+SEXP_GC_PAD);
-    }
-  }
-
-  /* make a second pass to fix code references */
-  if (loadp) {
-    p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size));
-    q = heap->free_list;
-    while (p < end) {
-      /* find the next free list pointer */
-      for ( ; q && ((char*)q < (char*)p); q=q->next)
-        ;
-      if ((char*)q == (char*)p) { /* this is a free block, skip it */
-        p = (sexp) (((char*)p) + q->size);
-      } else {
-#if SEXP_USE_DL
-        if (sexp_opcodep(p) && sexp_opcode_func(p)) {
-          name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p);
-          if (sexp_dlp(sexp_opcode_dl(p))) {
-            if (!sexp_dl_handle(sexp_opcode_dl(p)))
-              sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY);
-            sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name));
-          } else {
-            sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name));
-          }
-        } else
-#endif
-        if (sexp_typep(p)) {
-          if (sexp_type_finalize(p)) {
-            /* TODO: handle arbitrary finalizers in images */
-#if SEXP_USE_DL
-            if (sexp_type_tag(p) == SEXP_DL)
-              sexp_type_finalize(p) = SEXP_FINALIZE_DL;
-            else
-#endif
-              sexp_type_finalize(p) = SEXP_FINALIZE_PORT;
-          }
-        }
-        t = types[sexp_pointer_tag(p)];
-        p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD));
-      }
-    }
-  }
-}
-
-sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
-  sexp_sint_t off;
-  sexp_heap to, from = sexp_context_heap(ctx);
-
-  /* validate input, creating a new heap if needed */
-  if (from->next) {
-    return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
-  } else if (! dst || sexp_not(dst)) {
-    to = sexp_make_heap(from->size, from->max_size, from->chunk_size);
-    if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR);
-    dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
-  } else if (! sexp_contextp(dst)) {
-    return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
-  } else if (sexp_context_heap(dst)->size < from->size) {
-    return sexp_user_exception(ctx, NULL, "destination context too small", dst);
-  } else {
-    to = sexp_context_heap(dst);
-  }
-
-  /* copy the raw data */
-  off = (char*)to - (char*)from;
-  memcpy(to, from, sexp_heap_pad_size(from->size));
-
-  /* adjust the pointers */
-  sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags);
-
-  return dst;
-}
-
-#endif
 
 void sexp_gc_init (void) {
 #if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_GC

gc_heap.c

@@ -0,0 +1,671 @@
+/* gc_heap.h -- heap packing, run-time image generation    */
+/* Copyright (c) 2016 Chris Walsh.  All rights reserved.   */
+/* BSD-style license: http://synthcode.com/license.txt     */
+
+#include "gc_heap.h"
+
+#define ERR_STR_SIZE 256
+char gc_heap_err_str[ERR_STR_SIZE];
+
+
+static sexp_uint_t sexp_gc_allocated_bytes (sexp ctx, sexp *types, size_t types_cnt, sexp x) {
+  sexp_uint_t res;
+  if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= types_cnt))
+    return sexp_heap_align(1);
+  res = sexp_type_size_of_object(types[sexp_pointer_tag(x)], x) + SEXP_GC_PAD;
+  return res;
+}
+
+
+sexp sexp_gc_heap_walk(sexp ctx,
+                       sexp *t,      /* normally set to sexp_context_types(ctx) */
+                       size_t t_cnt, /* normally set to sexp_context_num_types(ctx) */
+                       void *user,
+                       sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user),
+                       sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user),
+                       sexp (*sexp_callback)(sexp ctx, sexp s, void *user))
+{
+  sexp res = SEXP_FALSE;
+  if (!ctx || !sexp_contextp(ctx)) return res;
+
+  size_t size = 0;
+  sexp_heap h = sexp_context_heap(ctx);
+  while (h) {
+
+    if (heap_callback && (res = heap_callback(ctx, h, user)) != SEXP_TRUE) {
+      return res; }
+
+    sexp p = sexp_heap_first_block(h);
+    sexp_free_list q = h->free_list;
+    sexp end = sexp_heap_end(h);
+
+    while (p < end) {
+      
+      /* find the preceding and succeeding free list pointers */
+      sexp_free_list r = q->next;
+      while (r && ((char*)r < (char*)p)) {
+        q = r;
+        r = r->next;
+      }
+      
+      if ( (char*)r == (char*)p ) {
+        if (free_callback && (res = free_callback(ctx, r, user)) != SEXP_TRUE) {
+          return res; }
+        size = r ? r->size : 0;
+      } else {
+        if (sexp_callback && (res = sexp_callback(ctx, p, user)) != SEXP_TRUE) {
+          return res; }
+        size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, t, t_cnt, p));
+        if (size == 0) {
+          strcpy(gc_heap_err_str, "Heap element with a zero size detected");
+          goto done;
+        }
+      }
+      p = (sexp)(((char*)p) + size);
+    }
+    
+    h = h->next;
+  }
+  res = SEXP_TRUE;
+done:
+  if (!res) res = sexp_user_exception(ctx, NULL, gc_heap_err_str, NULL);
+  return res;
+}
+
+
+struct sexp_remap {
+  sexp srcp;
+  sexp dstp;
+};
+
+struct sexp_remap_state {
+  size_t index, sexps_count, sexps_size;
+  sexp p, end, ctx_src, ctx_dst;
+  sexp_heap heap;
+  int mode;
+  struct sexp_remap *remap;
+};
+
+
+static sexp sexp_callback_count(sexp ctx, sexp s, void *user) {
+  struct sexp_remap_state* state = user;
+  size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                                        sexp_context_num_types(ctx), s));
+  state->sexps_count += 1;
+  state->sexps_size  += size;
+  return SEXP_TRUE;
+}
+
+
+static sexp sexp_callback_remap(sexp ctx, sexp s, void *user) {
+  struct sexp_remap_state* state = user;
+  size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                                        sexp_context_num_types(ctx), s));
+  memcpy(state->p, s, size);
+  
+  state->remap[state->index].srcp = s;
+  state->remap[state->index].dstp = state->p;
+  if (ctx == s) state->ctx_dst = state->p;
+  
+  state->p = (sexp)(((char*)state->p) + size);
+  state->index += 1;
+
+  return SEXP_TRUE;
+}
+
+
+
+/* Return a destination (remapped) pointer for a given source pointer */
+static sexp sexp_gc_heap_pack_src_to_dst(void* adata, sexp srcp) {
+
+  struct sexp_remap_state* state = adata;
+  int imin = 0;
+  int imax = state->sexps_count - 1;
+
+  while (imin <= imax) {
+    int imid = ((imax - imin) / 2) + imin;
+    sexp midp = state->remap[imid].srcp;
+    if (midp == srcp) {
+      return state->remap[imid].dstp;
+    } else if (midp < srcp) {
+      imin = imid + 1;
+    } else {
+      imax = imid - 1;
+    }
+  }
+  strcpy(gc_heap_err_str, "Source SEXP not found in src->dst mapping");
+  return SEXP_FALSE;
+}
+
+
+static sexp sexp_adjust_fields(sexp dstp, sexp* types, sexp (* adjust_fn)(void *, sexp), void *adata) {
+  sexp_tag_t tag           = sexp_pointer_tag(dstp);
+  sexp       type_spec     = types[tag];
+  size_t     type_sexp_cnt = sexp_type_num_slots_of_object(type_spec, dstp);
+  sexp*      vec           = (sexp*)((char*)dstp + sexp_type_field_base(type_spec));
+  int        i;
+  
+  for (i = 0; i < type_sexp_cnt; i++) {
+    sexp src = vec[i];
+    sexp dst = src;
+    if (src && sexp_pointerp(src)) {
+      dst = adjust_fn(adata, src);
+      if (!sexp_pointerp(dst)) { return dstp; }
+    }
+    vec[i] = dst;
+  }
+  return SEXP_TRUE;
+}
+
+
+static sexp sexp_adjust_bytecode(sexp dstp, sexp (*adjust_fn)(void *, sexp), void *adata) {
+  sexp res = NULL;
+  sexp   src, dst;
+  sexp*  vec;
+  int    i;
+  
+  for (i=0; i < sexp_bytecode_length(dstp); ) {
+    switch (sexp_bytecode_data(dstp)[i++]) {
+    case SEXP_OP_FCALL0:      case SEXP_OP_FCALL1:
+    case SEXP_OP_FCALL2:      case SEXP_OP_FCALL3:
+    case SEXP_OP_FCALL4:      case SEXP_OP_CALL:
+    case SEXP_OP_TAIL_CALL:   case SEXP_OP_PUSH:
+    case SEXP_OP_GLOBAL_REF:  case SEXP_OP_GLOBAL_KNOWN_REF:
+#if SEXP_USE_GREEN_THREADS
+    case SEXP_OP_PARAMETER_REF:
+#endif
+#if SEXP_USE_EXTENDED_FCALL
+    case SEXP_OP_FCALLN:
+#endif
+      vec = (sexp*)(&(sexp_bytecode_data(dstp)[i]));
+      src = vec[0];
+      if (src && sexp_pointerp(src)) {
+        dst = adjust_fn(adata, src);
+        if (!sexp_pointerp(dst)) { res = dst; goto done; }
+        vec[0] = dst;
+      }
+      /* ... FALLTHROUGH ... */
+    case SEXP_OP_JUMP:        case SEXP_OP_JUMP_UNLESS:
+    case SEXP_OP_STACK_REF:   case SEXP_OP_CLOSURE_REF:
+    case SEXP_OP_LOCAL_REF:   case SEXP_OP_LOCAL_SET:
+    case SEXP_OP_TYPEP:
+#if SEXP_USE_RESERVE_OPCODE
+    case SEXP_OP_RESERVE:
+#endif
+      i += sizeof(sexp); break;
+    case SEXP_OP_MAKE: case SEXP_OP_SLOT_REF: case SEXP_OP_SLOT_SET:
+      i += 2*sizeof(sexp); break;
+    case SEXP_OP_MAKE_PROCEDURE:
+      vec = (sexp*)(&(sexp_bytecode_data(dstp)[i]));
+      src = vec[2];
+      if (src && sexp_pointerp(src)) {
+        dst = adjust_fn(adata, src);
+        if (!sexp_pointerp(dst)) { res = dst; goto done; }
+        vec[2] = dst;
+      }
+      i += 3*sizeof(sexp); break;
+    }
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+static sexp sexp_gc_heap_pack_adjust(sexp dstp, sexp* types, struct sexp_remap_state* state) {
+  sexp res = NULL;
+  /* Adjust internal types which contain fields of sexp pointer(s)
+     within in the heap */
+  if ((res = sexp_adjust_fields(dstp, types, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) {
+    goto done; }
+    
+  /* Other adjustments - context heap pointer, bytecode pointers */
+  if (sexp_contextp(dstp)) {
+    sexp_context_heap(dstp) = state->heap;
+  } else if (sexp_bytecodep(dstp)) {
+    if ((res = sexp_adjust_bytecode(dstp, sexp_gc_heap_pack_src_to_dst, state)) != SEXP_TRUE) {
+      goto done; }
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+
+static sexp_heap sexp_gc_packed_heap_make(size_t packed_size, size_t free_size) {
+  if (free_size > 0 && free_size < 2*sexp_free_chunk_size) {
+    free_size = 2*sexp_free_chunk_size;
+  }
+  free_size = sexp_heap_align(free_size);
+  sexp_heap heap = sexp_make_heap(sexp_heap_align(packed_size + free_size + sexp_free_chunk_size + 128), 0, 0);
+  if (!heap) {
+    strcpy(gc_heap_err_str, "Could not allocate memory for heap");
+    return NULL;
+  }
+  sexp base = sexp_heap_first_block(heap);
+  size_t pad = (char *)base - (char *)heap->data;
+  heap->size = packed_size + free_size + pad;
+  heap->free_list->size = 0;
+  if (free_size == 0) {
+    heap->free_list->next = NULL;
+  } else {
+    heap->free_list->next = (sexp_free_list)((char *)base + packed_size);
+    heap->free_list->next->next = NULL;
+    heap->free_list->next->size = free_size;
+  }
+  return heap;
+}
+
+
+/* Pack the heap.  Return a new context with a unified, packed heap. */
+sexp sexp_gc_heap_pack(sexp ctx, sexp_uint_t heap_free_size) {
+
+  sexp res = NULL;
+  sexp_gc(ctx, NULL);
+  
+  struct sexp_remap_state state;
+  memset(&state, 0, sizeof(struct sexp_remap_state));
+  state.ctx_src = ctx;
+  if ((res = sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx),
+                               &state, NULL, NULL, sexp_callback_count)) != SEXP_TRUE) {
+    goto done; }
+
+  state.heap = sexp_gc_packed_heap_make(state.sexps_size, heap_free_size);
+  if (!state.heap) {
+    res = sexp_global(ctx, SEXP_G_OOM_ERROR);
+    goto done; }
+
+  state.p     = sexp_heap_first_block(state.heap);
+  state.end   = sexp_heap_end(state.heap);
+  state.index = 0;
+  state.remap = malloc(sizeof(struct sexp_remap) * state.sexps_count);
+  if (!state.remap) {
+    res = sexp_global(ctx, SEXP_G_OOM_ERROR);
+    goto done; }
+  
+  if ((res = sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx),
+                               &state, NULL, NULL, sexp_callback_remap)) != SEXP_TRUE) {
+    goto done; }
+
+  sexp* types = sexp_context_types(state.ctx_src);
+  int idx;
+  for (idx = 0; idx < state.sexps_count; idx++) {
+    sexp dstp = state.remap[idx].dstp;
+    if ((res = sexp_gc_heap_pack_adjust(dstp, types, &state)) != SEXP_TRUE) {
+      goto done; }
+  }
+
+  res = state.ctx_dst;
+done:
+  if (state.remap) free(state.remap);
+  return res;
+}
+
+
+#define SEXP_IMAGE_MAGIC "\a\achibi\n\0"
+#define SEXP_IMAGE_MAJOR_VERSION 1
+#define SEXP_IMAGE_MINOR_VERSION 1
+
+struct sexp_image_header_t {
+  char magic[8];
+  short major, minor;
+  sexp_abi_identifier_t abi;
+  sexp_uint_t size;
+  sexp base;
+  sexp context;
+};
+
+
+sexp sexp_save_image (sexp ctx_in, const char* filename) {
+  sexp_heap heap = NULL;
+  sexp res = NULL;
+  FILE *fp = fopen(filename, "wb");
+  if (!fp) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Could not open image file for writing: %s", filename);
+    goto done;
+  }
+  
+  /* Save ONLY packed, active SEXPs.  No free list structures or padding. */
+  sexp ctx = sexp_gc_heap_pack(ctx_in, 0);
+  if (!ctx || !sexp_contextp(ctx)) {
+    goto done;
+  }
+  heap = sexp_context_heap(ctx);
+  sexp   base = sexp_heap_first_block(heap);
+  size_t pad  = (size_t)((char *)base - (char *)heap->data);
+  size_t size = heap->size - pad;
+  
+  struct sexp_image_header_t header;
+  memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
+  memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi));
+  header.major   = SEXP_IMAGE_MAJOR_VERSION;
+  header.minor   = SEXP_IMAGE_MINOR_VERSION;
+  header.size    = size;
+  header.base    = base;
+  header.context = ctx;
+
+  sexp_gc(ctx, NULL);
+  if (! (fwrite(&header, sizeof(header), 1, fp) == 1 &&
+         fwrite(base, size, 1, fp) == 1)) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "Error writing image file: %s", filename);
+    goto done;
+  }
+  
+  res = SEXP_TRUE;
+done:
+  if (fp) fclose(fp);
+  if (heap) sexp_free_heap(heap);
+  //if (res != SEXP_TRUE) res = sexp_user_exception(ctx_in, NULL, gc_heap_err_str, NULL);
+  return res;
+}
+
+
+
+#if SEXP_USE_DL
+
+#ifdef __APPLE__
+#define SEXP_RTLD_DEFAULT RTLD_SELF
+#else
+#define SEXP_RTLD_DEFAULT RTLD_DEFAULT
+#endif
+
+struct load_image_state {
+  sexp_sint_t offset;
+  sexp_heap heap;
+  sexp *types;
+  size_t types_cnt;
+};
+
+/* Return a destination (remapped) pointer for a given source pointer */
+static sexp load_image_src_to_dst(void* adata, sexp srcp) {
+  struct load_image_state* state = adata;
+  return (sexp)((char *)srcp + state->offset);
+}
+
+
+static sexp load_image_callback_p1 (sexp ctx, sexp p, void *user) {
+  sexp res = NULL;
+  struct load_image_state* state = user;
+
+  if ((res = sexp_adjust_fields(p, state->types, load_image_src_to_dst, state)) != SEXP_TRUE) {
+    goto done; }
+    
+  if (sexp_contextp(p)) {
+#if SEXP_USE_GREEN_THREADS
+    sexp_context_ip(p) += state->offset;
+#endif
+    sexp_context_last_fp(p) += state->offset;
+    sexp_stack_top(sexp_context_stack(p)) = 0;
+    sexp_context_saves(p) = NULL;
+    sexp_context_heap(p) = state->heap;
+  
+  } else if (sexp_bytecodep(p)) {
+    if ((res = sexp_adjust_bytecode(p, load_image_src_to_dst, state)) != SEXP_TRUE) {
+      goto done; }
+    
+  } else if (sexp_portp(p) && sexp_port_stream(p)) {
+    sexp_port_stream(p) = 0;
+    sexp_port_openp(p) = 0;
+    sexp_freep(p) = 0;
+    
+  } else if (sexp_dlp(p)) {
+    sexp_dl_handle(p) = NULL;
+
+  }
+  res = SEXP_TRUE;
+done:
+  return res;
+}
+
+static void* load_image_fn(sexp dl, sexp name) {
+  void *fn = NULL;
+  char *handle_name = "<static>";
+  char *symbol_name = sexp_string_data(name);
+  if (dl && sexp_dlp(dl)) {
+    if (!sexp_dl_handle(dl)) {
+      sexp_dl_handle(dl) = dlopen(sexp_string_data(sexp_dl_file(dl)),
+                                  RTLD_LAZY);
+      if (!sexp_dl_handle(dl)) {
+        handle_name = sexp_string_data(sexp_dl_file(dl));
+        snprintf(gc_heap_err_str, ERR_STR_SIZE, "dlopen failure: %s",
+                 handle_name);
+        return NULL;
+      }
+    }
+    fn = dlsym(sexp_dl_handle(dl), symbol_name);
+  } else {
+    fn = dlsym(SEXP_RTLD_DEFAULT, symbol_name);
+  }
+  if (!fn) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE,
+             "dynamic function lookup failure: %s %s",
+             handle_name, symbol_name);
+  }
+  return fn;
+}
+
+static sexp load_image_callback_p2 (sexp ctx, sexp dstp, void *user) {
+  sexp res = NULL;
+  sexp name = NULL;
+  void *fn = NULL;
+
+  if (sexp_opcodep(dstp) && sexp_opcode_func(dstp)) {
+    if (sexp_opcode_data2(dstp) && sexp_stringp(sexp_opcode_data2(dstp))) {
+      name = sexp_opcode_data2(dstp);
+    } else {
+      name = sexp_opcode_name(dstp);
+    }
+    if (!name) {
+      snprintf(gc_heap_err_str, ERR_STR_SIZE, "opcode func field missing function name");
+      return SEXP_FALSE;
+    }
+    
+    fn = load_image_fn(sexp_opcode_dl(dstp), name);
+    if (!fn) {
+      return SEXP_FALSE;
+    }
+    sexp_opcode_func(dstp) = fn;
+  
+  } else if (sexp_typep(dstp) && sexp_type_finalize(dstp)) {
+    name = sexp_type_finalize_name(dstp);
+    if (!name) {
+      snprintf(gc_heap_err_str, ERR_STR_SIZE, "type finalize field missing function name");
+      return SEXP_FALSE;
+    }
+    fn = load_image_fn(sexp_type_dl(dstp), name);
+    if (!fn) {
+      return SEXP_FALSE;
+    }
+    sexp_type_finalize(dstp) = fn;
+  }
+  res = SEXP_TRUE;
+  return res;
+}
+
+
+int load_image_header(FILE *fp, struct sexp_image_header_t* header) {
+  if (!fp || !header) { return 0; }
+  
+  if (fread(header, sizeof(struct sexp_image_header_t), 1, fp) != 1) {
+    strcpy(gc_heap_err_str, "couldn't read image header");
+    return 0;
+  }
+  if (memcmp(header->magic, SEXP_IMAGE_MAGIC, sizeof(header->magic)) != 0) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "invalid image file magic %s\n", header->magic);
+    return 0;
+  } else if (header->major != SEXP_IMAGE_MAJOR_VERSION
+             || header->major < SEXP_IMAGE_MINOR_VERSION) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported image version: %d.%d\n",
+             header->major, header->minor);
+    return 0;
+  } else if (!sexp_abi_compatible(NULL, header->abi, SEXP_ABI_IDENTIFIER)) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "unsupported ABI: %s (expected %s)\n",
+             header->abi, SEXP_ABI_IDENTIFIER);
+    return 0;
+  }
+  return 1;
+}
+
+char* sexp_load_image_err() {
+  gc_heap_err_str[ERR_STR_SIZE-1] = 0;
+  return gc_heap_err_str;
+}
+
+sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) {
+  sexp res = NULL;
+  sexp ctx = NULL;
+  gc_heap_err_str[0] = 0;
+
+  struct load_image_state state;
+  memset(&state, 0, sizeof(struct load_image_state));
+  
+  FILE *fp = fopen(filename, "rb");
+  if (!fp) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't open image file for reading: %s\n", filename);
+    goto done;
+  }
+  
+  struct sexp_image_header_t header;
+  if (!load_image_header(fp, &header)) { goto done; }
+  
+  state.heap = sexp_gc_packed_heap_make(header.size, heap_free_size);
+  if (!state.heap) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "couldn't malloc heap\n");
+    goto done;
+  }
+  sexp base = sexp_heap_first_block(state.heap);
+
+  if (fread(base, header.size, 1, fp) != 1) {
+    snprintf(gc_heap_err_str, ERR_STR_SIZE, "error reading image\n");
+    goto done;
+  }
+
+  /* Adjust pointers in loaded packed heap. */
+  
+  state.offset = (sexp_sint_t)((sexp_sint_t)base - (sexp_sint_t)header.base);
+  ctx = (sexp)((char *)header.context + state.offset);
+  sexp_context_heap(ctx) = state.heap;
+
+  /* Type information (specifically, how big types are) is stored as sexps in the
+     heap.  This information is needed to sucessfully walk an arbitrary heap.  A
+     copy of the type array pointers with correct offsets is applied is created outside
+     of the new heap to be used with the pointer adjustment process.
+  */
+  sexp* ctx_globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + state.offset));
+  sexp* ctx_types   = sexp_vector_data((sexp)((char*)(ctx_globals[SEXP_G_TYPES]) + state.offset));
+  state.types_cnt   = sexp_unbox_fixnum(ctx_globals[SEXP_G_NUM_TYPES]);
+  state.types = malloc(sizeof(sexp) * state.types_cnt);
+  if (!state.types) goto done;
+  int i;
+  for (i = 0; i < state.types_cnt; i++) {
+    state.types[i] = (sexp)((char *)ctx_types[i] + state.offset);
+  }
+  
+  if (sexp_gc_heap_walk(ctx, state.types, state.types_cnt,
+                        &state, NULL, NULL, load_image_callback_p1) != SEXP_TRUE) {
+    goto done; }
+
+  /* Second pass to fix code references */
+  if (sexp_gc_heap_walk(ctx, state.types, state.types_cnt,
+                        &state, NULL, NULL, load_image_callback_p2) != SEXP_TRUE) {
+    goto done; }
+
+  if (heap_max_size > SEXP_INITIAL_HEAP_SIZE) {
+    sexp_context_heap(ctx)->max_size = heap_max_size;
+  }
+  
+  res = ctx;
+done:
+  if (fp) fclose(fp);
+  if (state.heap && !ctx) free(state.heap);
+  if (state.types) free(state.types);
+  return res;
+}
+
+#else
+
+sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size) {
+  return NULL;
+}
+
+#endif
+
+
+
+
+/****************** Debugging ************************/
+
+#define SEXP_CORE_TYPES_MAX 255
+
+struct sexp_stats_entry {
+  size_t count;
+  size_t size_all;
+  size_t size_min;
+  size_t size_max;
+};
+
+struct sexp_stats {
+  struct sexp_stats_entry sexps[SEXP_CORE_TYPES_MAX+1];
+  struct sexp_stats_entry heaps;
+  struct sexp_stats_entry frees;
+  size_t sexp_count;
+};
+
+static void sexp_stats_entry_set(struct sexp_stats_entry *entry, size_t value) {
+  entry->count += 1;
+  entry->size_all += value;
+  if (entry->size_min == 0 || value < entry->size_min) entry->size_min = value;
+  if (value > entry->size_max) entry->size_max = value;
+}
+
+static sexp heap_stats_callback(sexp ctx, sexp_heap h, void *user) {
+  struct sexp_stats *stats = user;
+  sexp_stats_entry_set(&(stats->heaps), h->size);
+  return SEXP_TRUE;
+}
+
+static sexp free_stats_callback(sexp ctx, sexp_free_list f, void *user) {
+  struct sexp_stats *stats = user;
+  sexp_stats_entry_set(&(stats->frees), f->size);
+  return SEXP_TRUE;
+}
+
+static sexp sexp_stats_callback(sexp ctx, sexp s, void *user) {
+  struct sexp_stats *stats = user;
+  int tag = sexp_pointer_tag(s);
+  size_t size = sexp_heap_align(sexp_gc_allocated_bytes(ctx, sexp_context_types(ctx),
+                                                        sexp_context_num_types(ctx), s));
+  if (tag > SEXP_CORE_TYPES_MAX) tag = SEXP_CORE_TYPES_MAX;
+  sexp_stats_entry_set(&(stats->sexps[tag]), size);
+  stats->sexp_count += 1;
+  return SEXP_TRUE;
+}
+
+void sexp_gc_heap_stats_print(sexp ctx)
+{
+  if (!ctx || !sexp_contextp(ctx)) return;
+  
+  struct sexp_stats stats;
+  memset(&stats, 0, sizeof(struct sexp_stats));
+  sexp_gc_heap_walk(ctx, sexp_context_types(ctx), sexp_context_num_types(ctx),
+                    &stats, heap_stats_callback, free_stats_callback, sexp_stats_callback);
+  
+  printf("Heap Stats\n    %6zu %7zu\n",
+         stats.heaps.count, stats.heaps.size_all);
+  printf("Free Stats\n    %6zu %7zu %5zu %5zu\n",
+         stats.frees.count, stats.frees.size_all, stats.frees.size_min, stats.frees.size_max);
+  printf("Sexp Stats\n");
+  size_t total_count = 0;
+  size_t total_size = 0;
+  int i;
+  for (i = 0; i <= SEXP_CORE_TYPES_MAX; i++) {
+    if (stats.sexps[i].count == 0) continue;
+    printf("%3d %6zu %7zu %5zu %5zu\n", i,
+           stats.sexps[i].count, stats.sexps[i].size_all, stats.sexps[i].size_min, stats.sexps[i].size_max);
+    total_count += stats.sexps[i].count;
+    total_size  += stats.sexps[i].size_all;
+  }
+  printf(" ========================================\n");
+  printf("    %6zu %7zu\n", total_count, total_size);
+}
+
+

gc_heap.h

@@ -0,0 +1,98 @@
+/* gc_heap.h -- heap packing, run-time image generation    */
+/* Copyright (c) 2016 Chris Walsh.  All rights reserved.   */
+/* BSD-style license: http://synthcode.com/license.txt     */
+
+#ifndef GC_HEAP_H
+#define GC_HEAP_H
+
+#include "chibi/sexp.h"
+
+/* Iterate the heap associated with the context argument 'ctx',
+   calling user provided callbacks for the individual heap elements.
+   
+   For each heap found, heap_callback is called.
+   For each free segment found, free_callback is called.
+   For each valid sexp found, sexp_callback is called.
+     
+   Callbacks are skipped if the associated function
+   pointer argument is NULL.
+
+   A callback return value of SEXP_TRUE allows the heap walk to 
+   continue normally.  Any other value terminates the heap walk
+   with the callback result being returned.
+ 
+   The sexp_gc_heap_walk return value of SEXP_TRUE indicates all
+   elements of the heap were walked normally.  Any other return 
+   value indicates an abnormal return condition.
+*/
+sexp sexp_gc_heap_walk(sexp ctx,         /* a possibly incomplete context */
+                       sexp *types,      /* normally set to sexp_context_types(ctx) */
+                       size_t types_cnt, /* normally set to sexp_context_num_types(ctx) */
+                       void *user,   /* arbitrary data passed to callbacks */
+                       sexp (*heap_callback)(sexp ctx, sexp_heap h, void *user),
+                       sexp (*free_callback)(sexp ctx, sexp_free_list f, void *user),
+                       sexp (*sexp_callback)(sexp ctx, sexp s, void *user));
+
+
+/* Returns a new context which contains a single, packed heap.
+   
+   The original ctx or heap are not altered, leaving two copies
+   of all sexps.  For runtime use where you are packing the heap
+   to make accesses more efficient, the old heap and context should
+   be discarded after a sucessful call to heap pack; finalizers do
+   not need to be called since all active objects are in the new heap.
+ 
+   The input heap_size specifies the amount of free space to allocate
+   at the end of the packed heap.  A heap_size of zero will produce a
+   single packed heap just large enough to hold all sexps from the
+   original heap.
+*/
+sexp sexp_gc_heap_pack(sexp ctx, sexp_uint_t heap_free_size);
+
+
+/* Creates a new packed heap from the provided context, and saves
+   the contents of the packed heap to the file named filename.
+
+   If sucessful, SEXP_TRUE is returned.  If a problem was encountered
+   in either creating the packed heap or saving to a file, then either
+   SEXP_FALSE or an exception is returned.  Because of shared code with
+   sexp_load_image, sexp_load_image_err() can also be used to return the
+   error condition.
+
+   In all cases, upon completion the temporary packed context is deleted 
+   and the context provided as an argument is not changed.
+*/
+sexp sexp_save_image (sexp ctx, const char* filename);
+
+
+/* Loads a previously saved image, and returns the context associated with
+   that image.  If the context could not be loaded, either NULL or an exception
+   are returned instead.
+
+   A new context is created with the contents of filename loaded into the
+   heap.  The heap_free_size parameter specifies the size of the heap to be
+   created in addition to the heap image on disk.  A size of zero will
+   result in an initial heap exactly the size of the disk image which will
+   be expanded with an additional heap when the system requests storage space.
+ 
+   The return value is either the context of the loaded image, or NULL.  In
+   the case of a NULL context, the function sexp_load_image_err() can be called
+   to provide a description of the error encountered.  An sexp exception cannot be
+   returned because there is not a valid context in which to put the exception.
+*/
+sexp sexp_load_image (const char* filename, sexp_uint_t heap_free_size, sexp_uint_t heap_max_size);
+
+
+/* In the case that sexp_load_image() returns NULL, this function will return
+   a string containing a description of the error condition.
+*/
+char* sexp_load_image_err();
+
+
+/* Debugging tool.  Prints a summary of the heap structure to stdout.
+ */
+void sexp_gc_heap_stats_print(sexp ctx);
+
+
+#endif
+

include/chibi/eval.h

@@ -129,7 +129,7 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from
 SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
 SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
 SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
-SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
 #if SEXP_USE_AUTO_FORCE
 SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
@@ -189,10 +189,11 @@ SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch);
 #endif
 
-#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
+SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name, int num_args, const char *fname, sexp_proc1 f, const char *param);
-#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
 
-SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_args, sexp_proc1 f, const char *param);
+#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
+#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
+#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
 
 #define sexp_env_key(x) sexp_car(x)
 #define sexp_env_value(x) sexp_cdr(x)

include/chibi/features.h

@@ -743,6 +743,11 @@
 #define isinf(x) (isInf(x,1) || isInf(x,-1))
 #define isnan(x) isNaN(x)
 #elif defined(_WIN32)
+#define _CRT_SECURE_NO_WARNINGS 1
+#define _CRT_NONSTDC_NO_DEPRECATE 1
+#pragma warning(disable:4146) /* unary minus operator to unsigned type */
+#define strcasecmp lstrcmpi
+#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2)
 #ifdef __MINGW32__
 #include <shlwapi.h>
 #define strcasestr StrStrI

include/chibi/sexp-huff.h

@@ -1,3 +1,4 @@
+static struct sexp_huff_entry huff_table[] = {
  {12, 0x0C00},   /* '\x00' */
  {15, 0x0000},   /* '\x01' */
  {15, 0x4000},   /* '\x02' */
@@ -125,4 +126,5 @@
  {14, 0x0E00},   /* '|'   */
  {14, 0x2E00},   /* '}'   */
  {14, 0x1E00},   /* '~'   */
- {14, 0x3E00},   /* '\x7f' */
+ {14, 0x3E00}    /* '\x7f' */
+};

include/chibi/sexp.h

@@ -324,7 +324,7 @@ struct sexp_type_struct {
   unsigned short size_scale;
   short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra;
   short depth;
-  sexp name, cpl, slots, getters, setters, id, print, dl;
+  sexp name, cpl, slots, getters, setters, id, print, dl, finalize_name;
   sexp_proc2 finalize;
 };
 
@@ -1234,6 +1234,7 @@ SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
 #define sexp_type_getters(x)           (sexp_field(x, type, SEXP_TYPE, getters))
 #define sexp_type_setters(x)           (sexp_field(x, type, SEXP_TYPE, setters))
 #define sexp_type_finalize(x)          (sexp_field(x, type, SEXP_TYPE, finalize))
+#define sexp_type_finalize_name(x)     (sexp_field(x, type, SEXP_TYPE, finalize_name))
 #define sexp_type_print(x)             (sexp_field(x, type, SEXP_TYPE, print))
 #define sexp_type_dl(x)                (sexp_field(x, type, SEXP_TYPE, dl))
 #define sexp_type_id(x)                (sexp_field(x, type, SEXP_TYPE, id))
@@ -1380,17 +1381,23 @@ SEXP_API int sexp_buffered_flush (sexp ctx, sexp p, int forcep);
 
 #if SEXP_USE_AUTOCLOSE_PORTS
 #define SEXP_FINALIZE_PORT sexp_finalize_port
+#define SEXP_FINALIZE_PORTN (sexp)"sexp_finalize_port"
 #define SEXP_FINALIZE_FILENO sexp_finalize_fileno
+#define SEXP_FINALIZE_FILENON (sexp)"sexp_finalize_fileno"
 #else
 #define SEXP_FINALIZE_PORT NULL
+#define SEXP_FINALIZE_PORTN NULL
 #define SEXP_FINALIZE_FILENO NULL
+#define SEXP_FINALIZE_FILENON NULL
 #endif
 
 #if SEXP_USE_DL
 sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl);
 #define SEXP_FINALIZE_DL sexp_finalize_dl
+#define SEXP_FINALIZE_DLN (sexp)"sexp_finalize_dl"
 #else
 #define SEXP_FINALIZE_DL NULL
+#define SEXP_FINALIZE_DLN NULL
 #endif
 
 #if SEXP_USE_TRACK_ALLOC_SOURCE
@@ -1485,7 +1492,7 @@ SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
 SEXP_API sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y);
 SEXP_API sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args);
 SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args);
-SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
+SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
 SEXP_API void sexp_init(void);
 
 #if SEXP_USE_UTF8_STRINGS
@@ -1559,7 +1566,7 @@ SEXP_API sexp sexp_finalize (sexp ctx);
 #define sexp_destroy_context(ctx)
 #else
 SEXP_API void sexp_free_heap (sexp_heap heap);
-SEXP_API void sexp_destroy_context (sexp ctx);
+SEXP_API sexp sexp_destroy_context (sexp ctx);
 SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags);
 #endif
 
@@ -1576,7 +1583,7 @@ SEXP_API int sexp_valid_object_p(sexp ctx, sexp x);
 #endif
 
 #if SEXP_USE_TYPE_DEFS
-SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
+SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, const char*, sexp_proc2);
 SEXP_API sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots);
 SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj);
 #define sexp_register_c_type(ctx, name, finalizer)                      \
@@ -1585,7 +1592,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj
                      sexp_make_fixnum(sexp_sizeof(cpointer)),           \
                      SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,        \
                      SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL,             \
-                     (sexp_proc2)finalizer)
+                     #finalizer, (sexp_proc2)finalizer)
 #endif
 
 #define sexp_current_input_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE))
@@ -1630,7 +1637,7 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx, NULL, 1, out)
 #define sexp_expt(ctx, a, b) sexp_expt_op(ctx, NULL, 2, a, b)
 #define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx, NULL, 3, a, b, c)
-#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s)
+#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, sn, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, sn, s)
 #define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx, NULL, 2, a, b)
 #define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx, NULL, 2, a, b)
 #define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx, NULL, 3, a, b, c)
@@ -1639,87 +1646,87 @@ SEXP_API int sexp_poll_port(sexp ctx, sexp port, int inputp);
 #define sexp_make_fileno(ctx, fd, no_closep) sexp_make_fileno_op(ctx, NULL, 2, fd, no_closep)
 
 enum sexp_opcode_names {
-  SEXP_OP_NOOP,
+  /*  0 00 */ SEXP_OP_NOOP,
-  SEXP_OP_RAISE,
+  /*  1 01 */ SEXP_OP_RAISE,
-  SEXP_OP_RESUMECC,
+  /*  2 02 */ SEXP_OP_RESUMECC,
-  SEXP_OP_CALLCC,
+  /*  3 03 */ SEXP_OP_CALLCC,
-  SEXP_OP_APPLY1,
+  /*  4 04 */ SEXP_OP_APPLY1,
-  SEXP_OP_TAIL_CALL,
+  /*  5 05 */ SEXP_OP_TAIL_CALL,
-  SEXP_OP_CALL,
+  /*  6 06 */ SEXP_OP_CALL,
-  SEXP_OP_FCALL0,
+  /*  7 07 */ SEXP_OP_FCALL0,
-  SEXP_OP_FCALL1,
+  /*  8 08 */ SEXP_OP_FCALL1,
-  SEXP_OP_FCALL2,
+  /*  9 09 */ SEXP_OP_FCALL2,
-  SEXP_OP_FCALL3,
+  /* 10 0A */ SEXP_OP_FCALL3,
-  SEXP_OP_FCALL4,
+  /* 11 0B */ SEXP_OP_FCALL4,
-  SEXP_OP_FCALLN,
+  /* 12 0C */ SEXP_OP_FCALLN,
-  SEXP_OP_JUMP_UNLESS,
+  /* 13 0D */ SEXP_OP_JUMP_UNLESS,
-  SEXP_OP_JUMP,
+  /* 14 0E */ SEXP_OP_JUMP,
-  SEXP_OP_PUSH,
+  /* 15 0F */ SEXP_OP_PUSH,
-  SEXP_OP_RESERVE,
+  /* 16 10 */ SEXP_OP_RESERVE,
-  SEXP_OP_DROP,
+  /* 17 11 */ SEXP_OP_DROP,
-  SEXP_OP_GLOBAL_REF,
+  /* 18 12 */ SEXP_OP_GLOBAL_REF,
-  SEXP_OP_GLOBAL_KNOWN_REF,
+  /* 19 13 */ SEXP_OP_GLOBAL_KNOWN_REF,
-  SEXP_OP_PARAMETER_REF,
+  /* 20 14 */ SEXP_OP_PARAMETER_REF,
-  SEXP_OP_STACK_REF,
+  /* 21 15 */ SEXP_OP_STACK_REF,
-  SEXP_OP_LOCAL_REF,
+  /* 22 16 */ SEXP_OP_LOCAL_REF,
-  SEXP_OP_LOCAL_SET,
+  /* 23 17 */ SEXP_OP_LOCAL_SET,
-  SEXP_OP_CLOSURE_REF,
+  /* 24 18 */ SEXP_OP_CLOSURE_REF,
-  SEXP_OP_CLOSURE_VARS,
+  /* 25 19 */ SEXP_OP_CLOSURE_VARS,
-  SEXP_OP_VECTOR_REF,
+  /* 26 1A */ SEXP_OP_VECTOR_REF,
-  SEXP_OP_VECTOR_SET,
+  /* 27 1B */ SEXP_OP_VECTOR_SET,
-  SEXP_OP_VECTOR_LENGTH,
+  /* 28 1C */ SEXP_OP_VECTOR_LENGTH,
-  SEXP_OP_BYTES_REF,
+  /* 29 1D */ SEXP_OP_BYTES_REF,
-  SEXP_OP_BYTES_SET,
+  /* 30 1E */ SEXP_OP_BYTES_SET,
-  SEXP_OP_BYTES_LENGTH,
+  /* 31 1F */ SEXP_OP_BYTES_LENGTH,
-  SEXP_OP_STRING_REF,
+  /* 32 20 */ SEXP_OP_STRING_REF,
-  SEXP_OP_STRING_SET,
+  /* 33 21 */ SEXP_OP_STRING_SET,
-  SEXP_OP_STRING_LENGTH,
+  /* 34 22 */ SEXP_OP_STRING_LENGTH,
-  SEXP_OP_STRING_CURSOR_NEXT,
+  /* 35 23 */ SEXP_OP_STRING_CURSOR_NEXT,
-  SEXP_OP_STRING_CURSOR_PREV,
+  /* 36 24 */ SEXP_OP_STRING_CURSOR_PREV,
-  SEXP_OP_STRING_SIZE,
+  /* 37 25 */ SEXP_OP_STRING_SIZE,
-  SEXP_OP_MAKE_PROCEDURE,
+  /* 38 26 */ SEXP_OP_MAKE_PROCEDURE,
-  SEXP_OP_MAKE_VECTOR,
+  /* 39 27 */ SEXP_OP_MAKE_VECTOR,
-  SEXP_OP_MAKE_EXCEPTION,
+  /* 40 28 */ SEXP_OP_MAKE_EXCEPTION,
-  SEXP_OP_AND,
+  /* 41 29 */ SEXP_OP_AND,
-  SEXP_OP_NULLP,
+  /* 42 2A */ SEXP_OP_NULLP,
-  SEXP_OP_FIXNUMP,
+  /* 43 2B */ SEXP_OP_FIXNUMP,
-  SEXP_OP_SYMBOLP,
+  /* 44 2C */ SEXP_OP_SYMBOLP,
-  SEXP_OP_CHARP,
+  /* 45 2D */ SEXP_OP_CHARP,
-  SEXP_OP_EOFP,
+  /* 46 2E */ SEXP_OP_EOFP,
-  SEXP_OP_TYPEP,
+  /* 47 2F */ SEXP_OP_TYPEP,
-  SEXP_OP_MAKE,
+  /* 48 30 */ SEXP_OP_MAKE,
-  SEXP_OP_SLOT_REF,
+  /* 49 31 */ SEXP_OP_SLOT_REF,
-  SEXP_OP_SLOT_SET,
+  /* 50 32 */ SEXP_OP_SLOT_SET,
-  SEXP_OP_ISA,
+  /* 51 33 */ SEXP_OP_ISA,
-  SEXP_OP_SLOTN_REF,
+  /* 52 34 */ SEXP_OP_SLOTN_REF,
-  SEXP_OP_SLOTN_SET,
+  /* 53 35 */ SEXP_OP_SLOTN_SET,
-  SEXP_OP_CAR,
+  /* 54 36 */ SEXP_OP_CAR,
-  SEXP_OP_CDR,
+  /* 55 37 */ SEXP_OP_CDR,
-  SEXP_OP_SET_CAR,
+  /* 56 38 */ SEXP_OP_SET_CAR,
-  SEXP_OP_SET_CDR,
+  /* 57 39 */ SEXP_OP_SET_CDR,
-  SEXP_OP_CONS,
+  /* 58 3A */ SEXP_OP_CONS,
-  SEXP_OP_ADD,
+  /* 59 3B */ SEXP_OP_ADD,
-  SEXP_OP_SUB,
+  /* 60 3C */ SEXP_OP_SUB,
-  SEXP_OP_MUL,
+  /* 61 3D */ SEXP_OP_MUL,
-  SEXP_OP_DIV,
+  /* 62 3E */ SEXP_OP_DIV,
-  SEXP_OP_QUOTIENT,
+  /* 63 3F */ SEXP_OP_QUOTIENT,
-  SEXP_OP_REMAINDER,
+  /* 64 40 */ SEXP_OP_REMAINDER,
-  SEXP_OP_LT,
+  /* 65 41 */ SEXP_OP_LT,
-  SEXP_OP_LE,
+  /* 66 42 */ SEXP_OP_LE,
-  SEXP_OP_EQN,
+  /* 67 43 */ SEXP_OP_EQN,
-  SEXP_OP_EQ,
+  /* 68 44 */ SEXP_OP_EQ,
-  SEXP_OP_CHAR2INT,
+  /* 69 45 */ SEXP_OP_CHAR2INT,
-  SEXP_OP_INT2CHAR,
+  /* 70 46 */ SEXP_OP_INT2CHAR,
-  SEXP_OP_CHAR_UPCASE,
+  /* 71 47 */ SEXP_OP_CHAR_UPCASE,
-  SEXP_OP_CHAR_DOWNCASE,
+  /* 72 48 */ SEXP_OP_CHAR_DOWNCASE,
-  SEXP_OP_WRITE_CHAR,
+  /* 73 49 */ SEXP_OP_WRITE_CHAR,
-  SEXP_OP_WRITE_STRING,
+  /* 74 4A */ SEXP_OP_WRITE_STRING,
-  SEXP_OP_READ_CHAR,
+  /* 75 4B */ SEXP_OP_READ_CHAR,
-  SEXP_OP_PEEK_CHAR,
+  /* 76 4C */ SEXP_OP_PEEK_CHAR,
-  SEXP_OP_YIELD,
+  /* 77 4D */ SEXP_OP_YIELD,
-  SEXP_OP_FORCE,
+  /* 78 4E */ SEXP_OP_FORCE,
-  SEXP_OP_RET,
+  /* 79 4F */ SEXP_OP_RET,
-  SEXP_OP_DONE,
+  /* 80 50 */ SEXP_OP_DONE,
   SEXP_OP_NUM_OPCODES
 };
 

lib/chibi/ast.c

@@ -8,6 +8,23 @@
 #include <errno.h>
 #endif
 
+#ifdef _WIN32
+int setenv(const char *name, const char *value, int overwrite)
+{
+  int errcode = 0;
+  if (!overwrite) {
+    size_t envsize = 0;
+    errcode = getenv_s(&envsize, NULL, 0, name);
+    if (errcode || envsize) return errcode;
+  }
+  return _putenv_s(name, value);
+}
+int unsetenv(const char *name)
+{
+  return setenv(name, "", 1);
+}
+#endif
+
 #if ! SEXP_USE_BOEHM
 extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
 #endif
@@ -40,7 +57,7 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
   sexp_gc_release2(ctx);
 }
 
-static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
+sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp id, sexp createp) {
   sexp cell;
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   cell = sexp_env_cell(ctx, env, id, 0);
@@ -56,27 +73,27 @@ static sexp sexp_get_env_cell (sexp ctx, sexp self, sexp_sint_t n, sexp env, sex
   return cell ? cell : SEXP_FALSE;
 }
 
-static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_code(proc);
 }
 
-static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_procedure_vars(proc);
 }
 
-static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_make_fixnum(sexp_procedure_num_args(proc));
 }
 
-static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
   return sexp_make_boolean(sexp_procedure_variadic_p(proc));
 }
 
-static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   if (! sexp_opcodep(op))
     return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
   else if (! sexp_opcode_name(op))
@@ -103,7 +120,7 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
   return res;
 }
 
-static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp res;
   if (!op)
     return sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -117,7 +134,7 @@ static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp o
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
+sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) {
   sexp res;
   int p = sexp_unbox_fixnum(k);
   if (! sexp_opcodep(op))
@@ -136,7 +153,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   default:
     res = sexp_opcode_arg3_type(op);
     if (res && sexp_vectorp(res)) {
-      if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
+      if (sexp_vector_length(res) > (unsigned)(sexp_unbox_fixnum(k)-2))
         res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
       else
         res = sexp_type_by_index(ctx, SEXP_OBJECT);
@@ -146,17 +163,17 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   return sexp_translate_opcode_type(ctx, res);
 }
 
-static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_class(op));
 }
 
-static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_code(op));
 }
 
-static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp data;
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   data = sexp_opcode_data(op);
@@ -167,29 +184,29 @@ static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
     sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
 }
 
-static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_num_args(op));
 }
 
-static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_boolean(sexp_opcode_variadic_p(op));
 }
 
-static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
+sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   return sexp_make_fixnum(sexp_port_line(p));
 }
 
-static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
+sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) {
   sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   sexp_port_line(p) = sexp_unbox_fixnum(i);
   return SEXP_VOID;
 }
 
-static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   if (!x)
     return sexp_type_by_index(ctx, SEXP_OBJECT);
   if (sexp_pointerp(x))
@@ -212,43 +229,43 @@ static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
     return sexp_type_by_index(ctx, SEXP_OBJECT);
 }
 
-static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
+sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp e2) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e1);
   if (sexp_truep(e2)) sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e2);
   sexp_env_parent(e1) = e2;
   return SEXP_VOID;
 }
 
-static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE;
 }
 
-static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
+sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam);
   sexp_env_lambda(e) = lam;
   return SEXP_VOID;
 }
 
-static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
+sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   return sexp_make_boolean(sexp_env_syntactic_p(e));
 }
 
-static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
+sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e);
   sexp_env_syntactic_p(e) = sexp_truep(synp);
   return SEXP_VOID;
 }
 
-static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
   return sexp_env_cell_define(ctx, env, name, value, NULL);
 }
 
-static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
+sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) {
   sexp_gc_var1(tmp);
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name);
@@ -258,38 +275,38 @@ static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp
   return SEXP_VOID;
 }
 
-static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
+sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) {
   sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c);
   return sexp_make_fixnum(sexp_core_code(c));
 }
 
-static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_name(t);
 }
 
-static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_cpl(t);
 }
 
-static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_slots(t);
 }
 
-static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t))
     : sexp_make_fixnum(sexp_type_field_eq_len_base(t));
 }
 
-static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
+sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) {
   sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t);
   return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE;
 }
 
-static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp t;
   if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
     return SEXP_ZERO;
@@ -297,7 +314,7 @@ static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_make_fixnum(sexp_type_size_of_object(t, x));
 }
 
-static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
+sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) {
   sexp x = (sexp)sexp_unbox_fixnum(i);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i);
   if (!x || sexp_pointerp(x))
@@ -305,11 +322,11 @@ static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp
   return x;
 }
 
-static sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_object_to_integer (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_make_integer(ctx, (sexp_uint_t)x);
 }
 
-static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
+sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = name;
   sexp_lambda_params(res) = params;
@@ -323,7 +340,7 @@ static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
   return res;
 }
 
-static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
+sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA);
   sexp_lambda_name(res) = sexp_lambda_name(lambda);
   sexp_lambda_params(res) = sexp_lambda_params(lambda);
@@ -337,21 +354,21 @@ static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) {
   return res;
 }
 
-static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
+sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) {
   sexp res = sexp_alloc_type(ctx, set, SEXP_SET);
   sexp_set_var(res) = var;
   sexp_set_value(res) = value;
   return res;
 }
 
-static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
+sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) {
   sexp res = sexp_alloc_type(ctx, ref, SEXP_REF);
   sexp_ref_name(res) = name;
   sexp_ref_cell(res) = cell;
   return res;
 }
 
-static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
+sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) {
   sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND);
   sexp_cnd_test(res) = test;
   sexp_cnd_pass(res) = pass;
@@ -359,26 +376,26 @@ static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sex
   return res;
 }
 
-static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
+sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) {
   sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
   sexp_seq_ls(res) = ls;
   return res;
 }
 
-static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT);
   sexp_lit_value(res) = value;
   return res;
 }
 
-static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
+sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) {
   sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO);
   sexp_macro_proc(res) = proc;
   sexp_macro_env(res) = env;
   return res;
 }
 
-static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
+sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) {
   sexp ctx2 = ctx;
   if (sexp_envp(e)) {
     ctx2 = sexp_make_child_context(ctx, NULL);
@@ -387,12 +404,12 @@ static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e)
   return sexp_analyze(ctx2, x);
 }
 
-static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
+sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) {
   sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env);
   return sexp_extend_env(ctx, env, vars, value);
 }
 
-static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp_gc_var2(ls, res);
   sexp_gc_preserve2(ctx, ls, res);
   res = x;
@@ -404,7 +421,7 @@ static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return res;
 }
 
-static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   size_t sum_freed=0;
 #if SEXP_USE_BOEHM
   GC_gcollect();
@@ -414,16 +431,16 @@ static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sum_freed);
 }
 
-static sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_gc_count_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sexp_context_gc_count(ctx));
 }
 
-static sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_gc_usecs_op (sexp ctx, sexp self, sexp_sint_t n) {
   return sexp_make_unsigned_integer(ctx, sexp_context_gc_usecs(ctx));
 }
 
 #if SEXP_USE_GREEN_THREADS
-static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
+sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
   sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P);
   sexp_global(ctx, SEXP_G_ATOMIC_P) = new_val;
   return res;
@@ -431,11 +448,11 @@ static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new_val) {
 #endif
 
 sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
-  sexp ls;
   sexp_gc_var1(res);
   sexp_gc_preserve1(ctx, res);
   res = SEXP_NULL;
 #if SEXP_USE_GREEN_THREADS
+  sexp ls;
   for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
     sexp_push(ctx, res, sexp_car(ls));
   for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
@@ -446,7 +463,7 @@ sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
   return res;
 }
 
-static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   const char *res;
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y);
@@ -454,7 +471,7 @@ static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, se
   return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE;
 }
 
-static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
+sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) {
   unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p;
   sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst),
     start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send);
@@ -465,9 +482,9 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send);
   if (from < 0 || from > to)
     return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom);
-  if (start < 0 || start > sexp_string_size(src))
+  if (start < 0 || start > (sexp_sint_t)sexp_string_size(src))
     return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart);
-  if (end < start || end > sexp_string_size(src))
+  if (end < start || end > (sexp_sint_t)sexp_string_size(src))
     return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send);
   pfrom = (unsigned char*)sexp_string_data(dst) + from;
   pto = (unsigned char*)sexp_string_data(dst) + to;
@@ -485,7 +502,7 @@ static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp ds
   return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src));
 }
 
-static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
 #ifdef PLAN9
   return SEXP_FALSE;
 #else
@@ -493,7 +510,7 @@ static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) {
 #endif
 }
 
-static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #ifdef PLAN9
   return SEXP_FALSE;
 #else
@@ -508,22 +525,22 @@ static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
 #endif
 }
 
-static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   return sexp_free_vars(ctx, x, SEXP_NULL);
 }
 
-static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
+sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) {
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value);
   return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1));
 }
 
-static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
+sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) {
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name);
   return sexp_make_boolean(unsetenv(sexp_string_data(name)));
 }
 
-static sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
+sexp sexp_abort (sexp ctx, sexp self, sexp_sint_t n, sexp value) {
   sexp res = sexp_make_trampoline(ctx, SEXP_FALSE, value);
   sexp_exception_message(res) = SEXP_TRAMPOLINE;
   return res;

lib/chibi/disasm.c

@@ -80,12 +80,12 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   /* build a table of labels that are jumped to */
   labels = (sexp_sint_t*)calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t));
   ip = sexp_bytecode_data(bc);
-  while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) {
+  while (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc)) {
     switch (*ip++) {
     case SEXP_OP_JUMP:
     case SEXP_OP_JUMP_UNLESS:
       off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
-      if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0)
+      if (off >= 0 && off < (int)sexp_bytecode_length(bc) && labels[off] == 0)
         labels[off] = label++;
     case SEXP_OP_CALL:
     case SEXP_OP_CLOSURE_REF:
@@ -134,7 +134,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
           == sexp_unbox_fixnum(
                sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) {
     src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off)));
-    src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1;
+    src_off = src_off < (sexp_sint_t)sexp_vector_length(src)-1 ? src_off + 1 : -1;
   } else {
     src_here = NULL;
   }
@@ -163,7 +163,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   case SEXP_OP_JUMP_UNLESS:
     sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out);
     off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0];
-    if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) {
+    if (off >= 0 && off < (sexp_sint_t)sexp_bytecode_length(bc) && labels[off] > 0) {
       sexp_write_string(ctx, " L", out);
       sexp_write_integer(ctx, labels[off], out);
     }
@@ -224,7 +224,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
       && (depth < SEXP_DISASM_MAX_DEPTH)
       && tmp && (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
     disasm(ctx, self, tmp, out, depth+1);
-  if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
+  if (ip - sexp_bytecode_data(bc) < (int)sexp_bytecode_length(bc))
     goto loop;
 
   free(labels);

lib/chibi/heap-stats.c

@@ -49,12 +49,12 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
     sexp_write_char(ctx, ')', out);
   } else if (sexp_vectorp(x)) {
     sexp_write_string(ctx, "#(", out);
-    for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<sexp_vector_length(x); i++) {
+    for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) {
       if (i>0)
         sexp_write_char(ctx, ' ', out);
       sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
     }
-    if (i<sexp_vector_length(x))
+    if (i<(int)sexp_vector_length(x))
       sexp_write_string(ctx, " ...", out);
     sexp_write_char(ctx, ')', out);
   } else {
@@ -185,19 +185,19 @@ static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
 
 #else
 
-static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
   return SEXP_NULL;
 }
 
-static sexp sexp_heap_sizes (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_heap_sizes (sexp ctx, sexp self, sexp_sint_t n) {
   return SEXP_NULL;
 }
 
-static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
+sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) {
   return SEXP_NULL;
 }
 
-static sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_free_sizes (sexp ctx, sexp self, sexp_sint_t n) {
   return SEXP_NULL;
 }
 

lib/scheme/time.c

@@ -65,7 +65,7 @@ static void current_ntp_clock_values (double *second, int *leap_second_indicator
   }
 }
 
-static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
   double second;
   int leap_second_indicator;
   sexp_gc_var3(res, car, cdr);
@@ -80,7 +80,7 @@ static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
 
 #endif  /* def SEXP_USE_NTP_GETTIME */
 
-static sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
 #ifndef PLAN9
   struct timeval tv;
   struct timezone tz;

lib/srfi/18/threads.c

@@ -332,7 +332,7 @@ static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) {
   return sexp_log2_lookup[((unsigned)n * 0x077CB531U) >> 27];
 }
 
-static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) {
+sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) {
   int allsigs, restsigs, signum;
   if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) == SEXP_ZERO) {
     return SEXP_FALSE;
@@ -345,7 +345,7 @@ static sexp sexp_pop_signal (sexp ctx, sexp self, sexp_sint_t n) {
   }
 }
 
-static sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) {
+sexp sexp_get_signal_handler (sexp ctx, sexp self, sexp_sint_t n, sexp signum) {
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, signum);
   return sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
 }
@@ -358,7 +358,7 @@ static sexp sexp_make_pollfds (sexp ctx) {
   return res;
 }
 
-static sexp sexp_free_pollfds (sexp ctx, sexp self, sexp_sint_t n, sexp pollfds) {
+sexp sexp_free_pollfds (sexp ctx, sexp self, sexp_sint_t n, sexp pollfds) {
   if (sexp_pollfds_fds(pollfds)) {
     free(sexp_pollfds_fds(pollfds));
     sexp_pollfds_fds(pollfds) = NULL;
@@ -397,7 +397,7 @@ static sexp sexp_insert_pollfd (sexp ctx, int fd, int events) {
 }
 
 /* block the current thread on the specified port */
-static sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd, sexp timeout) {
+sexp sexp_blocker (sexp ctx, sexp self, sexp_sint_t n, sexp portorfd, sexp timeout) {
   int fd;
   /* register the fd */
   if (sexp_portp(portorfd))
@@ -653,7 +653,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
                          SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds),
                          SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
-                         SEXP_ZERO, SEXP_ZERO, NULL,
+                         SEXP_ZERO, SEXP_ZERO, NULL, "sexp_free_pollfds",
                          (sexp_proc2)sexp_free_pollfds);
   if (sexp_typep(t)) {
     sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID) = sexp_make_fixnum(sexp_type_tag(t));
@@ -681,9 +681,9 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "get-signal-handler", 1, sexp_get_signal_handler);
 
   sexp_global(ctx, SEXP_G_THREADS_SCHEDULER)
-    = sexp_make_foreign(ctx, "scheduler", 1, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE);
+    = sexp_make_foreign(ctx, "scheduler", 1, 0, "sexp_scheduler", (sexp_proc1)sexp_scheduler, SEXP_FALSE);
   sexp_global(ctx, SEXP_G_THREADS_BLOCKER)
-    = sexp_make_foreign(ctx, "blocker", 2, 0, (sexp_proc1)sexp_blocker, SEXP_FALSE);
+    = sexp_make_foreign(ctx, "blocker", 2, 0, "sexp_blocker", (sexp_proc1)sexp_blocker, SEXP_FALSE);
 
   /* remember the env to lookup the runner later */
   sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = env;

lib/srfi/27/rand.c

@@ -212,7 +212,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
                           sexp_make_fixnum(sexp_offsetof_slot0),
                           ONE, ONE, ZERO, ZERO,
                           sexp_make_fixnum(sexp_sizeof_random), ZERO,
-                          ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL);
+                          ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL, NULL, NULL);
   if (sexp_exceptionp(op))
     return op;
   rs_type_id = sexp_type_tag(op);

lib/srfi/33/bit.c

@@ -45,7 +45,7 @@ static sexp sexp_fixnum_to_twos_complement (sexp ctx, sexp x, int len) {
   return res;
 }
 
-static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
 #if SEXP_USE_BIGNUMS
   sexp_sint_t len, i;
 #endif
@@ -82,7 +82,7 @@ static sexp sexp_bit_and (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   }
 }
 
-static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   sexp res;
 #if SEXP_USE_BIGNUMS
   sexp_sint_t len, i;
@@ -122,7 +122,7 @@ static sexp sexp_bit_ior (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   return sexp_bignum_normalize(res);
 }
 
-static sexp sexp_bit_xor (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
+sexp sexp_bit_xor (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) {
   sexp res;
 #if SEXP_USE_BIGNUMS
   sexp_sint_t len, i;
@@ -172,7 +172,7 @@ static int log2i(sexp_uint_t v) {
 
 /* should probably split into left and right shifts, that's a better */
 /* interface anyway */
-static sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) {
+sexp sexp_arithmetic_shift (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp count) {
   sexp_uint_t tmp;
   sexp_sint_t c;
 #if SEXP_USE_BIGNUMS
@@ -260,7 +260,7 @@ static sexp_uint_t bit_count (sexp_uint_t i) {
           >> (sizeof(i) - 1) * CHAR_BIT);
 }
 
-static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp res;
   sexp_sint_t i;
 #if SEXP_USE_BIGNUMS
@@ -271,7 +271,7 @@ static sexp sexp_bit_count (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
     res = sexp_make_fixnum(bit_count(i<0 ? ~i : i));
 #if SEXP_USE_BIGNUMS
   } else if (sexp_bignump(x)) {
-    for (i=count=0; i<sexp_bignum_length(x); i++)
+    for (i=count=0; i<(sexp_sint_t)sexp_bignum_length(x); i++)
       count += bit_count(sexp_bignum_data(x)[i]);
     res = sexp_make_fixnum(count);
 #endif
@@ -302,7 +302,7 @@ static sexp_uint_t integer_log2 (sexp_uint_t x) {
     return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x];
 }
 
-static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
+sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   sexp_sint_t tmp;
 #if SEXP_USE_BIGNUMS
   sexp_sint_t hi;
@@ -321,7 +321,7 @@ static sexp sexp_integer_length (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
   }
 }
 
-static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) {
+sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x) {
   sexp_sint_t pos;
 #if SEXP_USE_BIGNUMS
   sexp_sint_t rem;
@@ -338,7 +338,7 @@ static sexp sexp_bit_set_p (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp x)
   } else if (sexp_bignump(x)) {
     pos /= (sizeof(sexp_uint_t)*CHAR_BIT);
     rem = (sexp_unbox_fixnum(i) - pos*sizeof(sexp_uint_t)*CHAR_BIT);
-    return sexp_make_boolean((pos < sexp_bignum_length(x))
+    return sexp_make_boolean((pos < (sexp_sint_t)sexp_bignum_length(x))
                              && (sexp_bignum_data(x)[pos] & (1UL<<rem)));
 #endif
   } else {

lib/srfi/39/param.c

@@ -6,7 +6,7 @@
 
 #define _I(x) sexp_make_fixnum(x)
 
-static sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init, sexp conv) {
+sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init, sexp conv) {
   sexp res;
   sexp_gc_var1(cell);
   sexp_gc_preserve1(ctx, cell);
@@ -19,7 +19,7 @@ static sexp sexp_make_parameter (sexp ctx, sexp self, sexp_sint_t n, sexp init,
   return res;
 }
 
-static sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp param) {
+sexp sexp_parameter_converter (sexp ctx, sexp self, sexp_sint_t n, sexp param) {
   sexp res;
   sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, param);
   res = sexp_opcode_data2(param);

lib/srfi/69/hash.c

@@ -23,7 +23,7 @@ static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
   return acc % bound;
 }
 
-static sexp sexp_string_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
+sexp sexp_string_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
   if (! sexp_stringp(str))
     return sexp_type_exception(ctx, self, SEXP_STRING, str);
   else if (! sexp_fixnump(bound))
@@ -38,7 +38,7 @@ static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
   return acc % bound;
 }
 
-static sexp sexp_string_ci_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
+sexp sexp_string_ci_hash (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp bound) {
   if (! sexp_stringp(str))
     return sexp_type_exception(ctx, self, SEXP_STRING, str);
   else if (! sexp_fixnump(bound))
@@ -69,7 +69,7 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t
         size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
         p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
         if (((char*)obj + size) > p0)
-          for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
+          for (i=0; i<(sexp_sint_t)size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
         /* hash eq-object slots */
         len = sexp_type_num_eq_slots_of_object(t, obj);
         if (len > 0) {
@@ -91,13 +91,13 @@ static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t
   return (bound ? acc % bound : acc);
 }
 
-static sexp sexp_hash (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
+sexp sexp_hash (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
   if (! sexp_exact_integerp(bound))
     return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
   return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH));
 }
 
-static sexp sexp_hash_by_identity (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
+sexp sexp_hash_by_identity (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp bound) {
   if (! sexp_exact_integerp(bound))
     return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
   return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
@@ -119,7 +119,7 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) {
       args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx));
       sexp_print_exception(ctx, res, args);
       res = SEXP_ZERO;
-    } else if (sexp_unbox_fixnum(res) >= len) {
+    } else if ((sexp_uint_t)sexp_unbox_fixnum(res) >= len) {
       res = SEXP_ZERO;
     }
     sexp_gc_release1(ctx);
@@ -184,7 +184,7 @@ static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp has
   sexp_gc_release1(ctx);
 }
 
-static sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj, sexp createp) {
+sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj, sexp createp) {
   sexp buckets, eq_fn, hash_fn, i;
   sexp_uint_t size;
   sexp_gc_var1(res);
@@ -214,7 +214,7 @@ static sexp sexp_hash_table_cell (sexp ctx, sexp self, sexp_sint_t n, sexp ht, s
   return res;
 }
 
-static sexp sexp_hash_table_delete (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj) {
+sexp sexp_hash_table_delete (sexp ctx, sexp self, sexp_sint_t n, sexp ht, sexp obj) {
   sexp buckets, eq_fn, hash_fn, i, p, res;
   if (!(sexp_pointerp(ht) && strcmp(sexp_string_data(sexp_object_type_name(ctx, ht)), "Hash-Table") == 0))
     return sexp_xtype_exception(ctx, self, "not a Hash-Table", ht);

main.c

@@ -7,6 +7,7 @@
 #endif
 
 #include "chibi/eval.h"
+#include "gc_heap.h"
 
 #define sexp_argv_symbol "command-line"
 
@@ -78,126 +79,6 @@ void sexp_segfault_handler(int sig) {
 }
 #endif
 
-#if SEXP_USE_IMAGE_LOADING
-
-#include <sys/types.h>
-#include <sys/uio.h>
-#include <unistd.h>
-#include <fcntl.h>
-
-#define SEXP_IMAGE_MAGIC "\a\achibi\n\0"
-#define SEXP_IMAGE_MAJOR_VERSION 1
-#define SEXP_IMAGE_MINOR_VERSION 1
-
-typedef struct sexp_image_header_t* sexp_image_header;
-struct sexp_image_header_t {
-  char magic[8];
-  short major, minor;
-  sexp_abi_identifier_t abi;
-  sexp_uint_t size;
-  sexp_heap base;
-  sexp context;
-};
-
-sexp sexp_gc (sexp ctx, size_t *sum_freed);
-void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags);
-
-static sexp sexp_load_image (const char* file, sexp_uint_t heap_size, sexp_uint_t heap_max_size) {
-  sexp ctx, flags, *globals, *types;
-  int fd;
-  sexp_sint_t offset;
-  sexp_heap heap;
-  sexp_free_list q;
-  struct sexp_image_header_t header;
-  fd = open(file, O_RDONLY);
-  if (fd < 0) {
-    fprintf(stderr, "can't open image file: %s\n", file);
-    return NULL;
-  }
-  if (read(fd, &header, sizeof(header)) != sizeof(header))
-    return NULL;
-  if (memcmp(header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)) != 0) {
-    fprintf(stderr, "invalid image file magic for %s: %s\n", file, header.magic);
-    return NULL;
-  } else if (header.major != SEXP_IMAGE_MAJOR_VERSION
-             || header.major < SEXP_IMAGE_MINOR_VERSION) {
-    fprintf(stderr, "unsupported image version: %d.%d\n",
-            header.major, header.minor);
-    return NULL;
-  } else if (!sexp_abi_compatible(NULL, header.abi, SEXP_ABI_IDENTIFIER)) {
-    fprintf(stderr, "unsupported ABI: %s (expected %s)\n",
-            header.abi, SEXP_ABI_IDENTIFIER);
-    return NULL;
-  }
-  if (heap_size < header.size) heap_size = header.size;
-  heap = (sexp_heap)malloc(sexp_heap_pad_size(heap_size));
-  if (!heap) {
-    fprintf(stderr, "couldn't malloc heap\n");
-    return NULL;
-  }
-  if (read(fd, heap, header.size) != header.size) {
-    fprintf(stderr, "error reading image\n");
-    return NULL;
-  }
-  offset = (sexp_sint_t)((char*)heap - (sexp_sint_t)header.base);
-  /* expand the last free chunk if necessary */
-  if (heap->size < heap_size) {
-    for (q=(sexp_free_list)(((char*)heap->free_list) + offset); q->next;
-         q=(sexp_free_list)(((char*)q->next) + offset))
-      ;
-    if ((char*)q + q->size >= (char*)heap->data + heap->size) {
-      /* last free chunk at end of heap */
-      q->size += heap_size - heap->size;
-    } else {
-      /* last free chunk in the middle of the heap */
-      q->next = (sexp_free_list)((char*)heap->data + heap->size);
-      q = (sexp_free_list)(((char*)q->next) + offset);
-      q->size = heap_size - heap->size;
-      q->next = NULL;
-    }
-    heap->size += (heap_size - heap->size);
-  }
-  ctx = (sexp)(((char*)header.context) + offset);
-  globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + offset));
-  types = sexp_vector_data((sexp)((char*)(globals[SEXP_G_TYPES]) + offset));
-  flags = sexp_fx_add(SEXP_COPY_LOADP, SEXP_COPY_FREEP);
-  sexp_offset_heap_pointers(heap, header.base, types, flags);
-  close(fd);
-  return ctx;
-}
-
-static int sexp_save_image (sexp ctx, const char* path) {
-  sexp_heap heap;
-  FILE* file;
-  struct sexp_image_header_t header;
-  heap = sexp_context_heap(ctx);
-  if (heap->next) {
-    fprintf(stderr, "can't save image for a chunked heap, try a larger initial heap with -h\n");
-    return 0;
-  }
-  file = fopen(path, "w");
-  if (!file) {
-    fprintf(stderr, "couldn't open image file for writing: %s\n", path);
-    return 0;
-  }
-  memcpy(&header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic));
-  memcpy(&header.abi, SEXP_ABI_IDENTIFIER, sizeof(header.abi));
-  header.major = SEXP_IMAGE_MAJOR_VERSION;
-  header.minor = SEXP_IMAGE_MINOR_VERSION;
-  header.size = heap->size;
-  header.base = heap;
-  header.context = ctx;
-  sexp_gc(ctx, NULL);
-  if (! (fwrite(&header, sizeof(header), 1, file) == 1
-         && fwrite(heap, heap->size, 1, file) == 1)) {
-    fprintf(stderr, "error writing image file\n");
-    return 0;
-  }
-  fclose(file);
-  return 1;
-}
-
-#endif
 
 #if SEXP_USE_GREEN_THREADS
 static void sexp_make_unblocking (sexp ctx, sexp port) {
@@ -406,7 +287,7 @@ static sexp sexp_resume_ctx = SEXP_FALSE;
 static sexp sexp_resume_proc = SEXP_FALSE;
 #endif
 
-void run_main (int argc, char **argv) {
+sexp run_main (int argc, char **argv) {
 #if SEXP_USE_MODULES
   char *impmod;
 #endif
@@ -529,8 +410,9 @@ void run_main (int argc, char **argv) {
         exit_failure();
       }
       ctx = sexp_load_image(arg, heap_size, heap_max_size);
-      if (!ctx) {
+      if (!ctx || !sexp_contextp(ctx)) {
         fprintf(stderr, "-:i <file>: couldn't open file for reading: %s\n", arg);
+        fprintf(stderr, "            %s\n", sexp_load_image_err());
         exit_failure();
       }
       env = sexp_load_standard_params(ctx, sexp_context_env(ctx));
@@ -542,8 +424,11 @@ void run_main (int argc, char **argv) {
         env = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
       }
       arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
-      if (!sexp_save_image(ctx, arg))
+      if (sexp_save_image(ctx, arg) != SEXP_TRUE) {
+        fprintf(stderr, "-d <file>: couldn't save image to file: %s\n", arg);
+        fprintf(stderr, "           %s\n", sexp_load_image_err());
         exit_failure();
+      }
       quit = 1;
       break;
 #endif
@@ -555,7 +440,7 @@ void run_main (int argc, char **argv) {
       tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL);
       sexp_write(ctx, tmp, out);
       sexp_newline(ctx, out);
-      return;
+      return SEXP_TRUE;
 #if SEXP_USE_FOLD_CASE_SYMS
     case 'f':
       fold_case = 1;
@@ -698,7 +583,11 @@ void run_main (int argc, char **argv) {
   }
 
   sexp_gc_release4(ctx);
-  sexp_destroy_context(ctx);
+  if (sexp_destroy_context(ctx) == SEXP_FALSE) {
+    fprintf(stderr, "destroy_context error\n");
+    return SEXP_FALSE;
+  }
+  return SEXP_TRUE;
 }
 
 #ifdef EMSCRIPTEN
@@ -718,7 +607,10 @@ int main (int argc, char **argv) {
   signal(SIGSEGV, sexp_segfault_handler); 
 #endif
   sexp_scheme_init();
-  run_main(argc, argv);
+  if (run_main(argc, argv) == SEXP_FALSE) {
-  exit_success();
+    exit_failure();
+  } else {
+    exit_success();
+  }
   return 0;
 }

sexp.c

@@ -12,9 +12,7 @@ struct sexp_huff_entry {
 
 #if SEXP_USE_HUFF_SYMS
 #include "chibi/sexp-hufftabs.h"
-static struct sexp_huff_entry huff_table[] = {
 #include "chibi/sexp-huff.h"
-};
 #endif
 
 static int sexp_initialized_p = 0;
@@ -177,58 +175,58 @@ sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl) {
 #endif
 
 static struct sexp_type_struct _sexp_type_specs[] = {
-  {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_TYPE, sexp_offsetof(type, name), 7+SEXP_USE_DL, 7+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_TYPE, sexp_offsetof(type, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #if SEXP_USE_PACKED_STRINGS
-  {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #else
-  {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #endif
-  {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #if SEXP_USE_RATIOS
-  {SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #endif
 #if SEXP_USE_COMPLEX
-  {SEXP_COMPLEX, sexp_offsetof(complex, real), 2, 2, 0, 0, sexp_sizeof(complex), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Complex", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_COMPLEX, sexp_offsetof(complex, real), 2, 2, 0, 0, sexp_sizeof(complex), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Complex", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #endif
-  {SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORT},
+  {SEXP_IPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_FINALIZE_PORT},
-  {SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORT},
+  {SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_FINALIZE_PORT},
-  {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENO},
+  {SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FINALIZE_FILENO},
-  {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_EXCEPTION, sexp_offsetof(exception, kind), 5, 5, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #if SEXP_USE_DL
-  {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_DL},
+  {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_DLN, SEXP_FINALIZE_DL},
 #endif
-  {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"If", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"If", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ref", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ref", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_SET_SYN, sexp_offsetof(set_syn, var), 3, 3, 0, 0, sexp_sizeof(set_syn), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set-Syn!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_SET_SYN, sexp_offsetof(set_syn, var), 3, 3, 0, 0, sexp_sizeof(set_syn), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set-Syn!", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Seq", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Seq", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lit", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL},
+  {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lit", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, NULL},
-  {SEXP_STACK, sexp_offsetof(stack, data), 0, 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_STACK, sexp_offsetof(stack, data), 0, 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
-  {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #if SEXP_USE_AUTO_FORCE
-  {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #endif
 #if SEXP_USE_WEAK_REFERENCES
-  {SEXP_EPHEMERON, sexp_offsetof(ephemeron, key), 2, 0, 0, 0, sexp_sizeof(ephemeron), 0, 0, sexp_offsetof(ephemeron, key), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL},
+  {SEXP_EPHEMERON, sexp_offsetof(ephemeron, key), 2, 0, 0, 0, sexp_sizeof(ephemeron), 0, 0, sexp_offsetof(ephemeron, key), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, NULL},
 #endif
 };
 
@@ -240,7 +238,7 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
                             sexp parent, sexp slots,
                             sexp fb, sexp felb, sexp flb, sexp flo, sexp fls,
                             sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo,
-                            sexp ws, sexp we, sexp p, sexp_proc2 f) {
+                            sexp ws, sexp we, sexp p, const char* fname, sexp_proc2 f) {
   sexp *v1, *v2;
   sexp_gc_var2(res, type);
   sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
@@ -271,32 +269,33 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
       sexp_pointer_tag(type) = SEXP_TYPE;
       sexp_type_tag(type) = num_types;
       sexp_type_slots(type) = slots;
-      sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
+      sexp_type_field_base(type) = (short)sexp_unbox_fixnum(fb);
-      sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb);
+      sexp_type_field_eq_len_base(type) = (short)sexp_unbox_fixnum(felb);
-      sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);
+      sexp_type_field_len_base(type) = (short)sexp_unbox_fixnum(flb);
-      sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo);
+      sexp_type_field_len_off(type) = (short)sexp_unbox_fixnum(flo);
-      sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls);
+      sexp_type_field_len_scale(type) = (unsigned short)sexp_unbox_fixnum(fls);
-      sexp_type_size_base(type) = sexp_unbox_fixnum(sb);
+      sexp_type_size_base(type) = (short)sexp_unbox_fixnum(sb);
-      sexp_type_size_off(type) = sexp_unbox_fixnum(so);
+      sexp_type_size_off(type) = (short)sexp_unbox_fixnum(so);
-      sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
+      sexp_type_size_scale(type) = (unsigned short)sexp_unbox_fixnum(sc);
-      sexp_type_weak_base(type) = sexp_unbox_fixnum(w);
+      sexp_type_weak_base(type) = (short)sexp_unbox_fixnum(w);
-      sexp_type_weak_len_base(type) = sexp_unbox_fixnum(wb);
+      sexp_type_weak_len_base(type) = (short)sexp_unbox_fixnum(wb);
-      sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo);
+      sexp_type_weak_len_off(type) = (short)sexp_unbox_fixnum(wo);
-      sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws);
+      sexp_type_weak_len_scale(type) = (short)sexp_unbox_fixnum(ws);
-      sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we);
+      sexp_type_weak_len_extra(type) = (short)sexp_unbox_fixnum(we);
       sexp_type_name(type) = name;
       sexp_type_getters(type) = SEXP_FALSE;
       sexp_type_setters(type) = SEXP_FALSE;
       sexp_type_finalize(type) = f;
+      sexp_type_finalize_name(type) = (fname) ? sexp_c_string(ctx, fname, -1) : NULL;
       sexp_type_id(type) = SEXP_FALSE;
 #if SEXP_USE_DL
       if (f) sexp_type_dl(type) = sexp_context_dl(ctx);
 #endif
       sexp_type_print(type) = p;
-      if (sexp_typep(parent)) {
+      if (parent && sexp_typep(parent)) {
         len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1;
         sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID);
-        if (sexp_vectorp(sexp_type_cpl(parent)))
+        if (parent && sexp_vectorp(sexp_type_cpl(parent)))
           memcpy(sexp_vector_data(sexp_type_cpl(type)),
                  sexp_vector_data(sexp_type_cpl(parent)),
                  len * sizeof(sexp));
@@ -307,7 +306,7 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
         sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID);
       }
       sexp_vector_data(sexp_type_cpl(type))[len] = type;
-      sexp_type_depth(type) = len;
+      sexp_type_depth(type) = (short)len;
       sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1);
     }
     res = type;
@@ -317,14 +316,14 @@ sexp sexp_register_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name,
 }
 
 sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots) {
-  short i, num_slots = sexp_unbox_fixnum(sexp_length(ctx, slots));
+  short i, num_slots = (short)sexp_unbox_fixnum(sexp_length(ctx, slots));
   sexp type_size, num_slots_obj, cpl, tmp;
   if (parent && sexp_typep(parent)) {
-    num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent)));
+    num_slots += (short)sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent)));
     if (sexp_vectorp((cpl = sexp_type_cpl(parent))))
-      for (i=sexp_vector_length(cpl)-1; i>=0; i--) {
+      for (i=(short)sexp_vector_length(cpl)-1; i>=0; i--) {
         tmp = sexp_vector_ref(cpl, sexp_make_fixnum(i));
-        num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp)));
+        num_slots += (short)sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp)));
       }
   }
   num_slots_obj = sexp_make_fixnum(num_slots);
@@ -336,7 +335,7 @@ sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name
                        type_size, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
                        SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
                        sexp_type_print(sexp_type_by_index(ctx, SEXP_EXCEPTION)),
-                       NULL);
+                       NULL, NULL);
 }
 
 #if SEXP_USE_OBJECT_BRACE_LITERALS
@@ -419,14 +418,20 @@ void sexp_init_context_globals (sexp ctx) {
   vec = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
   for (i=0; i<SEXP_NUM_CORE_TYPES; i++) {
     type = sexp_alloc_type(ctx, type, SEXP_TYPE);
+    if (!type) {
+      return; // TODO - fundamental OOM, what to do here?
+    }
     memcpy(&(type->value), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
     vec[i] = type;
     sexp_type_name(type) = sexp_c_string(ctx, (char*)sexp_type_name(type), -1);
+    if (sexp_type_finalize_name(type)) {
+      sexp_type_finalize_name(type) = sexp_c_string(ctx, (char*)sexp_type_finalize_name(type), -1);
+    }
     if (sexp_type_print(type)) {
       if (print && ((sexp_proc1)sexp_type_print(type) == sexp_opcode_func(print)))
         sexp_type_print(type) = print;
       else
-        sexp_type_print(type) = print = sexp_make_foreign(ctx, "sexp_write_simple_object", 3, 0, (sexp_proc1)sexp_type_print(type), NULL);
+        sexp_type_print(type) = print = sexp_make_foreign(ctx, "sexp_write_simple_object", 3, 0, NULL, (sexp_proc1)sexp_type_print(type), NULL);
     }
   }
 }
@@ -503,7 +508,7 @@ sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) {
 }
 
 #if ! SEXP_USE_GLOBAL_HEAP
-void sexp_destroy_context (sexp ctx) {
+sexp sexp_destroy_context (sexp ctx) {
   sexp_heap heap, tmp;
   size_t sum_freed;
   if (sexp_context_heap(ctx)) {
@@ -511,15 +516,16 @@ void sexp_destroy_context (sexp ctx) {
     sexp_markedp(ctx) = 1;
     sexp_markedp(sexp_context_globals(ctx)) = 1;
     sexp_mark(ctx, sexp_global(ctx, SEXP_G_TYPES));
-    sexp_finalize(ctx);
+    if (sexp_finalize(ctx) == SEXP_FALSE) { return SEXP_FALSE; }
     sexp_sweep(ctx, &sum_freed);
-    sexp_finalize(ctx);
+    if (sexp_finalize(ctx) == SEXP_FALSE) { return SEXP_FALSE; }
     sexp_context_heap(ctx) = NULL;
     for ( ; heap; heap=tmp) {
       tmp = heap->next;
       sexp_free_heap(heap);
     }
   }
+  return SEXP_TRUE;
 }
 #endif
 
@@ -1014,7 +1020,7 @@ sexp sexp_string_offset_to_index (sexp ctx, sexp self, sexp_sint_t n, sexp str,
   sexp_sint_t off = sexp_unbox_fixnum(offset);
   sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, offset);
-  if (off < 0 || off > sexp_string_size(str))
+  if (off < 0 || off > (sexp_sint_t)sexp_string_size(str))
     return sexp_user_exception(ctx, self, "string-offset->index: offset out of range", offset);
   return sexp_make_fixnum(sexp_string_utf8_length((unsigned char*)sexp_string_data(str), off));
 }
@@ -1078,9 +1084,9 @@ sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start
     end = sexp_make_fixnum(sexp_string_size(str));
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
   if ((sexp_unbox_fixnum(start) < 0)
-      || (sexp_unbox_fixnum(start) > sexp_string_size(str))
+      || (sexp_unbox_fixnum(start) > (sexp_sint_t)sexp_string_size(str))
       || (sexp_unbox_fixnum(end) < 0)
-      || (sexp_unbox_fixnum(end) > sexp_string_size(str))
+      || (sexp_unbox_fixnum(end) > (sexp_sint_t)sexp_string_size(str))
       || (end < start))
     return sexp_range_exception(ctx, str, start, end);
   res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID);
@@ -1529,16 +1535,16 @@ static void sexp_insert_fileno(sexp ctx, sexp fileno) {
   if (!sexp_vectorp(vec)) {
     vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
         = sexp_make_vector(ctx, sexp_make_fixnum(128), SEXP_FALSE);
-  } else if (n >= sexp_vector_length(vec)) {
+  } else if (n >= (sexp_sint_t)sexp_vector_length(vec)) {
     data = sexp_vector_data(vec);
-    for (i = n2 = 0; i < sexp_vector_length(vec); i++)
+    for (i = n2 = 0; i < (sexp_sint_t)sexp_vector_length(vec); i++)
       if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i]))
         n2++;
     if (n2 * 2 >= n)
       n2 = n * 2;
     tmp = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
         = sexp_make_vector(ctx, sexp_make_fixnum(n2), SEXP_FALSE);
-    for (i = n = 0; i < sexp_vector_length(vec); i++)
+    for (i = n = 0; i < (sexp_sint_t)sexp_vector_length(vec); i++)
       if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i])
           && sexp_insert_fileno_ephemeron(ctx, tmp, data[i]))
         n++;
@@ -1765,7 +1771,7 @@ static struct {const char* name; char ch;} sexp_char_names[] = {
   {"alarm", '\a'},
   {"backspace", '\b'},
   {"delete", 127},
-  {"escape", '\e'},
+  {"escape", 27},
   {"null", 0},
 #endif
 };
@@ -1820,7 +1826,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
       } else {
         sexp_write_string(ctx, "#(", out);
         sexp_write_one(ctx, elts[0], out);
-        for (i=1; i<len; i++) {
+        for (i=1; i<(long)len; i++) {
           sexp_write_char(ctx, ' ', out);
           sexp_write_one(ctx, elts[i], out);
         }
@@ -1953,7 +1959,7 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
       sexp_write_string(ctx, "#u8(", out);
       str = sexp_bytes_data(obj);
       len = sexp_bytes_length(obj);
-      for (i=0; i<len; i++) {
+      for (i=0; i<(long)len; i++) {
         if (i!=0) sexp_write_char(ctx, ' ', out);
         sexp_write(ctx, sexp_make_fixnum(((unsigned char*)str)[i]), out);
       }
@@ -2881,7 +2887,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
                         sexp_make_fixnum(16))) {
           res = sexp_read_error(ctx, "reader label out of order", tmp, in);
         } else {
-          if (c2 + 1 >= sexp_vector_length(*shares)) {
+          if (c2 + 1 >= (int)sexp_vector_length(*shares)) {
             tmp2 = sexp_make_vector(ctx, sexp_make_fixnum(sexp_vector_length(*shares)*2), SEXP_VOID);
             memcpy(sexp_vector_data(tmp2), sexp_vector_data(*shares), (sexp_vector_length(*shares)-1)*sizeof(sexp));
             *shares = tmp2;
@@ -2890,6 +2896,7 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
           if (tmp > sexp_vector_data(*shares)[sexp_vector_length(*shares)-1])
             sexp_vector_data(*shares)[sexp_vector_length(*shares)-1] = tmp;
           res = sexp_read_raw(ctx, in, shares);
+          sexp_vector_data(*shares)[c2] = res;
           if (sexp_reader_labelp(res))
             res = sexp_read_error(ctx, "self reader label reference", tmp, in);
           else

tools/chibi-ffi

@@ -1390,7 +1390,7 @@
     (write-gc-release gc-vars)))
 
 (define (write-func-declaration func)
-  (cat "static sexp " (func-stub-name func)
+  (cat "sexp " (func-stub-name func)
        " (sexp ctx, sexp self, sexp_sint_t n"
        (write-parameters (func-scheme-args func)) ")"))
 
@@ -1516,7 +1516,7 @@
                           (else 1))
                     ", "))
              "")
-         "(sexp_proc1)" (func-stub-name func)
+         (func-stub-name func)
          (cond
           (default (lambda () (cat ", " (write-default default))))
           (no-bind? ", SEXP_VOID")
@@ -1668,7 +1668,7 @@
                "((" (x->string (or (type-struct-type name) ""))
                " " (x->string name) "*)"
                "sexp_cpointer_value(x))")))
-    (cat "static sexp " (type-getter-name type name field)
+    (cat "sexp " (type-getter-name type name field)
          " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
          (lambda () (write-validator "x" (parse-type name 0)))
          "  return "
@@ -1745,7 +1745,7 @@
              (lambda () (scheme->c-converter (car field) val)) ";\n"))))))
 
 (define (write-type-setter type name field)
-  (cat "static sexp " (type-setter-name type name field)
+  (cat "sexp " (type-setter-name type name field)
        " (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
        (lambda () (write-validator "x" (parse-type name 0)))
        (lambda () (write-validator "v" (parse-type (car field) 1)))
@@ -1762,7 +1762,7 @@
                 (scheme-name (if (pair? y) (car y) y))
                 (cname (if (pair? y) (cadr y) y))
                 (method? (not (memq 'finalizer: type))))
-           (cat "static sexp " (generate-stub-name scheme-name)
+           (cat "sexp " (generate-stub-name scheme-name)
                 " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
                 "  if (sexp_cpointer_freep(x)) {\n"
                 "    " (if method? "" cname) "("
@@ -1787,7 +1787,7 @@
     => (lambda (x)
          (let ((make (car (cadr x)))
                (args (cdr (cadr x))))
-           (cat "static sexp " (generate-stub-name make)
+           (cat "sexp " (generate-stub-name make)
                 " (sexp ctx, sexp self, sexp_sint_t n"
                 (lambda ()
                   (let lp ((ls args) (i 0))
@@ -1928,7 +1928,7 @@
          (let ((name (type-c-name-derefed (car t)))
                (finalizer-name (type-finalizer-name (car t))))
            (cat
-            "static sexp " finalizer-name " ("
+            "sexp " finalizer-name " ("
             "sexp ctx, sexp self, sexp_sint_t n, sexp obj) {\n"
             "  if (sexp_cpointer_freep(obj))\n"
             "    delete static_cast<" name "*>"

vm.c

@@ -32,7 +32,7 @@ static sexp sexp_lookup_source_info (sexp src, int ip) {
   if (src && sexp_procedurep(src))
     src = sexp_procedure_source(src);
   if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) {
-    for (i=1; i<sexp_vector_length(src); i++)
+    for (i=1; i<(int)sexp_vector_length(src); i++)
       if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(i)))) > ip)
         return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1)));
     return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1)));
@@ -200,7 +200,7 @@ static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
       generate_drop_prev(ctx, sexp_car(head));
       sexp_inc_context_depth(ctx, -1);
     }
-  sexp_context_tailp(ctx) = tailp;
+  sexp_context_tailp(ctx) = (char)tailp;
   sexp_generate(ctx, name, loc, lam, sexp_car(head));
 }
 
@@ -209,12 +209,12 @@ static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) {
   sexp_push_source(ctx, sexp_cnd_source(cnd));
   sexp_context_tailp(ctx) = 0;
   sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd));
-  sexp_context_tailp(ctx) = tailp;
+  sexp_context_tailp(ctx) = (char)tailp;
   sexp_emit(ctx, SEXP_OP_JUMP_UNLESS);
   sexp_inc_context_depth(ctx, -1);
   label1 = sexp_context_make_label(ctx);
   sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd));
-  sexp_context_tailp(ctx) = tailp;
+  sexp_context_tailp(ctx) = (char)tailp;
   sexp_emit(ctx, SEXP_OP_JUMP);
   sexp_inc_context_depth(ctx, -1);
   label2 = sexp_context_make_label(ctx);
@@ -473,7 +473,7 @@ static void generate_general_app (sexp ctx, sexp app) {
   sexp_emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL));
   sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len));
 
-  sexp_context_tailp(ctx) = tailp;
+  sexp_context_tailp(ctx) = (char)tailp;
   sexp_inc_context_depth(ctx, -len);
   sexp_gc_release1(ctx);
 }
@@ -890,7 +890,7 @@ static int sexp_check_type(sexp ctx, sexp a, sexp b) {
   if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
     return 1;
   d = sexp_type_depth(b);
-  return (d < sexp_vector_length(v))
+  return (d < (int)sexp_vector_length(v))
     && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
 }
 
@@ -1136,7 +1136,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     bc = sexp_procedure_code(self);
     cp = sexp_procedure_vars(self);
     ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3);
-    i = sexp_unbox_fixnum(_ARG4);
+    // TODO - value stored here never read, verify   i = sexp_unbox_fixnum(_ARG4);
     top -= 4;
     _ARG1 = tmp1;
     break;
@@ -1375,7 +1375,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     else if (! sexp_fixnump(_ARG2))
       sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
       sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
     top--;
@@ -1388,7 +1388,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     else if (! sexp_fixnump(_ARG2))
       sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_vector_length(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
       sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     sexp_vector_set(_ARG1, _ARG2, _ARG3);
     top-=3;
@@ -1404,7 +1404,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     if (! sexp_fixnump(_ARG2))
       sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_bytes_length(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
       sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     _ARG2 = sexp_bytes_ref(_ARG1, _ARG2);
     top--;
@@ -1415,7 +1415,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     else if (! sexp_fixnump(_ARG2))
       sexp_raise("string-ref: not an integer", sexp_list1(ctx, _ARG2));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_string_size(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
       sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     _ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2);
     top--;
@@ -1432,7 +1432,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
                && sexp_unbox_fixnum(_ARG3)<0x100))
       sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_bytes_length(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
       sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     sexp_bytes_set(_ARG1, _ARG2, _ARG3);
     top-=3;
@@ -1448,7 +1448,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     else if (! sexp_charp(_ARG3))
       sexp_raise("string-set!: not a char", sexp_list1(ctx, _ARG3));
     i = sexp_unbox_fixnum(_ARG2);
-    if ((i < 0) || (i >= sexp_string_size(_ARG1)))
+    if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
       sexp_raise("string-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
     sexp_context_top(ctx) = top;
     sexp_string_set(ctx, _ARG1, _ARG2, _ARG3);
@@ -1573,7 +1573,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     if (! sexp_fixnump(_ARG3))
       sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
     if (sexp_vectorp(sexp_type_getters(_ARG1))) {
-      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_getters(_ARG1)))
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_getters(_ARG1)))
         sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
       tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
       if (sexp_opcodep(tmp1))
@@ -1602,7 +1602,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     if (! sexp_fixnump(_ARG3))
       sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
     if (sexp_vectorp(sexp_type_setters(_ARG1))) {
-      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_vector_length(sexp_type_setters(_ARG1)))
+      if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_setters(_ARG1)))
         sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
       tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
       if (sexp_opcodep(tmp1))
@@ -2007,7 +2007,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
       _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1));
     else if (! sexp_fixnump(_ARG2))
       sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
-    if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > sexp_bytes_length(tmp1))
+    if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > (sexp_sint_t)sexp_bytes_length(tmp1))
       sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2));
     if (! sexp_oportp(_ARG3))
       sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));