gpgscm: Fix string.
[gnupg.git] / tests / gpgscm / scheme.c
index 0e31dc5..fe8b9dd 100644 (file)
@@ -144,7 +144,7 @@ type_to_string (enum scheme_types typ)
      case T_PROC: return "proc";
      case T_PAIR: return "pair";
      case T_CLOSURE: return "closure";
-     case T_CONTINUATION: return "configuration";
+     case T_CONTINUATION: return "continuation";
      case T_FOREIGN: return "foreign";
      case T_CHARACTER: return "character";
      case T_PORT: return "port";
@@ -165,6 +165,7 @@ type_to_string (enum scheme_types typ)
 #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 */
@@ -653,13 +654,119 @@ 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.  */
+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);
 }
 
@@ -672,6 +779,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);
@@ -773,6 +881,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 */
 
@@ -785,6 +913,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)
 {
@@ -795,7 +934,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;
 }
 
@@ -808,16 +948,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)
 {
@@ -871,9 +1006,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));
@@ -881,6 +1018,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;
 }
 
@@ -958,7 +1096,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);
 }
@@ -974,7 +1112,7 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) {
 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);
+  typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
   x->_object._foreign_object._vtable=vtable;
   x->_object._foreign_object._data = data;
   return (x);
@@ -1042,7 +1180,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);
@@ -1050,7 +1188,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);
@@ -1090,6 +1228,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 */
@@ -1320,6 +1459,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...");
   }
@@ -1364,7 +1505,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;
@@ -2041,7 +2182,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;
@@ -2269,14 +2412,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)));
@@ -2286,6 +2434,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)
@@ -2358,6 +2507,7 @@ 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);
 }
 
@@ -2434,98 +2584,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 STACK_GROWTH 3
+/* 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
 
-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);
-}
+#else  /* USE_THREADED_CODE */
+#define s_thread_to(sc, a)     s_goto(sc, a)
+#define CASE(OP)               case OP
+#endif /* USE_THREADED_CODE */
 
-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)
 {
@@ -2542,28 +2634,37 @@ 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);
+  free_cell(sc, op);
+  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       5
+    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_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)
 
@@ -2571,7 +2672,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)));
@@ -2582,10 +2683,10 @@ 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)
      {
@@ -2619,23 +2720,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 */
@@ -2650,7 +2751,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);*/
@@ -2660,7 +2761,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);
@@ -2677,46 +2778,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);
@@ -2726,7 +2832,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 */
@@ -2762,7 +2868,7 @@ 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);
@@ -2770,12 +2876,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                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 through */
           {
@@ -2784,23 +2890,27 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                     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));
+     CASE(OP_LAMBDA1):
+         gc_disable(sc, 1);
+          s_return_enable_gc(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 */
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir));
 
 #endif
 
-     case OP_MKCLOSURE: /* make-closure */
+     CASE(OP_MKCLOSURE): /* make-closure */
        x=car(sc->args);
        if(car(x)==sc->LAMBDA) {
          x=cdr(x);
@@ -2810,18 +2920,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);
@@ -2830,9 +2943,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);
@@ -2842,21 +2955,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);
@@ -2866,7 +2979,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);
           }
@@ -2874,28 +2987,29 @@ 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))) {
@@ -2903,17 +3017,19 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                             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)) {
@@ -2925,47 +3041,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);
@@ -2978,15 +3098,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 :",
@@ -3000,10 +3122,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));
           }
@@ -3011,7 +3133,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");
           }
@@ -3019,7 +3141,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);
@@ -3028,8 +3150,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);
@@ -3043,12 +3167,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);
           }
@@ -3056,7 +3181,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) {
@@ -3067,7 +3192,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);
           }
@@ -3075,7 +3200,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) {
@@ -3086,21 +3211,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);
@@ -3111,7 +3239,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) {
@@ -3121,12 +3249,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;
@@ -3153,29 +3281,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:
@@ -3194,7 +3324,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);
@@ -3204,35 +3334,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))));
@@ -3241,11 +3371,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);
@@ -3274,15 +3404,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) ;
@@ -3293,28 +3423,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;
@@ -3325,9 +3457,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;
@@ -3342,9 +3475,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;
@@ -3359,37 +3493,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));
@@ -3397,7 +3534,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));
@@ -3405,36 +3542,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) {
@@ -3469,12 +3611,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) {
@@ -3494,13 +3637,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;
 
@@ -3509,13 +3653,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;
 
@@ -3527,10 +3673,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;
@@ -3551,7 +3699,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;
@@ -3561,16 +3709,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;
@@ -3594,14 +3743,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);
@@ -3616,7 +3766,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;
@@ -3634,10 +3784,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));
@@ -3649,7 +3800,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))) {
@@ -3720,19 +3871,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;
@@ -3752,37 +3903,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
@@ -3790,18 +3941,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);
@@ -3814,7 +3965,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 */
@@ -3825,13 +3976,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);
@@ -3847,7 +3998,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);
@@ -3858,7 +4009,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);
@@ -3867,9 +4018,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);
@@ -3885,13 +4036,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) {
@@ -3911,7 +4062,7 @@ 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 */
+     CASE(OP_PUT):        /* put */
           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
                Error_0(sc,"illegal use of put");
           }
@@ -3927,7 +4078,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                                 symprop(car(sc->args)));
           s_return(sc,sc->T);
 
-     case OP_GET:        /* get */
+     CASE(OP_GET):        /* get */
           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
                Error_0(sc,"illegal use of get");
           }
@@ -3942,42 +4093,42 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                s_return(sc,sc->NIL);
           }
 #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) {
@@ -3996,8 +4147,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) {
@@ -4012,7 +4163,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);
@@ -4029,7 +4180,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) {
@@ -4052,18 +4203,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);
 
      }
@@ -4082,7 +4233,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);
           }
@@ -4098,8 +4249,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) {
@@ -4119,7 +4270,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)) {
@@ -4129,30 +4280,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 */
@@ -4165,30 +4305,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:
@@ -4218,17 +4358,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) {
@@ -4244,14 +4378,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 {
@@ -4259,26 +4393,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);
@@ -4290,11 +4433,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);
@@ -4304,36 +4447,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, " . ");
@@ -4342,7 +4485,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);
@@ -4356,7 +4499,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);
           }
      }
 
@@ -4373,14 +4516,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))) {
@@ -4396,24 +4540,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);
@@ -4759,6 +4907,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->EOF_OBJ=&sc->_EOF_OBJ;
   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;
@@ -4842,7 +4993,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;
 }