gpgscm: Fix initialization of 'sink'.
[gnupg.git] / tests / gpgscm / scheme.c
index 220eed3..673d199 100644 (file)
@@ -67,6 +67,7 @@
 #define banner "TinyScheme 1.41"
 
 #include <string.h>
+#include <stddef.h>
 #include <stdlib.h>
 
 #ifdef __APPLE__
@@ -124,13 +125,47 @@ enum scheme_types {
   T_MACRO=12,
   T_PROMISE=13,
   T_ENVIRONMENT=14,
-  T_LAST_SYSTEM_TYPE=14
+  T_FOREIGN_OBJECT=15,
+  T_BOOLEAN=16,
+  T_NIL=17,
+  T_EOF_OBJ=18,
+  T_SINK=19,
+  T_LAST_SYSTEM_TYPE=19
 };
 
+static const char *
+type_to_string (enum scheme_types typ)
+{
+     switch (typ)
+     {
+     case T_STRING: return "string";
+     case T_NUMBER: return "number";
+     case T_SYMBOL: return "symbol";
+     case T_PROC: return "proc";
+     case T_PAIR: return "pair";
+     case T_CLOSURE: return "closure";
+     case T_CONTINUATION: return "continuation";
+     case T_FOREIGN: return "foreign";
+     case T_CHARACTER: return "character";
+     case T_PORT: return "port";
+     case T_VECTOR: return "vector";
+     case T_MACRO: return "macro";
+     case T_PROMISE: return "promise";
+     case T_ENVIRONMENT: return "environment";
+     case T_FOREIGN_OBJECT: return "foreign object";
+     case T_BOOLEAN: return "boolean";
+     case T_NIL: return "nil";
+     case T_EOF_OBJ: return "eof object";
+     case T_SINK: return "sink";
+     }
+     assert (! "not reached");
+}
+
 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
 #define ADJ 32
 #define TYPE_BITS 5
 #define T_MASKTYPE      31    /* 0000000000011111 */
+#define T_FINALIZE    2048    /* 0000100000000000 */
 #define T_SYNTAX      4096    /* 0001000000000000 */
 #define T_IMMUTABLE   8192    /* 0010000000000000 */
 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
@@ -215,7 +250,7 @@ INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
 #if USE_PLIST
-SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (typeflag(p)&T_SYMBOL); }
+SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (is_symbol(p)); }
 #define symprop(p)       cdr(p)
 #endif
 
@@ -234,6 +269,14 @@ INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
 #define cont_dump(p)     cdr(p)
 
+INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
+INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
+  return p->_object._foreign_object._vtable;
+}
+INTERFACE void *get_foreign_object_data(pointer p) {
+  return p->_object._foreign_object._data;
+}
+
 /* To do: promise should be forced ONCE only */
 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
 
@@ -555,34 +598,47 @@ static long binary_decode(const char *s) {
  return x;
 }
 
+/* Allocate a new cell segment but do not make it available yet.  */
+static int
+_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
+{
+  int adj = ADJ;
+  void *cp;
+
+  if (adj < sizeof(struct cell))
+    adj = sizeof(struct cell);
+
+  cp = sc->malloc(len * sizeof(struct cell) + adj);
+  if (cp == NULL)
+    return 1;
+
+  *alloc = cp;
+
+  /* adjust in TYPE_BITS-bit boundary */
+  if (((unsigned long) cp) % adj != 0)
+    cp = (void *) (adj * ((unsigned long) cp / adj + 1));
+
+  *cells = cp;
+  return 0;
+}
+
 /* allocate new cell segment */
 static int alloc_cellseg(scheme *sc, int n) {
      pointer newp;
      pointer last;
      pointer p;
-     char *cp;
      long i;
      int k;
-     int adj=ADJ;
-
-     if(adj<sizeof(struct cell)) {
-       adj=sizeof(struct cell);
-     }
 
      for (k = 0; k < n; k++) {
          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
               return k;
-         cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
-         if (cp == 0)
-              return k;
-         i = ++sc->last_cell_seg ;
-         sc->alloc_seg[i] = cp;
-         /* adjust in TYPE_BITS-bit boundary */
-         if(((unsigned long)cp)%adj!=0) {
-           cp=(char*)(adj*((unsigned long)cp/adj+1));
-         }
+        i = ++sc->last_cell_seg;
+        if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) {
+             sc->last_cell_seg--;
+             return k;
+        }
          /* insert new segment in address order */
-         newp=(pointer)cp;
          sc->cell_seg[i] = newp;
          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
              p = sc->cell_seg[i];
@@ -611,13 +667,120 @@ static int alloc_cellseg(scheme *sc, int n) {
      return n;
 }
 
+\f
+
+/* Controlling the garbage collector.
+ *
+ * Every time a cell is allocated, the interpreter may run out of free
+ * cells and do a garbage collection.  This is problematic because it
+ * might garbage collect objects that have been allocated, but are not
+ * yet made available to the interpreter.
+ *
+ * Previously, we would plug such newly allocated cells into the list
+ * of newly allocated objects rooted at car(sc->sink), but that
+ * requires allocating yet another cell increasing pressure on the
+ * memory management system.
+ *
+ * A faster alternative is to preallocate the cells needed for an
+ * operation and make sure the garbage collection is not run until all
+ * allocated objects are plugged in.  This can be done with gc_disable
+ * and gc_enable.
+ */
+
+/* The garbage collector is enabled if the inhibit counter is
+ * zero.  */
+#define GC_ENABLED     0
+
+/* For now we provide a way to disable this optimization for
+ * benchmarking and because it produces slightly smaller code.  */
+#ifndef USE_GC_LOCKING
+# define USE_GC_LOCKING 1
+#endif
+
+/* To facilitate nested calls to gc_disable, functions that allocate
+ * more than one cell may define a macro, e.g. foo_allocates.  This
+ * macro can be used to compute the amount of preallocation at the
+ * call site with the help of this macro.  */
+#define gc_reservations(fn) fn ## _allocates
+
+#if USE_GC_LOCKING
+
+/* Report a shortage in reserved cells, and terminate the program.  */
+static void
+gc_reservation_failure(struct scheme *sc)
+{
+#ifdef NDEBUG
+  fprintf(stderr,
+         "insufficient reservation\n")
+#else
+  fprintf(stderr,
+         "insufficient reservation in line %d\n",
+         sc->reserved_lineno);
+#endif
+  abort();
+}
+
+/* Disable the garbage collection and reserve the given number of
+ * cells.  gc_disable may be nested, but the enclosing reservation
+ * must include the reservations of all nested calls.  Note: You must
+ * re-enable the gc before calling Error_X.  */
+static void
+_gc_disable(struct scheme *sc, size_t reserve, int lineno)
+{
+  if (sc->inhibit_gc == 0) {
+    reserve_cells(sc, (reserve));
+    sc->reserved_cells = (reserve);
+#ifndef NDEBUG
+    (void) lineno;
+#else
+    sc->reserved_lineno = lineno;
+#endif
+  } else if (sc->reserved_cells < (reserve))
+    gc_reservation_failure (sc);
+  sc->inhibit_gc += 1;
+}
+#define gc_disable(sc, reserve)                        \
+     _gc_disable (sc, reserve, __LINE__)
+
+/* Enable the garbage collector.  */
+#define gc_enable(sc)                          \
+     do {                                      \
+         assert(sc->inhibit_gc);               \
+         sc->inhibit_gc -= 1;                  \
+     } while (0)
+
+/* Test whether the garbage collector is enabled.  */
+#define gc_enabled(sc)                         \
+     (sc->inhibit_gc == GC_ENABLED)
+
+/* Consume a reserved cell.  */
+#define gc_consume(sc)                                                 \
+     do {                                                              \
+         assert(! gc_enabled (sc));                                    \
+         if (sc->reserved_cells == 0)                                  \
+              gc_reservation_failure (sc);                             \
+         sc->reserved_cells -= 1;                                      \
+     } while (0)
+
+#else /* USE_GC_LOCKING */
+
+#define gc_disable(sc, reserve)        (void) 0
+#define gc_enable(sc)  (void) 0
+#define gc_enabled(sc) 1
+#define gc_consume(sc) (void) 0
+
+#endif /* USE_GC_LOCKING */
+
 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
-  if (sc->free_cell != sc->NIL) {
+  if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
     pointer x = sc->free_cell;
+    if (! gc_enabled (sc))
+        gc_consume (sc);
     sc->free_cell = cdr(x);
     --sc->fcells;
     return (x);
   }
+  assert (gc_enabled (sc));
   return _get_cell (sc, a, b);
 }
 
@@ -630,6 +793,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) {
     return sc->sink;
   }
 
+  assert (gc_enabled (sc));
   if (sc->free_cell == sc->NIL) {
     const int min_to_be_recovered = sc->last_cell_seg*8;
     gc(sc,a, b);
@@ -731,6 +895,26 @@ static pointer find_consecutive_cells(scheme *sc, int n) {
   return sc->NIL;
 }
 
+/* Free a cell.  This is dangerous.  Only free cells that are not
+ * referenced.  */
+static INLINE void
+free_cell(scheme *sc, pointer a)
+{
+  cdr(a) = sc->free_cell;
+  sc->free_cell = a;
+  sc->fcells += 1;
+}
+
+/* Free a cell and retrieve its content.  This is dangerous.  Only
+ * free cells that are not referenced.  */
+static INLINE void
+free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
+{
+  *r_car = car(a);
+  *r_cdr = cdr(a);
+  free_cell(sc, a);
+}
+
 /* To retain recent allocs before interpreter knows about them -
    Tehom */
 
@@ -743,6 +927,17 @@ static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
   car(sc->sink) = holder;
 }
 
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+  pointer a = car(sc->sink), next;
+  car(sc->sink) = sc->NIL;
+  while (a != sc->NIL)
+    {
+      next = cdr(a);
+      free_cell(sc, a);
+      a = next;
+    }
+}
 
 static pointer get_cell(scheme *sc, pointer a, pointer b)
 {
@@ -753,7 +948,8 @@ static pointer get_cell(scheme *sc, pointer a, pointer b)
   typeflag(cell) = T_PAIR;
   car(cell) = a;
   cdr(cell) = b;
-  push_recent_alloc(sc, cell, sc->NIL);
+  if (gc_enabled (sc))
+    push_recent_alloc(sc, cell, sc->NIL);
   return cell;
 }
 
@@ -766,16 +962,11 @@ static pointer get_vector_object(scheme *sc, int len, pointer init)
   ivalue_unchecked(cells)=len;
   set_num_integer(cells);
   fill_vector(cells,init);
-  push_recent_alloc(sc, cells, sc->NIL);
+  if (gc_enabled (sc))
+    push_recent_alloc(sc, cells, sc->NIL);
   return cells;
 }
 
-static INLINE void ok_to_freely_gc(scheme *sc)
-{
-  car(sc->sink) = sc->NIL;
-}
-
-
 #if defined TSGRIND
 static void check_cell_alloced(pointer p, int expect_alloced)
 {
@@ -829,9 +1020,11 @@ static pointer oblist_initial_value(scheme *sc)
 /* returns the new symbol */
 static pointer oblist_add_by_name(scheme *sc, const char *name)
 {
+#define oblist_add_by_name_allocates   3
   pointer x;
   int location;
 
+  gc_disable(sc, gc_reservations (oblist_add_by_name));
   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
   typeflag(x) = T_SYMBOL;
   setimmutable(car(x));
@@ -839,6 +1032,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name)
   location = hash_fn(name, ivalue_unchecked(sc->oblist));
   set_vector_elem(sc->oblist, location,
                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
+  gc_enable(sc);
   return x;
 }
 
@@ -916,7 +1110,7 @@ static pointer oblist_all_symbols(scheme *sc)
 static pointer mk_port(scheme *sc, port *p) {
   pointer x = get_cell(sc, sc->NIL, sc->NIL);
 
-  typeflag(x) = T_PORT|T_ATOM;
+  typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
   x->_object._port=p;
   return (x);
 }
@@ -929,6 +1123,15 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) {
   return (x);
 }
 
+pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
+  pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+  typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
+  x->_object._foreign_object._vtable=vtable;
+  x->_object._foreign_object._data = data;
+  return (x);
+}
+
 INTERFACE pointer mk_character(scheme *sc, int c) {
   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 
@@ -938,16 +1141,64 @@ INTERFACE pointer mk_character(scheme *sc, int c) {
   return (x);
 }
 
+\f
+
+#if USE_SMALL_INTEGERS
+
+/* s_save assumes that all opcodes can be expressed as a small
+ * integer.  */
+#define MAX_SMALL_INTEGER      OP_MAXDEFINED
+
+static int
+initialize_small_integers(scheme *sc)
+{
+  int i;
+  if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc,
+                    &sc->integer_cells))
+    return 1;
+
+  for (i = 0; i < MAX_SMALL_INTEGER; i++) {
+    pointer x = &sc->integer_cells[i];
+    typeflag(x) = T_NUMBER | T_ATOM | MARK;
+    ivalue_unchecked(x) = i;
+    set_num_integer(x);
+  }
+
+  return 0;
+}
+
+static INLINE pointer
+mk_small_integer(scheme *sc, long n)
+{
+#define mk_small_integer_allocates     0
+  assert(0 <= n && n < MAX_SMALL_INTEGER);
+  return &sc->integer_cells[n];
+}
+#else
+
+#define mk_small_integer_allocates     1
+#define mk_small_integer       mk_integer
+
+#endif
+
 /* get number atom (integer) */
-INTERFACE pointer mk_integer(scheme *sc, long num) {
-  pointer x = get_cell(sc,sc->NIL, sc->NIL);
+INTERFACE pointer mk_integer(scheme *sc, long n) {
+  pointer x;
+
+#if USE_SMALL_INTEGERS
+  if (0 <= n && n < MAX_SMALL_INTEGER)
+    return mk_small_integer(sc, n);
+#endif
 
+  x = get_cell(sc,sc->NIL, sc->NIL);
   typeflag(x) = (T_NUMBER | T_ATOM);
-  ivalue_unchecked(x)= num;
+  ivalue_unchecked(x)= n;
   set_num_integer(x);
   return (x);
 }
 
+\f
+
 INTERFACE pointer mk_real(scheme *sc, double n) {
   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 
@@ -975,7 +1226,8 @@ static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
           return sc->strbuff;
      }
      if(str!=0) {
-          snprintf(q, len_str+1, "%s", str);
+         memcpy (q, str, len_str);
+          q[len_str]=0;
      } else {
           memset(q, fill, len_str);
           q[len_str]=0;
@@ -990,7 +1242,7 @@ INTERFACE pointer mk_string(scheme *sc, const char *str) {
 
 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
      pointer x = get_cell(sc, sc->NIL, sc->NIL);
-     typeflag(x) = (T_STRING | T_ATOM);
+     typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
      strvalue(x) = store_string(sc,len,str,0);
      strlength(x) = len;
      return (x);
@@ -998,7 +1250,7 @@ INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
 
 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
      pointer x = get_cell(sc, sc->NIL, sc->NIL);
-     typeflag(x) = (T_STRING | T_ATOM);
+     typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
      strvalue(x) = store_string(sc,len,0,fill);
      strlength(x) = len;
      return (x);
@@ -1009,8 +1261,8 @@ INTERFACE static pointer mk_vector(scheme *sc, int len)
 
 INTERFACE static void fill_vector(pointer vec, pointer obj) {
      int i;
-     int num=ivalue(vec)/2+ivalue(vec)%2;
-     for(i=0; i<num; i++) {
+     int n = ivalue(vec)/2+ivalue(vec)%2;
+     for(i=0; i < n; i++) {
           typeflag(vec+1+i) = T_PAIR;
           setimmutable(vec+1+i);
           car(vec+1+i)=obj;
@@ -1038,6 +1290,7 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
 
 /* get new symbol */
 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
+#define mk_symbol_allocates    oblist_add_by_name_allocates
      pointer x;
 
      /* first check oblist */
@@ -1071,6 +1324,21 @@ INTERFACE pointer gensym(scheme *sc) {
      return sc->NIL;
 }
 
+/* double the size of the string buffer */
+static int expand_strbuff(scheme *sc) {
+  size_t new_size = sc->strbuff_size * 2;
+  char *new_buffer = sc->malloc(new_size);
+  if (new_buffer == 0) {
+    sc->no_memory = 1;
+    return 1;
+  }
+  memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
+  sc->free(sc->strbuff);
+  sc->strbuff = new_buffer;
+  sc->strbuff_size = new_size;
+  return 0;
+}
+
 /* make symbol or number atom from string */
 static pointer mk_atom(scheme *sc, char *q) {
      char    c, *p;
@@ -1206,8 +1474,8 @@ static void mark(pointer a) {
 E2:  setmark(p);
      if(is_vector(p)) {
           int i;
-          int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
-          for(i=0; i<num; i++) {
+          int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
+          for(i=0; i < n; i++) {
                /* Vector cells will be treated like ordinary cells */
                mark(p+1+i);
           }
@@ -1253,6 +1521,8 @@ static void gc(scheme *sc, pointer a, pointer b) {
   pointer p;
   int i;
 
+  assert (gc_enabled (sc));
+
   if(sc->gc_verbose) {
     putstr(sc, "gc...");
   }
@@ -1297,7 +1567,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
     clrmark(p);
       } else {
     /* reclaim cell */
-        if (typeflag(p) != 0) {
+        if (typeflag(p) & T_FINALIZE) {
           finalize_cell(sc, p);
           typeflag(p) = 0;
           car(p) = sc->NIL;
@@ -1323,8 +1593,12 @@ static void finalize_cell(scheme *sc, pointer a) {
     if(a->_object._port->kind&port_file
        && a->_object._port->rep.stdio.closeit) {
       port_close(sc,a,port_input|port_output);
+    } else if (a->_object._port->kind & port_srfi6) {
+      sc->free(a->_object._port->rep.string.start);
     }
     sc->free(a->_object._port);
+  } else if(is_foreign_object(a)) {
+    a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
   }
 }
 
@@ -1549,12 +1823,13 @@ static void backchar(scheme *sc, int c) {
 static int realloc_port_string(scheme *sc, port *p)
 {
   char *start=p->rep.string.start;
+  size_t old_size = p->rep.string.past_the_end - start;
   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
   char *str=sc->malloc(new_size);
   if(str) {
     memset(str,' ',new_size-1);
     str[new_size-1]='\0';
-    strcpy(str,start);
+    memcpy(str, start, old_size);
     p->rep.string.start=str;
     p->rep.string.past_the_end=str+new_size-1;
     p->rep.string.curr-=start-str;
@@ -1612,7 +1887,7 @@ INTERFACE void putcharacter(scheme *sc, int c) {
 static char *readstr_upto(scheme *sc, char *delim) {
   char *p = sc->strbuff;
 
-  while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
+  while ((p - sc->strbuff < sc->strbuff_size) &&
          !is_one_of(delim, (*p++ = inchar(sc))));
 
   if(p == sc->strbuff+2 && p[-2] == '\\') {
@@ -1633,9 +1908,16 @@ static pointer readstrexp(scheme *sc) {
 
   for (;;) {
     c=inchar(sc);
-    if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
+    if(c == EOF) {
       return sc->F;
     }
+    if(p-sc->strbuff > (sc->strbuff_size)-1) {
+      ptrdiff_t offset = p - sc->strbuff;
+      if (expand_strbuff(sc) != 0) {
+        return sc->F;
+      }
+      p = sc->strbuff + offset;
+    }
     switch(state) {
         case st_ok:
             switch(c) {
@@ -1962,7 +2244,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
           }
      } else if (is_string(l)) {
           if (!f) {
-               p = strvalue(l);
+               *pp = strvalue(l);
+              *plen = strlength(l);
+              return;
           } else { /* Hack, uses the fact that printing is needed */
                *pp=sc->strbuff;
                *plen=0;
@@ -2024,6 +2308,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
      } else if (is_continuation(l)) {
           p = "#<CONTINUATION>";
+     } else if (is_foreign_object(l)) {
+          p = sc->strbuff;
+          l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
      } else {
           p = "#<ERROR>";
      }
@@ -2187,14 +2474,19 @@ static void new_frame_in_env(scheme *sc, pointer old_env)
     new_frame = sc->NIL;
   }
 
+  gc_disable(sc, 1);
   sc->envir = immutable_cons(sc, new_frame, old_env);
+  gc_enable(sc);
   setenvironment(sc->envir);
 }
 
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
                                         pointer variable, pointer value)
 {
-  pointer slot = immutable_cons(sc, variable, value);
+#define new_slot_spec_in_env_allocates 2
+  pointer slot;
+  gc_disable(sc, gc_reservations (new_slot_spec_in_env));
+  slot = immutable_cons(sc, variable, value);
 
   if (is_vector(car(env))) {
     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
@@ -2204,6 +2496,7 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
   } else {
     car(env) = immutable_cons(sc, slot, car(env));
   }
+  gc_enable(sc);
 }
 
 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
@@ -2276,11 +2569,13 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
 
 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
 {
+#define new_slot_in_env_allocates      new_slot_spec_in_env_allocates
   new_slot_spec_in_env(sc, sc->envir, variable, value);
 }
 
 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
 {
+  (void)sc;
   cdr(slot) = value;
 }
 
@@ -2351,98 +2646,40 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 /* Too small to turn into function */
 # define  BEGIN     do {
 # define  END  } while (0)
+
+/* Bounce back to Eval_Cycle and execute A.  */
 #define s_goto(sc,a) BEGIN                                  \
     sc->op = (int)(a);                                      \
     return sc->T; END
 
-#define s_return(sc,a) return _s_return(sc,a)
+#if USE_THREADED_CODE
 
-#ifndef USE_SCHEME_STACK
+/* Do not bounce back to Eval_Cycle but execute A by jumping directly
+ * to it.  Only applicable if A is part of the same dispatch
+ * function.  */
+#define s_thread_to(sc, a)     \
+     BEGIN                     \
+     op = (int) (a);           \
+     goto a;                   \
+     END
 
-/* this structure holds all the interpreter's registers */
-struct dump_stack_frame {
-  enum scheme_opcodes op;
-  pointer args;
-  pointer envir;
-  pointer code;
-};
+/* Define a label OP and emit a case statement for OP.  For use in the
+ * dispatch functions.  The slightly peculiar goto that is never
+ * executed avoids warnings about unused labels.  */
+#define CASE(OP)       if (0) goto OP; OP: case OP
 
-#define STACK_GROWTH 3
+#else  /* USE_THREADED_CODE */
+#define s_thread_to(sc, a)     s_goto(sc, a)
+#define CASE(OP)               case OP
+#endif /* USE_THREADED_CODE */
 
-static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
-{
-  int nframes = (int)sc->dump;
-  struct dump_stack_frame *next_frame;
-
-  /* enough room for the next frame? */
-  if (nframes >= sc->dump_size) {
-    sc->dump_size += STACK_GROWTH;
-    /* alas there is no sc->realloc */
-    sc->dump_base = realloc(sc->dump_base,
-                            sizeof(struct dump_stack_frame) * sc->dump_size);
-  }
-  next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
-  next_frame->op = op;
-  next_frame->args = args;
-  next_frame->envir = sc->envir;
-  next_frame->code = code;
-  sc->dump = (pointer)(nframes+1);
-}
-
-static pointer _s_return(scheme *sc, pointer a)
-{
-  int nframes = (int)sc->dump;
-  struct dump_stack_frame *frame;
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A.  */
+#define s_return(sc, a) return _s_return(sc, a, 0)
 
-  sc->value = (a);
-  if (nframes <= 0) {
-    return sc->NIL;
-  }
-  nframes--;
-  frame = (struct dump_stack_frame *)sc->dump_base + nframes;
-  sc->op = frame->op;
-  sc->args = frame->args;
-  sc->envir = frame->envir;
-  sc->code = frame->code;
-  sc->dump = (pointer)nframes;
-  return sc->T;
-}
-
-static INLINE void dump_stack_reset(scheme *sc)
-{
-  /* in this implementation, sc->dump is the number of frames on the stack */
-  sc->dump = (pointer)0;
-}
-
-static INLINE void dump_stack_initialize(scheme *sc)
-{
-  sc->dump_size = 0;
-  sc->dump_base = NULL;
-  dump_stack_reset(sc);
-}
-
-static void dump_stack_free(scheme *sc)
-{
-  free(sc->dump_base);
-  sc->dump_base = NULL;
-  sc->dump = (pointer)0;
-  sc->dump_size = 0;
-}
-
-static INLINE void dump_stack_mark(scheme *sc)
-{
-  int nframes = (int)sc->dump;
-  int i;
-  for(i=0; i<nframes; i++) {
-    struct dump_stack_frame *frame;
-    frame = (struct dump_stack_frame *)sc->dump_base + i;
-    mark(frame->args);
-    mark(frame->envir);
-    mark(frame->code);
-  }
-}
-
-#else
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A, and re-enable the garbage collector.  */
+#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
 
 static INLINE void dump_stack_reset(scheme *sc)
 {
@@ -2459,28 +2696,39 @@ static void dump_stack_free(scheme *sc)
   sc->dump = sc->NIL;
 }
 
-static pointer _s_return(scheme *sc, pointer a) {
-    sc->value = (a);
-    if(sc->dump==sc->NIL) return sc->NIL;
-    sc->op = ivalue(car(sc->dump));
-    sc->args = cadr(sc->dump);
-    sc->envir = caddr(sc->dump);
-    sc->code = cadddr(sc->dump);
-    sc->dump = cddddr(sc->dump);
-    return sc->T;
+static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
+  pointer dump = sc->dump;
+  pointer op;
+  sc->value = (a);
+  if (enable_gc)
+       gc_enable(sc);
+  if (dump == sc->NIL)
+    return sc->NIL;
+  free_cons(sc, dump, &op, &dump);
+  sc->op = ivalue(op);
+#ifndef USE_SMALL_INTEGERS
+  free_cell(sc, op);
+#endif
+  free_cons(sc, dump, &sc->args, &dump);
+  free_cons(sc, dump, &sc->envir, &dump);
+  free_cons(sc, dump, &sc->code, &sc->dump);
+  return sc->T;
 }
 
 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-    sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
-    sc->dump = cons(sc, (args), sc->dump);
-    sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
+#define s_save_allocates       (4 + mk_small_integer_allocates)
+    pointer dump;
+    gc_disable(sc, gc_reservations (s_save));
+    dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
+    dump = cons(sc, (args), dump);
+    sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump);
+    gc_enable(sc);
 }
 
 static INLINE void dump_stack_mark(scheme *sc)
 {
   mark(sc->dump);
 }
-#endif
 
 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
 
@@ -2488,7 +2736,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
      pointer x, y;
 
      switch (op) {
-     case OP_LOAD:       /* load */
+     CASE(OP_LOAD):       /* load */
           if(file_interactive(sc)) {
                fprintf(sc->outport->_object._port->rep.stdio.file,
                "Loading %s\n", strvalue(car(sc->args)));
@@ -2499,16 +2747,17 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
       else
         {
           sc->args = mk_integer(sc,sc->file_i);
-          s_goto(sc,OP_T0LVL);
+          s_thread_to(sc,OP_T0LVL);
         }
 
-     case OP_T0LVL: /* top level */
+     CASE(OP_T0LVL): /* top level */
        /* If we reached the end of file, this loop is done. */
        if(sc->loadport->_object._port->kind & port_saw_EOF)
      {
        if(sc->file_i == 0)
          {
            sc->args=sc->NIL;
+           sc->nesting = sc->nesting_stack[0];
            s_goto(sc,OP_QUIT);
          }
        else
@@ -2535,23 +2784,23 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
-       s_goto(sc,OP_READ_INTERNAL);
+       s_thread_to(sc,OP_READ_INTERNAL);
 
-     case OP_T1LVL: /* top level */
+     CASE(OP_T1LVL): /* top level */
           sc->code = sc->value;
           sc->inport=sc->save_inport;
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_READ_INTERNAL:       /* internal read */
+     CASE(OP_READ_INTERNAL):       /* internal read */
           sc->tok = token(sc);
           if(sc->tok==TOK_EOF)
         { s_return(sc,sc->EOF_OBJ); }
           s_goto(sc,OP_RDSEXPR);
 
-     case OP_GENSYM:
+     CASE(OP_GENSYM):
           s_return(sc, gensym(sc));
 
-     case OP_VALUEPRINT: /* print evaluation result */
+     CASE(OP_VALUEPRINT): /* print evaluation result */
           /* OP_VALUEPRINT is always pushed, because when changing from
              non-interactive to interactive mode, it needs to be
              already on the stack */
@@ -2566,7 +2815,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
          s_return(sc,sc->value);
        }
 
-     case OP_EVAL:       /* main part of evaluation */
+     CASE(OP_EVAL):       /* main part of evaluation */
 #if USE_TRACING
        if(sc->tracing) {
          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
@@ -2576,7 +2825,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
          s_goto(sc,OP_P0LIST);
        }
        /* fall through */
-     case OP_REAL_EVAL:
+     CASE(OP_REAL_EVAL):
 #endif
           if (is_symbol(sc->code)) {    /* symbol */
                x=find_slot_in_env(sc,sc->envir,sc->code,1);
@@ -2593,46 +2842,51 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
                     sc->code = car(sc->code);
-                    s_goto(sc,OP_EVAL);
+                    s_thread_to(sc,OP_EVAL);
                }
           } else {
                s_return(sc,sc->code);
           }
 
-     case OP_E0ARGS:     /* eval arguments */
+     CASE(OP_E0ARGS):     /* eval arguments */
           if (is_macro(sc->value)) {    /* macro expansion */
+              gc_disable(sc, 1 + gc_reservations (s_save));
                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
                sc->args = cons(sc,sc->code, sc->NIL);
+              gc_enable(sc);
                sc->code = sc->value;
-               s_goto(sc,OP_APPLY);
+               s_thread_to(sc,OP_APPLY);
           } else {
                sc->code = cdr(sc->code);
-               s_goto(sc,OP_E1ARGS);
+               s_thread_to(sc,OP_E1ARGS);
           }
 
-     case OP_E1ARGS:     /* eval arguments */
-          sc->args = cons(sc, sc->value, sc->args);
+     CASE(OP_E1ARGS):     /* eval arguments */
+         gc_disable(sc, 1);
+         sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           if (is_pair(sc->code)) { /* continue */
                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
                sc->code = car(sc->code);
                sc->args = sc->NIL;
-               s_goto(sc,OP_EVAL);
+               s_thread_to(sc,OP_EVAL);
           } else {  /* end */
                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
                sc->code = car(sc->args);
                sc->args = cdr(sc->args);
-               s_goto(sc,OP_APPLY);
+               s_thread_to(sc,OP_APPLY);
           }
 
 #if USE_TRACING
-     case OP_TRACING: {
+     CASE(OP_TRACING): {
        int tr=sc->tracing;
        sc->tracing=ivalue(car(sc->args));
-       s_return(sc,mk_integer(sc,tr));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_integer(sc, tr));
      }
 #endif
 
-     case OP_APPLY:      /* apply 'code' to 'args' */
+     CASE(OP_APPLY):      /* apply 'code' to 'args' */
 #if USE_TRACING
        if(sc->tracing) {
          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
@@ -2642,7 +2896,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
          s_goto(sc,OP_P0LIST);
        }
        /* fall through */
-     case OP_REAL_APPLY:
+     CASE(OP_REAL_APPLY):
 #endif
           if (is_proc(sc->code)) {
                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
@@ -2660,7 +2914,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                for (x = car(closure_code(sc->code)), y = sc->args;
                     is_pair(x); x = cdr(x), y = cdr(y)) {
                     if (y == sc->NIL) {
-                         Error_0(sc,"not enough arguments");
+                         Error_1(sc, "not enough arguments, missing:", x);
                     } else {
                          new_slot_in_env(sc, car(x), car(y));
                     }
@@ -2678,45 +2932,49 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                }
                sc->code = cdr(closure_code(sc->code));
                sc->args = sc->NIL;
-               s_goto(sc,OP_BEGIN);
+               s_thread_to(sc,OP_BEGIN);
           } else if (is_continuation(sc->code)) { /* CONTINUATION */
                sc->dump = cont_dump(sc->code);
                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
           } else {
-               Error_0(sc,"illegal function");
+               Error_1(sc,"illegal function",sc->code);
           }
 
-     case OP_DOMACRO:    /* do macro */
+     CASE(OP_DOMACRO):    /* do macro */
           sc->code = sc->value;
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-#if 1
-     case OP_LAMBDA:     /* lambda */
+#if USE_COMPILE_HOOK
+     CASE(OP_LAMBDA):     /* lambda */
           /* If the hook is defined, apply it to sc->code, otherwise
-             set sc->value fall thru */
+             set sc->value fall through */
           {
                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
                if(f==sc->NIL) {
                     sc->value = sc->code;
                     /* Fallthru */
                } else {
+                   gc_disable(sc, 1 + gc_reservations (s_save));
                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
                     sc->args=cons(sc,sc->code,sc->NIL);
+                   gc_enable(sc);
                     sc->code=slot_value_in_env(f);
-                    s_goto(sc,OP_APPLY);
+                    s_thread_to(sc,OP_APPLY);
                }
           }
 
-     case OP_LAMBDA1:
-          s_return(sc,mk_closure(sc, sc->value, sc->envir));
-
 #else
-     case OP_LAMBDA:     /* lambda */
-          s_return(sc,mk_closure(sc, sc->code, sc->envir));
-
+     CASE(OP_LAMBDA):     /* lambda */
+         sc->value = sc->code;
+         /* Fallthrough. */
 #endif
 
-     case OP_MKCLOSURE: /* make-closure */
+     CASE(OP_LAMBDA1):
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
+
+
+     CASE(OP_MKCLOSURE): /* make-closure */
        x=car(sc->args);
        if(car(x)==sc->LAMBDA) {
          x=cdr(x);
@@ -2726,18 +2984,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
        } else {
          y=cadr(sc->args);
        }
-       s_return(sc,mk_closure(sc, x, y));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_closure(sc, x, y));
 
-     case OP_QUOTE:      /* quote */
+     CASE(OP_QUOTE):      /* quote */
           s_return(sc,car(sc->code));
 
-     case OP_DEF0:  /* define */
+     CASE(OP_DEF0):  /* define */
           if(is_immutable(car(sc->code)))
             Error_1(sc,"define: unable to alter immutable", car(sc->code));
 
           if (is_pair(car(sc->code))) {
                x = caar(sc->code);
+              gc_disable(sc, 2);
                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+              gc_enable(sc);
           } else {
                x = car(sc->code);
                sc->code = cadr(sc->code);
@@ -2746,9 +3007,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                Error_0(sc,"variable is not a symbol");
           }
           s_save(sc,OP_DEF1, sc->NIL, x);
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_DEF1:  /* define */
+     CASE(OP_DEF1):  /* define */
           x=find_slot_in_env(sc,sc->envir,sc->code,0);
           if (x != sc->NIL) {
                set_slot_in_env(sc, x, sc->value);
@@ -2758,21 +3019,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,sc->code);
 
 
-     case OP_DEFP:  /* defined? */
+     CASE(OP_DEFP):  /* defined? */
           x=sc->envir;
           if(cdr(sc->args)!=sc->NIL) {
                x=cadr(sc->args);
           }
           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
 
-     case OP_SET0:       /* set! */
+     CASE(OP_SET0):       /* set! */
           if(is_immutable(car(sc->code)))
                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
           sc->code = cadr(sc->code);
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_SET1:       /* set! */
+     CASE(OP_SET1):       /* set! */
           y=find_slot_in_env(sc,sc->envir,sc->code,1);
           if (y != sc->NIL) {
                set_slot_in_env(sc, y, sc->value);
@@ -2782,7 +3043,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           }
 
 
-     case OP_BEGIN:      /* begin */
+     CASE(OP_BEGIN):      /* begin */
           if (!is_pair(sc->code)) {
                s_return(sc,sc->code);
           }
@@ -2790,46 +3051,50 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
           }
           sc->code = car(sc->code);
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_IF0:        /* if */
+     CASE(OP_IF0):        /* if */
           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
           sc->code = car(sc->code);
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_IF1:        /* if */
+     CASE(OP_IF1):        /* if */
           if (is_true(sc->value))
                sc->code = car(sc->code);
           else
                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
                                             * car(sc->NIL) = sc->NIL */
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_LET0:       /* let */
+     CASE(OP_LET0):       /* let */
           sc->args = sc->NIL;
           sc->value = sc->code;
           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
-          s_goto(sc,OP_LET1);
+          s_thread_to(sc,OP_LET1);
 
-     case OP_LET1:       /* let (calculate parameters) */
+     CASE(OP_LET1):       /* let (calculate parameters) */
+         gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
           sc->args = cons(sc, sc->value, sc->args);
           if (is_pair(sc->code)) { /* continue */
                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+                   gc_enable(sc);
                     Error_1(sc, "Bad syntax of binding spec in let :",
                             car(sc->code));
                }
                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
+              gc_enable(sc);
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
-               s_goto(sc,OP_EVAL);
+               s_thread_to(sc,OP_EVAL);
           } else {  /* end */
+              gc_enable(sc);
                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
                sc->code = car(sc->args);
                sc->args = cdr(sc->args);
-               s_goto(sc,OP_LET2);
+               s_thread_to(sc,OP_LET2);
           }
 
-     case OP_LET2:       /* let */
+     CASE(OP_LET2):       /* let */
           new_frame_in_env(sc, sc->envir);
           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
                y != sc->NIL; x = cdr(x), y = cdr(y)) {
@@ -2841,47 +3106,51 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                         Error_1(sc, "Bad syntax of binding in let :", x);
                     if (!is_list(sc, car(x)))
                         Error_1(sc, "Bad syntax of binding in let :", car(x));
+                   gc_disable(sc, 1);
                     sc->args = cons(sc, caar(x), sc->args);
+                   gc_enable(sc);
                }
+              gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
                new_slot_in_env(sc, car(sc->code), x);
+              gc_enable(sc);
                sc->code = cddr(sc->code);
                sc->args = sc->NIL;
           } else {
                sc->code = cdr(sc->code);
                sc->args = sc->NIL;
           }
-          s_goto(sc,OP_BEGIN);
+          s_thread_to(sc,OP_BEGIN);
 
-     case OP_LET0AST:    /* let* */
+     CASE(OP_LET0AST):    /* let* */
           if (car(sc->code) == sc->NIL) {
                new_frame_in_env(sc, sc->envir);
                sc->code = cdr(sc->code);
-               s_goto(sc,OP_BEGIN);
+               s_thread_to(sc,OP_BEGIN);
           }
           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
           }
           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
           sc->code = cadaar(sc->code);
-          s_goto(sc,OP_EVAL);
+          s_thread_to(sc,OP_EVAL);
 
-     case OP_LET1AST:    /* let* (make new frame) */
+     CASE(OP_LET1AST):    /* let* (make new frame) */
           new_frame_in_env(sc, sc->envir);
-          s_goto(sc,OP_LET2AST);
+          s_thread_to(sc,OP_LET2AST);
 
-     case OP_LET2AST:    /* let* (calculate parameters) */
+     CASE(OP_LET2AST):    /* let* (calculate parameters) */
           new_slot_in_env(sc, caar(sc->code), sc->value);
           sc->code = cdr(sc->code);
           if (is_pair(sc->code)) { /* continue */
                s_save(sc,OP_LET2AST, sc->args, sc->code);
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
-               s_goto(sc,OP_EVAL);
+               s_thread_to(sc,OP_EVAL);
           } else {  /* end */
                sc->code = sc->args;
                sc->args = sc->NIL;
-               s_goto(sc,OP_BEGIN);
+               s_thread_to(sc,OP_BEGIN);
           }
      default:
           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
@@ -2894,15 +3163,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
      pointer x, y;
 
      switch (op) {
-     case OP_LET0REC:    /* letrec */
+     CASE(OP_LET0REC):    /* letrec */
           new_frame_in_env(sc, sc->envir);
           sc->args = sc->NIL;
           sc->value = sc->code;
           sc->code = car(sc->code);
-          s_goto(sc,OP_LET1REC);
+          s_thread_to(sc,OP_LET1REC);
 
-     case OP_LET1REC:    /* letrec (calculate parameters) */
+     CASE(OP_LET1REC):    /* letrec (calculate parameters) */
+         gc_disable(sc, 1);
           sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           if (is_pair(sc->code)) { /* continue */
                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                     Error_1(sc, "Bad syntax of binding spec in letrec :",
@@ -2916,10 +3187,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
                sc->code = car(sc->args);
                sc->args = cdr(sc->args);
-               s_goto(sc,OP_LET2REC);
+               s_thread_to(sc,OP_LET2REC);
           }
 
-     case OP_LET2REC:    /* letrec */
+     CASE(OP_LET2REC):    /* letrec */
           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
                new_slot_in_env(sc, caar(x), car(y));
           }
@@ -2927,7 +3198,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           sc->args = sc->NIL;
           s_goto(sc,OP_BEGIN);
 
-     case OP_COND0:      /* cond */
+     CASE(OP_COND0):      /* cond */
           if (!is_pair(sc->code)) {
                Error_0(sc,"syntax error in cond");
           }
@@ -2935,7 +3206,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           sc->code = caar(sc->code);
           s_goto(sc,OP_EVAL);
 
-     case OP_COND1:      /* cond */
+     CASE(OP_COND1):      /* cond */
           if (is_true(sc->value)) {
                if ((sc->code = cdar(sc->code)) == sc->NIL) {
                     s_return(sc,sc->value);
@@ -2944,8 +3215,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                     if(!is_pair(cdr(sc->code))) {
                          Error_0(sc,"syntax error in cond");
                     }
+                   gc_disable(sc, 4);
                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
+                   gc_enable(sc);
                     s_goto(sc,OP_EVAL);
                }
                s_goto(sc,OP_BEGIN);
@@ -2959,12 +3232,13 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                }
           }
 
-     case OP_DELAY:      /* delay */
+     CASE(OP_DELAY):      /* delay */
+         gc_disable(sc, 2);
           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
           typeflag(x)=T_PROMISE;
-          s_return(sc,x);
+          s_return_enable_gc(sc,x);
 
-     case OP_AND0:       /* and */
+     CASE(OP_AND0):       /* and */
           if (sc->code == sc->NIL) {
                s_return(sc,sc->T);
           }
@@ -2972,7 +3246,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           sc->code = car(sc->code);
           s_goto(sc,OP_EVAL);
 
-     case OP_AND1:       /* and */
+     CASE(OP_AND1):       /* and */
           if (is_false(sc->value)) {
                s_return(sc,sc->value);
           } else if (sc->code == sc->NIL) {
@@ -2983,7 +3257,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                s_goto(sc,OP_EVAL);
           }
 
-     case OP_OR0:        /* or */
+     CASE(OP_OR0):        /* or */
           if (sc->code == sc->NIL) {
                s_return(sc,sc->F);
           }
@@ -2991,7 +3265,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           sc->code = car(sc->code);
           s_goto(sc,OP_EVAL);
 
-     case OP_OR1:        /* or */
+     CASE(OP_OR1):        /* or */
           if (is_true(sc->value)) {
                s_return(sc,sc->value);
           } else if (sc->code == sc->NIL) {
@@ -3002,21 +3276,24 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                s_goto(sc,OP_EVAL);
           }
 
-     case OP_C0STREAM:   /* cons-stream */
+     CASE(OP_C0STREAM):   /* cons-stream */
           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
           sc->code = car(sc->code);
           s_goto(sc,OP_EVAL);
 
-     case OP_C1STREAM:   /* cons-stream */
+     CASE(OP_C1STREAM):   /* cons-stream */
           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
+         gc_disable(sc, 3);
           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
           typeflag(x)=T_PROMISE;
-          s_return(sc,cons(sc, sc->args, x));
+          s_return_enable_gc(sc, cons(sc, sc->args, x));
 
-     case OP_MACRO0:     /* macro */
+     CASE(OP_MACRO0):     /* macro */
           if (is_pair(car(sc->code))) {
                x = caar(sc->code);
+              gc_disable(sc, 2);
                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+              gc_enable(sc);
           } else {
                x = car(sc->code);
                sc->code = cadr(sc->code);
@@ -3027,7 +3304,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           s_save(sc,OP_MACRO1, sc->NIL, x);
           s_goto(sc,OP_EVAL);
 
-     case OP_MACRO1:     /* macro */
+     CASE(OP_MACRO1):     /* macro */
           typeflag(sc->value) = T_MACRO;
           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
           if (x != sc->NIL) {
@@ -3037,12 +3314,12 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           }
           s_return(sc,sc->code);
 
-     case OP_CASE0:      /* case */
+     CASE(OP_CASE0):      /* case */
           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
           sc->code = car(sc->code);
           s_goto(sc,OP_EVAL);
 
-     case OP_CASE1:      /* case */
+     CASE(OP_CASE1):      /* case */
           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
                if (!is_pair(y = caar(x))) {
                     break;
@@ -3069,29 +3346,31 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                s_return(sc,sc->NIL);
           }
 
-     case OP_CASE2:      /* case */
+     CASE(OP_CASE2):      /* case */
           if (is_true(sc->value)) {
                s_goto(sc,OP_BEGIN);
           } else {
                s_return(sc,sc->NIL);
           }
 
-     case OP_PAPPLY:     /* apply */
+     CASE(OP_PAPPLY):     /* apply */
           sc->code = car(sc->args);
           sc->args = list_star(sc,cdr(sc->args));
           /*sc->args = cadr(sc->args);*/
           s_goto(sc,OP_APPLY);
 
-     case OP_PEVAL: /* eval */
+     CASE(OP_PEVAL): /* eval */
           if(cdr(sc->args)!=sc->NIL) {
                sc->envir=cadr(sc->args);
           }
           sc->code = car(sc->args);
           s_goto(sc,OP_EVAL);
 
-     case OP_CONTINUATION:    /* call-with-current-continuation */
+     CASE(OP_CONTINUATION):    /* call-with-current-continuation */
           sc->code = car(sc->args);
+         gc_disable(sc, 2);
           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
+         gc_enable(sc);
           s_goto(sc,OP_APPLY);
 
      default:
@@ -3101,6 +3380,52 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
      return sc->T;
 }
 
+#if USE_PLIST
+static pointer
+get_property(scheme *sc, pointer obj, pointer key)
+{
+  pointer x;
+
+  assert (is_symbol(obj));
+  assert (is_symbol(key));
+
+  for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+    if (caar(x) == key)
+      break;
+  }
+
+  if (x != sc->NIL)
+    return cdar(x);
+
+  return sc->NIL;
+}
+
+static pointer
+set_property(scheme *sc, pointer obj, pointer key, pointer value)
+{
+#define set_property_allocates 2
+  pointer x;
+
+  assert (is_symbol(obj));
+  assert (is_symbol(key));
+
+  for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+    if (caar(x) == key)
+      break;
+  }
+
+  if (x != sc->NIL)
+    cdar(x) = value;
+  else {
+    gc_disable(sc, gc_reservations(set_property));
+    symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
+    gc_enable(sc);
+  }
+
+  return sc->T;
+}
+#endif
+
 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
      pointer x;
      num v;
@@ -3110,7 +3435,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
 
      switch (op) {
 #if USE_MATH
-     case OP_INEX2EX:    /* inexact->exact */
+     CASE(OP_INEX2EX):    /* inexact->exact */
           x=car(sc->args);
           if(num_is_integer(x)) {
                s_return(sc,x);
@@ -3120,35 +3445,35 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                Error_1(sc,"inexact->exact: not integral:",x);
           }
 
-     case OP_EXP:
+     CASE(OP_EXP):
           x=car(sc->args);
           s_return(sc, mk_real(sc, exp(rvalue(x))));
 
-     case OP_LOG:
+     CASE(OP_LOG):
           x=car(sc->args);
           s_return(sc, mk_real(sc, log(rvalue(x))));
 
-     case OP_SIN:
+     CASE(OP_SIN):
           x=car(sc->args);
           s_return(sc, mk_real(sc, sin(rvalue(x))));
 
-     case OP_COS:
+     CASE(OP_COS):
           x=car(sc->args);
           s_return(sc, mk_real(sc, cos(rvalue(x))));
 
-     case OP_TAN:
+     CASE(OP_TAN):
           x=car(sc->args);
           s_return(sc, mk_real(sc, tan(rvalue(x))));
 
-     case OP_ASIN:
+     CASE(OP_ASIN):
           x=car(sc->args);
           s_return(sc, mk_real(sc, asin(rvalue(x))));
 
-     case OP_ACOS:
+     CASE(OP_ACOS):
           x=car(sc->args);
           s_return(sc, mk_real(sc, acos(rvalue(x))));
 
-     case OP_ATAN:
+     CASE(OP_ATAN):
           x=car(sc->args);
           if(cdr(sc->args)==sc->NIL) {
                s_return(sc, mk_real(sc, atan(rvalue(x))));
@@ -3157,11 +3482,11 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
           }
 
-     case OP_SQRT:
+     CASE(OP_SQRT):
           x=car(sc->args);
           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
 
-     case OP_EXPT: {
+     CASE(OP_EXPT): {
           double result;
           int real_result=1;
           pointer y=cadr(sc->args);
@@ -3190,15 +3515,15 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
      }
 
-     case OP_FLOOR:
+     CASE(OP_FLOOR):
           x=car(sc->args);
           s_return(sc, mk_real(sc, floor(rvalue(x))));
 
-     case OP_CEILING:
+     CASE(OP_CEILING):
           x=car(sc->args);
           s_return(sc, mk_real(sc, ceil(rvalue(x))));
 
-     case OP_TRUNCATE : {
+     CASE(OP_TRUNCATE ): {
           double rvalue_of_x ;
           x=car(sc->args);
           rvalue_of_x = rvalue(x) ;
@@ -3209,28 +3534,30 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
      }
 
-     case OP_ROUND:
+     CASE(OP_ROUND):
         x=car(sc->args);
         if (num_is_integer(x))
             s_return(sc, x);
         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
 #endif
 
-     case OP_ADD:        /* + */
+     CASE(OP_ADD):        /* + */
        v=num_zero;
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          v=num_add(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_MUL:        /* * */
+     CASE(OP_MUL):        /* * */
        v=num_one;
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          v=num_mul(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_SUB:        /* - */
+     CASE(OP_SUB):        /* - */
        if(cdr(sc->args)==sc->NIL) {
          x=sc->args;
          v=num_zero;
@@ -3241,9 +3568,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
        for (; x != sc->NIL; x = cdr(x)) {
          v=num_sub(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_DIV:        /* / */
+     CASE(OP_DIV):        /* / */
        if(cdr(sc->args)==sc->NIL) {
          x=sc->args;
          v=num_one;
@@ -3258,9 +3586,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
            Error_0(sc,"/: division by zero");
          }
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_INTDIV:        /* quotient */
+     CASE(OP_INTDIV):        /* quotient */
           if(cdr(sc->args)==sc->NIL) {
                x=sc->args;
                v=num_one;
@@ -3275,37 +3604,40 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                     Error_0(sc,"quotient: division by zero");
                }
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_REM:        /* remainder */
+     CASE(OP_REM):        /* remainder */
           v = nvalue(car(sc->args));
           if (ivalue(cadr(sc->args)) != 0)
                v=num_rem(v,nvalue(cadr(sc->args)));
           else {
                Error_0(sc,"remainder: division by zero");
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_MOD:        /* modulo */
+     CASE(OP_MOD):        /* modulo */
           v = nvalue(car(sc->args));
           if (ivalue(cadr(sc->args)) != 0)
                v=num_mod(v,nvalue(cadr(sc->args)));
           else {
                Error_0(sc,"modulo: division by zero");
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
-     case OP_CAR:        /* car */
+     CASE(OP_CAR):        /* car */
           s_return(sc,caar(sc->args));
 
-     case OP_CDR:        /* cdr */
+     CASE(OP_CDR):        /* cdr */
           s_return(sc,cdar(sc->args));
 
-     case OP_CONS:       /* cons */
+     CASE(OP_CONS):       /* cons */
           cdr(sc->args) = cadr(sc->args);
           s_return(sc,sc->args);
 
-     case OP_SETCAR:     /* set-car! */
+     CASE(OP_SETCAR):     /* set-car! */
        if(!is_immutable(car(sc->args))) {
          caar(sc->args) = cadr(sc->args);
          s_return(sc,car(sc->args));
@@ -3313,7 +3645,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
          Error_0(sc,"set-car!: unable to alter immutable pair");
        }
 
-     case OP_SETCDR:     /* set-cdr! */
+     CASE(OP_SETCDR):     /* set-cdr! */
        if(!is_immutable(car(sc->args))) {
          cdar(sc->args) = cadr(sc->args);
          s_return(sc,car(sc->args));
@@ -3321,36 +3653,41 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
          Error_0(sc,"set-cdr!: unable to alter immutable pair");
        }
 
-     case OP_CHAR2INT: { /* char->integer */
+     CASE(OP_CHAR2INT): { /* char->integer */
           char c;
           c=(char)ivalue(car(sc->args));
-          s_return(sc,mk_integer(sc,(unsigned char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
      }
 
-     case OP_INT2CHAR: { /* integer->char */
+     CASE(OP_INT2CHAR): { /* integer->char */
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
-     case OP_CHARUPCASE: {
+     CASE(OP_CHARUPCASE): {
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
           c=toupper(c);
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
-     case OP_CHARDNCASE: {
+     CASE(OP_CHARDNCASE): {
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
           c=tolower(c);
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
-     case OP_STR2SYM:  /* string->symbol */
-          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
+     CASE(OP_STR2SYM):  /* string->symbol */
+          gc_disable(sc, gc_reservations (mk_symbol));
+          s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
 
-     case OP_STR2ATOM: /* string->atom */ {
+     CASE(OP_STR2ATOM): /* string->atom */ {
           char *s=strvalue(car(sc->args));
           long pf = 0;
           if(cdr(sc->args)!=sc->NIL) {
@@ -3385,12 +3722,13 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
         }
 
-     case OP_SYM2STR: /* symbol->string */
+     CASE(OP_SYM2STR): /* symbol->string */
+         gc_disable(sc, 1);
           x=mk_string(sc,symname(car(sc->args)));
           setimmutable(x);
-          s_return(sc,x);
+          s_return_enable_gc(sc, x);
 
-     case OP_ATOM2STR: /* atom->string */ {
+     CASE(OP_ATOM2STR): /* atom->string */ {
           long pf = 0;
           x=car(sc->args);
           if(cdr(sc->args)!=sc->NIL) {
@@ -3410,13 +3748,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
             char *p;
             int len;
             atom2str(sc,x,(int )pf,&p,&len);
-            s_return(sc,mk_counted_string(sc,p,len));
+           gc_disable(sc, 1);
+            s_return_enable_gc(sc, mk_counted_string(sc, p, len));
           } else {
             Error_1(sc, "atom->string: not an atom:", x);
           }
         }
 
-     case OP_MKSTRING: { /* make-string */
+     CASE(OP_MKSTRING): { /* make-string */
           int fill=' ';
           int len;
 
@@ -3425,13 +3764,15 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           if(cdr(sc->args)!=sc->NIL) {
                fill=charvalue(cadr(sc->args));
           }
-          s_return(sc,mk_empty_string(sc,len,(char)fill));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
      }
 
-     case OP_STRLEN:  /* string-length */
-          s_return(sc,mk_integer(sc,strlength(car(sc->args))));
+     CASE(OP_STRLEN):  /* string-length */
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
 
-     case OP_STRREF: { /* string-ref */
+     CASE(OP_STRREF): { /* string-ref */
           char *str;
           int index;
 
@@ -3443,10 +3784,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
           }
 
-          s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc,
+                            mk_character(sc, ((unsigned char*) str)[index]));
      }
 
-     case OP_STRSET: { /* string-set! */
+     CASE(OP_STRSET): { /* string-set! */
           char *str;
           int index;
           int c;
@@ -3467,7 +3810,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,car(sc->args));
      }
 
-     case OP_STRAPPEND: { /* string-append */
+     CASE(OP_STRAPPEND): { /* string-append */
        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
        int len = 0;
        pointer newstr;
@@ -3477,16 +3820,17 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
           len += strlength(car(x));
        }
+       gc_disable(sc, 1);
        newstr = mk_empty_string(sc, len, ' ');
        /* store the contents of the argument strings into the new string */
        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
            pos += strlength(car(x)), x = cdr(x)) {
            memcpy(pos, strvalue(car(x)), strlength(car(x)));
        }
-       s_return(sc, newstr);
+       s_return_enable_gc(sc, newstr);
      }
 
-     case OP_SUBSTR: { /* substring */
+     CASE(OP_SUBSTR): { /* substring */
           char *str;
           int index0;
           int index1;
@@ -3510,14 +3854,15 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
 
           len=index1-index0;
+         gc_disable(sc, 1);
           x=mk_empty_string(sc,len,' ');
           memcpy(strvalue(x),str+index0,len);
           strvalue(x)[len]=0;
 
-          s_return(sc,x);
+          s_return_enable_gc(sc, x);
      }
 
-     case OP_VECTOR: {   /* vector */
+     CASE(OP_VECTOR): {   /* vector */
           int i;
           pointer vec;
           int len=list_length(sc,sc->args);
@@ -3532,7 +3877,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,vec);
      }
 
-     case OP_MKVECTOR: { /* make-vector */
+     CASE(OP_MKVECTOR): { /* make-vector */
           pointer fill=sc->NIL;
           int len;
           pointer vec;
@@ -3550,10 +3895,11 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,vec);
      }
 
-     case OP_VECLEN:  /* vector-length */
-          s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
+     CASE(OP_VECLEN):  /* vector-length */
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
 
-     case OP_VECREF: { /* vector-ref */
+     CASE(OP_VECREF): { /* vector-ref */
           int index;
 
           index=ivalue(cadr(sc->args));
@@ -3565,7 +3911,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,vector_elem(car(sc->args),index));
      }
 
-     case OP_VECSET: {   /* vector-set! */
+     CASE(OP_VECSET): {   /* vector-set! */
           int index;
 
           if(is_immutable(car(sc->args))) {
@@ -3636,19 +3982,19 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
      int (*comp_func)(num,num)=0;
 
      switch (op) {
-     case OP_NOT:        /* not */
+     CASE(OP_NOT):        /* not */
           s_retbool(is_false(car(sc->args)));
-     case OP_BOOLP:       /* boolean? */
+     CASE(OP_BOOLP):       /* boolean? */
           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
-     case OP_EOFOBJP:       /* boolean? */
+     CASE(OP_EOFOBJP):       /* boolean? */
           s_retbool(car(sc->args) == sc->EOF_OBJ);
-     case OP_NULLP:       /* null? */
+     CASE(OP_NULLP):       /* null? */
           s_retbool(car(sc->args) == sc->NIL);
-     case OP_NUMEQ:      /* = */
-     case OP_LESS:       /* < */
-     case OP_GRE:        /* > */
-     case OP_LEQ:        /* <= */
-     case OP_GEQ:        /* >= */
+     CASE(OP_NUMEQ):      /* = */
+     CASE(OP_LESS):       /* < */
+     CASE(OP_GRE):        /* > */
+     CASE(OP_LEQ):        /* <= */
+     CASE(OP_GEQ):        /* >= */
           switch(op) {
                case OP_NUMEQ: comp_func=num_eq; break;
                case OP_LESS:  comp_func=num_lt; break;
@@ -3668,37 +4014,37 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
            v=nvalue(car(x));
           }
           s_retbool(1);
-     case OP_SYMBOLP:     /* symbol? */
+     CASE(OP_SYMBOLP):     /* symbol? */
           s_retbool(is_symbol(car(sc->args)));
-     case OP_NUMBERP:     /* number? */
+     CASE(OP_NUMBERP):     /* number? */
           s_retbool(is_number(car(sc->args)));
-     case OP_STRINGP:     /* string? */
+     CASE(OP_STRINGP):     /* string? */
           s_retbool(is_string(car(sc->args)));
-     case OP_INTEGERP:     /* integer? */
+     CASE(OP_INTEGERP):     /* integer? */
           s_retbool(is_integer(car(sc->args)));
-     case OP_REALP:     /* real? */
+     CASE(OP_REALP):     /* real? */
           s_retbool(is_number(car(sc->args))); /* All numbers are real */
-     case OP_CHARP:     /* char? */
+     CASE(OP_CHARP):     /* char? */
           s_retbool(is_character(car(sc->args)));
 #if USE_CHAR_CLASSIFIERS
-     case OP_CHARAP:     /* char-alphabetic? */
+     CASE(OP_CHARAP):     /* char-alphabetic? */
           s_retbool(Cisalpha(ivalue(car(sc->args))));
-     case OP_CHARNP:     /* char-numeric? */
+     CASE(OP_CHARNP):     /* char-numeric? */
           s_retbool(Cisdigit(ivalue(car(sc->args))));
-     case OP_CHARWP:     /* char-whitespace? */
+     CASE(OP_CHARWP):     /* char-whitespace? */
           s_retbool(Cisspace(ivalue(car(sc->args))));
-     case OP_CHARUP:     /* char-upper-case? */
+     CASE(OP_CHARUP):     /* char-upper-case? */
           s_retbool(Cisupper(ivalue(car(sc->args))));
-     case OP_CHARLP:     /* char-lower-case? */
+     CASE(OP_CHARLP):     /* char-lower-case? */
           s_retbool(Cislower(ivalue(car(sc->args))));
 #endif
-     case OP_PORTP:     /* port? */
+     CASE(OP_PORTP):     /* port? */
           s_retbool(is_port(car(sc->args)));
-     case OP_INPORTP:     /* input-port? */
+     CASE(OP_INPORTP):     /* input-port? */
           s_retbool(is_inport(car(sc->args)));
-     case OP_OUTPORTP:     /* output-port? */
+     CASE(OP_OUTPORTP):     /* output-port? */
           s_retbool(is_outport(car(sc->args)));
-     case OP_PROCP:       /* procedure? */
+     CASE(OP_PROCP):       /* procedure? */
           /*--
               * continuation should be procedure by the example
               * (call-with-current-continuation procedure?) ==> #t
@@ -3706,18 +4052,18 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
               */
           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
-     case OP_PAIRP:       /* pair? */
+     CASE(OP_PAIRP):       /* pair? */
           s_retbool(is_pair(car(sc->args)));
-     case OP_LISTP:       /* list? */
+     CASE(OP_LISTP):       /* list? */
        s_retbool(list_length(sc,car(sc->args)) >= 0);
 
-     case OP_ENVP:        /* environment? */
+     CASE(OP_ENVP):        /* environment? */
           s_retbool(is_environment(car(sc->args)));
-     case OP_VECTORP:     /* vector? */
+     CASE(OP_VECTORP):     /* vector? */
           s_retbool(is_vector(car(sc->args)));
-     case OP_EQ:         /* eq? */
+     CASE(OP_EQ):         /* eq? */
           s_retbool(car(sc->args) == cadr(sc->args));
-     case OP_EQV:        /* eqv? */
+     CASE(OP_EQV):        /* eqv? */
           s_retbool(eqv(car(sc->args), cadr(sc->args)));
      default:
           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
@@ -3730,7 +4076,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
      pointer x, y;
 
      switch (op) {
-     case OP_FORCE:      /* force */
+     CASE(OP_FORCE):      /* force */
           sc->code = car(sc->args);
           if (is_promise(sc->code)) {
                /* Should change type to closure here */
@@ -3741,13 +4087,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                s_return(sc,sc->code);
           }
 
-     case OP_SAVE_FORCED:     /* Save forced value replacing promise */
+     CASE(OP_SAVE_FORCED):     /* Save forced value replacing promise */
           memcpy(sc->code,sc->value,sizeof(struct cell));
           s_return(sc,sc->value);
 
-     case OP_WRITE:      /* write */
-     case OP_DISPLAY:    /* display */
-     case OP_WRITE_CHAR: /* write-char */
+     CASE(OP_WRITE):      /* write */
+     CASE(OP_DISPLAY):    /* display */
+     CASE(OP_WRITE_CHAR): /* write-char */
           if(is_pair(cdr(sc->args))) {
                if(cadr(sc->args)!=sc->outport) {
                     x=cons(sc,sc->outport,sc->NIL);
@@ -3763,7 +4109,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           }
           s_goto(sc,OP_P0LIST);
 
-     case OP_NEWLINE:    /* newline */
+     CASE(OP_NEWLINE):    /* newline */
           if(is_pair(sc->args)) {
                if(car(sc->args)!=sc->outport) {
                     x=cons(sc,sc->outport,sc->NIL);
@@ -3774,7 +4120,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           putstr(sc, "\n");
           s_return(sc,sc->T);
 
-     case OP_ERR0:  /* error */
+     CASE(OP_ERR0):  /* error */
           sc->retcode=-1;
           if (!is_string(car(sc->args))) {
                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
@@ -3783,9 +4129,9 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           putstr(sc, "Error: ");
           putstr(sc, strvalue(car(sc->args)));
           sc->args = cdr(sc->args);
-          s_goto(sc,OP_ERR1);
+          s_thread_to(sc,OP_ERR1);
 
-     case OP_ERR1:  /* error */
+     CASE(OP_ERR1):  /* error */
           putstr(sc, " ");
           if (sc->args != sc->NIL) {
                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
@@ -3801,13 +4147,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                }
           }
 
-     case OP_REVERSE:   /* reverse */
+     CASE(OP_REVERSE):   /* reverse */
           s_return(sc,reverse(sc, car(sc->args)));
 
-     case OP_LIST_STAR: /* list* */
+     CASE(OP_LIST_STAR): /* list* */
           s_return(sc,list_star(sc,sc->args));
 
-     case OP_APPEND:    /* append */
+     CASE(OP_APPEND):    /* append */
           x = sc->NIL;
           y = sc->args;
           if (y == x) {
@@ -3827,73 +4173,51 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           s_return(sc, reverse_in_place(sc, car(y), x));
 
 #if USE_PLIST
-     case OP_PUT:        /* put */
-          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-               Error_0(sc,"illegal use of put");
-          }
-          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-               if (caar(x) == y) {
-                    break;
-               }
-          }
-          if (x != sc->NIL)
-               cdar(x) = caddr(sc->args);
-          else
-               symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
-                                symprop(car(sc->args)));
-          s_return(sc,sc->T);
-
-     case OP_GET:        /* get */
-          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-               Error_0(sc,"illegal use of get");
-          }
-          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-               if (caar(x) == y) {
-                    break;
-               }
-          }
-          if (x != sc->NIL) {
-               s_return(sc,cdar(x));
-          } else {
-               s_return(sc,sc->NIL);
-          }
+     CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
+         gc_disable(sc, gc_reservations(set_property));
+          s_return_enable_gc(sc,
+                            set_property(sc, car(sc->args),
+                                         cadr(sc->args), caddr(sc->args)));
+
+     CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
+         s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
 #endif /* USE_PLIST */
-     case OP_QUIT:       /* quit */
+     CASE(OP_QUIT):       /* quit */
           if(is_pair(sc->args)) {
                sc->retcode=ivalue(car(sc->args));
           }
           return (sc->NIL);
 
-     case OP_GC:         /* gc */
+     CASE(OP_GC):         /* gc */
           gc(sc, sc->NIL, sc->NIL);
           s_return(sc,sc->T);
 
-     case OP_GCVERB:          /* gc-verbose */
+     CASE(OP_GCVERB):          /* gc-verbose */
      {    int  was = sc->gc_verbose;
 
           sc->gc_verbose = (car(sc->args) != sc->F);
           s_retbool(was);
      }
 
-     case OP_NEWSEGMENT: /* new-segment */
+     CASE(OP_NEWSEGMENT): /* new-segment */
           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
                Error_0(sc,"new-segment: argument must be a number");
           }
           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
           s_return(sc,sc->T);
 
-     case OP_OBLIST: /* oblist */
+     CASE(OP_OBLIST): /* oblist */
           s_return(sc, oblist_all_symbols(sc));
 
-     case OP_CURR_INPORT: /* current-input-port */
+     CASE(OP_CURR_INPORT): /* current-input-port */
           s_return(sc,sc->inport);
 
-     case OP_CURR_OUTPORT: /* current-output-port */
+     CASE(OP_CURR_OUTPORT): /* current-output-port */
           s_return(sc,sc->outport);
 
-     case OP_OPEN_INFILE: /* open-input-file */
-     case OP_OPEN_OUTFILE: /* open-output-file */
-     case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
+     CASE(OP_OPEN_INFILE): /* open-input-file */
+     CASE(OP_OPEN_OUTFILE): /* open-output-file */
+     CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
           int prop=0;
           pointer p;
           switch(op) {
@@ -3912,8 +4236,8 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
      }
 
 #if USE_STRING_PORTS
-     case OP_OPEN_INSTRING: /* open-input-string */
-     case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
+     CASE(OP_OPEN_INSTRING): /* open-input-string */
+     CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ {
           int prop=0;
           pointer p;
           switch(op) {
@@ -3928,7 +4252,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           }
           s_return(sc,p);
      }
-     case OP_OPEN_OUTSTRING: /* open-output-string */ {
+     CASE(OP_OPEN_OUTSTRING): /* open-output-string */ {
           pointer p;
           if(car(sc->args)==sc->NIL) {
                p=port_from_scratch(sc);
@@ -3945,7 +4269,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           }
           s_return(sc,p);
      }
-     case OP_GET_OUTSTRING: /* get-output-string */ {
+     CASE(OP_GET_OUTSTRING): /* get-output-string */ {
           port *p;
 
           if ((p=car(sc->args)->_object._port)->kind&port_string) {
@@ -3968,18 +4292,18 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
      }
 #endif
 
-     case OP_CLOSE_INPORT: /* close-input-port */
+     CASE(OP_CLOSE_INPORT): /* close-input-port */
           port_close(sc,car(sc->args),port_input);
           s_return(sc,sc->T);
 
-     case OP_CLOSE_OUTPORT: /* close-output-port */
+     CASE(OP_CLOSE_OUTPORT): /* close-output-port */
           port_close(sc,car(sc->args),port_output);
           s_return(sc,sc->T);
 
-     case OP_INT_ENV: /* interaction-environment */
+     CASE(OP_INT_ENV): /* interaction-environment */
           s_return(sc,sc->global_env);
 
-     case OP_CURR_ENV: /* current-environment */
+     CASE(OP_CURR_ENV): /* current-environment */
           s_return(sc,sc->envir);
 
      }
@@ -3998,7 +4322,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
 
      switch (op) {
      /* ========== reading part ========== */
-     case OP_READ:
+     CASE(OP_READ):
           if(!is_pair(sc->args)) {
                s_goto(sc,OP_READ_INTERNAL);
           }
@@ -4014,8 +4338,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           s_save(sc,OP_SET_INPORT, x, sc->NIL);
           s_goto(sc,OP_READ_INTERNAL);
 
-     case OP_READ_CHAR: /* read-char */
-     case OP_PEEK_CHAR: /* peek-char */ {
+     CASE(OP_READ_CHAR): /* read-char */
+     CASE(OP_PEEK_CHAR): /* peek-char */ {
           int c;
           if(is_pair(sc->args)) {
                if(car(sc->args)!=sc->inport) {
@@ -4035,7 +4359,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           s_return(sc,mk_character(sc,c));
      }
 
-     case OP_CHAR_READY: /* char-ready? */ {
+     CASE(OP_CHAR_READY): /* char-ready? */ {
           pointer p=sc->inport;
           int res;
           if(is_pair(sc->args)) {
@@ -4045,30 +4369,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           s_retbool(res);
      }
 
-     case OP_SET_INPORT: /* set-input-port */
+     CASE(OP_SET_INPORT): /* set-input-port */
           sc->inport=car(sc->args);
           s_return(sc,sc->value);
 
-     case OP_SET_OUTPORT: /* set-output-port */
+     CASE(OP_SET_OUTPORT): /* set-output-port */
           sc->outport=car(sc->args);
           s_return(sc,sc->value);
 
-     case OP_RDSEXPR:
+     CASE(OP_RDSEXPR):
           switch (sc->tok) {
           case TOK_EOF:
                s_return(sc,sc->EOF_OBJ);
           /* NOTREACHED */
-/*
- * Commented out because we now skip comments in the scanner
- *
-          case TOK_COMMENT: {
-               int c;
-               while ((c=inchar(sc)) != '\n' && c!=EOF)
-                    ;
-               sc->tok = token(sc);
-               s_goto(sc,OP_RDSEXPR);
-          }
-*/
           case TOK_VEC:
                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
                /* fall through */
@@ -4081,30 +4394,30 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                } else {
                     sc->nesting_stack[sc->file_i]++;
                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
-                    s_goto(sc,OP_RDSEXPR);
+                    s_thread_to(sc,OP_RDSEXPR);
                }
           case TOK_QUOTE:
                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
                sc->tok = token(sc);
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           case TOK_BQUOTE:
                sc->tok = token(sc);
                if(sc->tok==TOK_VEC) {
                  s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
                  sc->tok=TOK_LPAREN;
-                 s_goto(sc,OP_RDSEXPR);
+                 s_thread_to(sc,OP_RDSEXPR);
                } else {
                  s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
                }
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           case TOK_COMMA:
                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
                sc->tok = token(sc);
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           case TOK_ATMARK:
                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
                sc->tok = token(sc);
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           case TOK_ATOM:
                s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
           case TOK_DQUOTE:
@@ -4134,17 +4447,11 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           }
           break;
 
-     case OP_RDLIST: {
+     CASE(OP_RDLIST): {
+         gc_disable(sc, 1);
           sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           sc->tok = token(sc);
-/* We now skip comments in the scanner
-          while (sc->tok == TOK_COMMENT) {
-               int c;
-               while ((c=inchar(sc)) != '\n' && c!=EOF)
-                    ;
-               sc->tok = token(sc);
-          }
-*/
           if (sc->tok == TOK_EOF)
                { s_return(sc,sc->EOF_OBJ); }
           else if (sc->tok == TOK_RPAREN) {
@@ -4160,14 +4467,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           } else if (sc->tok == TOK_DOT) {
                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
                sc->tok = token(sc);
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           } else {
                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
-               s_goto(sc,OP_RDSEXPR);
+               s_thread_to(sc,OP_RDSEXPR);
           }
      }
 
-     case OP_RDDOT:
+     CASE(OP_RDDOT):
           if (token(sc) != TOK_RPAREN) {
                Error_0(sc,"syntax error: illegal dot expression");
           } else {
@@ -4175,26 +4482,35 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
           }
 
-     case OP_RDQUOTE:
-          s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
+     CASE(OP_RDQUOTE):
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->QUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
-     case OP_RDQQUOTE:
-          s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
+     CASE(OP_RDQQUOTE):
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
-     case OP_RDQQUOTEVEC:
-           s_return(sc,cons(sc, mk_symbol(sc,"apply"),
+     CASE(OP_RDQQUOTEVEC):
+         gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
+         s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
            cons(sc, mk_symbol(sc,"vector"),
                  cons(sc,cons(sc, sc->QQUOTE,
                   cons(sc,sc->value,sc->NIL)),
                   sc->NIL))));
 
-     case OP_RDUNQUOTE:
-          s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
+     CASE(OP_RDUNQUOTE):
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
-     case OP_RDUQTSP:
-          s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
+     CASE(OP_RDUQTSP):
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
+                                     cons(sc, sc->value, sc->NIL)));
 
-     case OP_RDVEC:
+     CASE(OP_RDVEC):
           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
           s_goto(sc,OP_EVAL); Cannot be quoted*/
           /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
@@ -4206,11 +4522,11 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           s_goto(sc,OP_VECTOR);
 
      /* ========== printing part ========== */
-     case OP_P0LIST:
+     CASE(OP_P0LIST):
           if(is_vector(sc->args)) {
                putstr(sc,"#(");
                sc->args=cons(sc,sc->args,mk_integer(sc,0));
-               s_goto(sc,OP_PVECFROM);
+               s_thread_to(sc,OP_PVECFROM);
           } else if(is_environment(sc->args)) {
                putstr(sc,"#<ENVIRONMENT>");
                s_return(sc,sc->T);
@@ -4220,36 +4536,36 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
                putstr(sc, "'");
                sc->args = cadr(sc->args);
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
                putstr(sc, "`");
                sc->args = cadr(sc->args);
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
                putstr(sc, ",");
                sc->args = cadr(sc->args);
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
                putstr(sc, ",@");
                sc->args = cadr(sc->args);
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           } else {
                putstr(sc, "(");
                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
                sc->args = car(sc->args);
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           }
 
-     case OP_P1LIST:
+     CASE(OP_P1LIST):
           if (is_pair(sc->args)) {
             s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
             putstr(sc, " ");
             sc->args = car(sc->args);
-            s_goto(sc,OP_P0LIST);
+            s_thread_to(sc,OP_P0LIST);
           } else if(is_vector(sc->args)) {
             s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
             putstr(sc, " . ");
-            s_goto(sc,OP_P0LIST);
+            s_thread_to(sc,OP_P0LIST);
           } else {
             if (sc->args != sc->NIL) {
               putstr(sc, " . ");
@@ -4258,7 +4574,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
             putstr(sc, ")");
             s_return(sc,sc->T);
           }
-     case OP_PVECFROM: {
+     CASE(OP_PVECFROM): {
           int i=ivalue_unchecked(cdr(sc->args));
           pointer vec=car(sc->args);
           int len=ivalue_unchecked(vec);
@@ -4272,7 +4588,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                sc->args=elem;
                if (i > 0)
                    putstr(sc," ");
-               s_goto(sc,OP_P0LIST);
+               s_thread_to(sc,OP_P0LIST);
           }
      }
 
@@ -4289,14 +4605,15 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
      long v;
 
      switch (op) {
-     case OP_LIST_LENGTH:     /* length */   /* a.k */
+     CASE(OP_LIST_LENGTH):     /* length */   /* a.k */
           v=list_length(sc,car(sc->args));
           if(v<0) {
                Error_1(sc,"length: not a list:",car(sc->args));
           }
-          s_return(sc,mk_integer(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, v));
 
-     case OP_ASSQ:       /* assq */     /* a.k */
+     CASE(OP_ASSQ):       /* assq */     /* a.k */
           x = car(sc->args);
           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
                if (!is_pair(car(y))) {
@@ -4312,24 +4629,28 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
           }
 
 
-     case OP_GET_CLOSURE:     /* get-closure-code */   /* a.k */
+     CASE(OP_GET_CLOSURE):     /* get-closure-code */   /* a.k */
           sc->args = car(sc->args);
           if (sc->args == sc->NIL) {
                s_return(sc,sc->F);
           } else if (is_closure(sc->args)) {
-               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+              gc_disable(sc, 1);
+               s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+                                          closure_code(sc->value)));
           } else if (is_macro(sc->args)) {
-               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+              gc_disable(sc, 1);
+               s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+                                          closure_code(sc->value)));
           } else {
                s_return(sc,sc->F);
           }
-     case OP_CLOSUREP:        /* closure? */
+     CASE(OP_CLOSUREP):        /* closure? */
           /*
            * Note, macro object is also a closure.
            * Therefore, (closure? <#MACRO>) ==> #t
            */
           s_retbool(is_closure(car(sc->args)));
-     case OP_MACROP:          /* macro? */
+     CASE(OP_MACROP):          /* macro? */
           s_retbool(is_macro(car(sc->args)));
      default:
           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
@@ -4341,7 +4662,11 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
 
 typedef int (*test_predicate)(pointer);
-static int is_any(pointer p) { return 1;}
+
+static int is_any(pointer p) {
+   (void)p;
+   return 1;
+}
 
 static int is_nonneg(pointer p) {
   return ivalue(p)>=0 && is_integer(p);
@@ -4458,10 +4783,11 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
           } while(i<n);
           if(i<n) {
             ok=0;
-            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
+            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
                 pcd->name,
                 i+1,
-                tests[j].kind);
+               tests[j].kind,
+               type_to_string(type(car(arglist))));
           }
         }
       }
@@ -4478,7 +4804,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
     }
     if(sc->no_memory) {
       fprintf(stderr,"No memory!\n");
-      return;
+      exit(1);
     }
   }
 }
@@ -4568,6 +4894,9 @@ static struct scheme_interface vtbl ={
   mk_character,
   mk_vector,
   mk_foreign_func,
+  mk_foreign_object,
+  get_foreign_object_vtable,
+  get_foreign_object_data,
   putstr,
   putcharacter,
 
@@ -4614,7 +4943,8 @@ static struct scheme_interface vtbl ={
   setimmutable,
 
   scheme_load_file,
-  scheme_load_string
+  scheme_load_string,
+  port_from_file
 };
 #endif
 
@@ -4664,15 +4994,33 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->T = &sc->_HASHT;
   sc->F = &sc->_HASHF;
   sc->EOF_OBJ=&sc->_EOF_OBJ;
+
+#if USE_SMALL_INTEGERS
+  if (initialize_small_integers(sc)) {
+    sc->no_memory=1;
+    return 0;
+  }
+#endif
+
   sc->free_cell = &sc->_NIL;
   sc->fcells = 0;
+  sc->inhibit_gc = GC_ENABLED;
+  sc->reserved_cells = 0;
+  sc->reserved_lineno = 0;
   sc->no_memory=0;
   sc->inport=sc->NIL;
   sc->outport=sc->NIL;
   sc->save_inport=sc->NIL;
   sc->loadport=sc->NIL;
   sc->nesting=0;
+  memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
   sc->interactive_repl=0;
+  sc->strbuff = sc->malloc(STRBUFFSIZE);
+  if (sc->strbuff == 0) {
+     sc->no_memory=1;
+     return 0;
+  }
+  sc->strbuff_size = STRBUFFSIZE;
 
   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
     sc->no_memory=1;
@@ -4684,17 +5032,20 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->tracing=0;
 
   /* init sc->NIL */
-  typeflag(sc->NIL) = (T_ATOM | MARK);
+  typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
   /* init T */
-  typeflag(sc->T) = (T_ATOM | MARK);
+  typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
   car(sc->T) = cdr(sc->T) = sc->T;
   /* init F */
-  typeflag(sc->F) = (T_ATOM | MARK);
+  typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
   car(sc->F) = cdr(sc->F) = sc->F;
+  /* init EOF_OBJ */
+  typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
+  car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
   /* init sink */
-  typeflag(sc->sink) = (T_PAIR | MARK);
-  car(sc->sink) = sc->NIL;
+  typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
+  car(sc->sink) = cdr(sc->sink) = sc->NIL;
   /* init c_nest */
   sc->c_nest = sc->NIL;
 
@@ -4739,7 +5090,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+#if USE_COMPILE_HOOK
   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
+#endif
 
   return !sc->no_memory;
 }
@@ -4794,9 +5147,14 @@ void scheme_deinit(scheme *sc) {
   sc->gc_verbose=0;
   gc(sc,sc->NIL,sc->NIL);
 
+#if USE_SMALL_INTEGERS
+  sc->free(sc->integer_alloc);
+#endif
+
   for(i=0; i<=sc->last_cell_seg; i++) {
     sc->free(sc->alloc_seg[i]);
   }
+  sc->free(sc->strbuff);
 
 #if SHOW_ERROR_LINE
   for(i=0; i<=sc->file_i; i++) {
@@ -4839,6 +5197,11 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
   if(sc->retcode==0) {
     sc->retcode=sc->nesting!=0;
   }
+
+#if SHOW_ERROR_LINE
+  sc->free(sc->load_stack[0].rep.stdio.filename);
+  sc->load_stack[0].rep.stdio.filename = NULL;
+#endif
 }
 
 void scheme_load_string(scheme *sc, const char *cmd) {