gpg,common: Make sure that all fd given are valid.
[gnupg.git] / tests / gpgscm / scheme.c
index 0e31dc5..1265c62 100644 (file)
@@ -29,6 +29,7 @@
 
 #include <assert.h>
 #include <limits.h>
+#include <stdint.h>
 #include <float.h>
 #include <ctype.h>
 
@@ -110,27 +111,43 @@ static const char *strlwr(char *s) {
 # define FIRST_CELLSEGS 3
 #endif
 
+\f
+
+/* Support for immediate values.
+ *
+ * Immediate values are tagged with IMMEDIATE_TAG, which is neither
+ * used in types, nor in pointer values.
+ *
+ * XXX: Currently, we only use this to tag pointers in vectors.  */
+#define IMMEDIATE_TAG          1
+#define is_immediate(p)                ((pointer) ((uintptr_t) (p) &  IMMEDIATE_TAG))
+#define set_immediate(p)       ((pointer) ((uintptr_t) (p) |  IMMEDIATE_TAG))
+#define clr_immediate(p)       ((pointer) ((uintptr_t) (p) & ~IMMEDIATE_TAG))
+
+\f
+
 enum scheme_types {
-  T_STRING=1,
-  T_NUMBER=2,
-  T_SYMBOL=3,
-  T_PROC=4,
-  T_PAIR=5,
-  T_CLOSURE=6,
-  T_CONTINUATION=7,
-  T_FOREIGN=8,
-  T_CHARACTER=9,
-  T_PORT=10,
-  T_VECTOR=11,
-  T_MACRO=12,
-  T_PROMISE=13,
-  T_ENVIRONMENT=14,
-  T_FOREIGN_OBJECT=15,
-  T_BOOLEAN=16,
-  T_NIL=17,
-  T_EOF_OBJ=18,
-  T_SINK=19,
-  T_LAST_SYSTEM_TYPE=19
+  T_STRING=1 << 1,     /* Do not use the lsb, it is used for
+                        * immediate values.  */
+  T_NUMBER=2 << 1,
+  T_SYMBOL=3 << 1,
+  T_PROC=4 << 1,
+  T_PAIR=5 << 1,
+  T_CLOSURE=6 << 1,
+  T_CONTINUATION=7 << 1,
+  T_FOREIGN=8 << 1,
+  T_CHARACTER=9 << 1,
+  T_PORT=10 << 1,
+  T_VECTOR=11 << 1,
+  T_MACRO=12 << 1,
+  T_PROMISE=13 << 1,
+  T_ENVIRONMENT=14 << 1,
+  T_FOREIGN_OBJECT=15 << 1,
+  T_BOOLEAN=16 << 1,
+  T_NIL=17 << 1,
+  T_EOF_OBJ=18 << 1,
+  T_SINK=19 << 1,
+  T_LAST_SYSTEM_TYPE=19 << 1
 };
 
 static const char *
@@ -144,7 +161,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";
@@ -162,9 +179,11 @@ type_to_string (enum scheme_types typ)
 }
 
 /* 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 TYPE_BITS      6
+#define ADJ            (1 << TYPE_BITS)
+#define T_MASKTYPE      (ADJ - 1)
+#define T_TAGGED      1024    /* 0000010000000000 */
+#define T_FINALIZE    2048    /* 0000100000000000 */
 #define T_SYNTAX      4096    /* 0001000000000000 */
 #define T_IMMUTABLE   8192    /* 0010000000000000 */
 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
@@ -207,6 +226,11 @@ INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
 
 INTERFACE static int is_list(scheme *sc, pointer p);
 INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
+/* Given a vector, return it's length.  */
+#define vector_length(v)       (v)->_object._vector._length
+/* Given a vector length, compute the amount of cells required to
+ * represent it.  */
+#define vector_size(len)       (1 + ((len) - 1 + 2) / 3)
 INTERFACE static void fill_vector(pointer vec, pointer obj);
 INTERFACE static pointer vector_elem(pointer vec, int ielem);
 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
@@ -249,7 +273,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
 
@@ -305,6 +329,14 @@ INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
 #define cadddr(p)        car(cdr(cdr(cdr(p))))
 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
 
+#if USE_HISTORY
+static pointer history_flatten(scheme *sc);
+static void history_mark(scheme *sc);
+#else
+# define history_mark(SC)      (void) 0
+# define history_flatten(SC)   (SC)->NIL
+#endif
+
 #if USE_CHAR_CLASSIFIERS
 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
@@ -366,7 +398,7 @@ static int is_ascii_name(const char *name, int *pc) {
 
 #endif
 
-static int file_push(scheme *sc, const char *fname);
+static int file_push(scheme *sc, pointer fname);
 static void file_pop(scheme *sc);
 static int file_interactive(scheme *sc);
 static INLINE int is_one_of(char *s, int c);
@@ -408,7 +440,7 @@ static void printatom(scheme *sc, pointer l, int f);
 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
 static pointer mk_closure(scheme *sc, pointer c, pointer e);
 static pointer mk_continuation(scheme *sc, pointer d);
-static pointer reverse(scheme *sc, pointer a);
+static pointer reverse(scheme *sc, pointer term, pointer list);
 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
 static pointer revappend(scheme *sc, pointer a, pointer b);
 static void dump_stack_mark(scheme *);
@@ -597,34 +629,100 @@ static long binary_decode(const char *s) {
  return x;
 }
 
+\f
+
+/* Tags are like property lists, but can be attached to arbitrary
+ * values.  */
+
+#if USE_TAGS
+
+static pointer
+mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
+{
+  pointer r, t;
+
+  assert(! is_vector(v));
+
+  r = get_consecutive_cells(sc, 2);
+  if (r == sc->sink)
+    return sc->sink;
+
+  memcpy(r, v, sizeof *v);
+  typeflag(r) |= T_TAGGED;
+
+  t = r + 1;
+  typeflag(t) = T_PAIR;
+  car(t) = tag_car;
+  cdr(t) = tag_cdr;
+
+  return r;
+}
+
+static INLINE int
+has_tag(pointer v)
+{
+  return !! (typeflag(v) & T_TAGGED);
+}
+
+static INLINE pointer
+get_tag(scheme *sc, pointer v)
+{
+  if (has_tag(v))
+    return v + 1;
+  return sc->NIL;
+}
+
+#else
+
+#define mk_tagged_value(SC, X, A, B)   (X)
+#define has_tag(V)                     0
+#define get_tag(SC, V)                 (SC)->NIL
+
+#endif
+
+\f
+
+/* 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 (((uintptr_t) cp) % adj != 0)
+    cp = (void *) (adj * ((uintptr_t) 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;
-     void *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 = 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=(void *)(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];
@@ -653,13 +751,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);
+#ifdef 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 +877,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 +979,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 +1011,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,53 +1032,24 @@ 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;
 }
 
 static pointer get_vector_object(scheme *sc, int len, pointer init)
 {
-  pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
+  pointer cells = get_consecutive_cells(sc, vector_size(len));
   if(sc->no_memory) { return sc->sink; }
   /* Record it as a vector so that gc understands it. */
-  typeflag(cells) = (T_VECTOR | T_ATOM);
-  ivalue_unchecked(cells)=len;
-  set_num_integer(cells);
+  typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE);
+  vector_length(cells) = len;
   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)
-{
-  /* Can't use putstr(sc,str) because callers have no access to
-     sc.  */
-  if(typeflag(p) & !expect_alloced)
-    {
-      fprintf(stderr,"Cell is already allocated!\n");
-    }
-  if(!(typeflag(p)) & expect_alloced)
-    {
-      fprintf(stderr,"Cell is not allocated!\n");
-    }
-
-}
-static void check_range_alloced(pointer p, int n, int expect_alloced)
-{
-  int i;
-  for(i = 0;i<n;i++)
-    { (void)check_cell_alloced(p+i,expect_alloced); }
-}
-
-#endif
-
 /* Medium level cell allocation */
 
 /* get new cons cell */
@@ -865,38 +1073,65 @@ static int hash_fn(const char *key, int table_size);
 
 static pointer oblist_initial_value(scheme *sc)
 {
-  return mk_vector(sc, 461); /* probably should be bigger */
+  /* There are about 768 symbols used after loading the
+   * interpreter.  */
+  return mk_vector(sc, 1009);
 }
 
-/* returns the new symbol */
-static pointer oblist_add_by_name(scheme *sc, const char *name)
+/* Add a new symbol NAME at SLOT.  SLOT must be obtained using
+ * oblist_find_by_name, and no insertion must be done between
+ * obtaining the SLOT and calling this function.  Returns the new
+ * symbol.
+ *
+ * If SLOT is NULL, the new symbol is be placed at the appropriate
+ * place in the vector.  */
+static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot)
 {
+#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));
 
-  location = hash_fn(name, ivalue_unchecked(sc->oblist));
-  set_vector_elem(sc->oblist, location,
-                  immutable_cons(sc, x, vector_elem(sc->oblist, location)));
+  if (slot == NULL) {
+    location = hash_fn(name, vector_length(sc->oblist));
+    set_vector_elem(sc->oblist, location,
+                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
+  } else {
+    *slot = immutable_cons(sc, x, *slot);
+  }
+
+  gc_enable(sc);
   return x;
 }
 
-static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+/* Lookup the symbol NAME.  Returns the symbol, or NIL if it does not
+ * exist.  In that case, SLOT points to the point where the new symbol
+ * is to be inserted.
+ *
+ * SLOT may be set to NULL if the new symbol should be placed at the
+ * appropriate place in the vector.  */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
 {
   int location;
   pointer x;
   char *s;
+  int d;
 
-  location = hash_fn(name, ivalue_unchecked(sc->oblist));
-  for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
+  location = hash_fn(name, vector_length(sc->oblist));
+  for (*slot = NULL, x = vector_elem(sc->oblist, location);
+       x != sc->NIL; *slot = &cdr(x), x = **slot) {
     s = symname(car(x));
     /* case-insensitive, per R5RS section 2. */
-    if(stricmp(name, s) == 0) {
-      return car(x);
-    }
+    d = stricmp(name, s);
+    if (d == 0)
+      return car(x);           /* Hit.  */
+    else if (d > 0)
+      break;                   /* Miss.  */
   }
   return sc->NIL;
 }
@@ -907,7 +1142,7 @@ static pointer oblist_all_symbols(scheme *sc)
   pointer x;
   pointer ob_list = sc->NIL;
 
-  for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
+  for (i = 0; i < vector_length(sc->oblist); i++) {
     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
       ob_list = cons(sc, x, ob_list);
     }
@@ -922,30 +1157,41 @@ static pointer oblist_initial_value(scheme *sc)
   return sc->NIL;
 }
 
-static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+/* Lookup the symbol NAME.  Returns the symbol, or NIL if it does not
+ * exist.  In that case, SLOT points to the point where the new symbol
+ * is to be inserted.  */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
 {
      pointer x;
      char    *s;
+     int     d;
 
-     for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
+     for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) {
         s = symname(car(x));
         /* case-insensitive, per R5RS section 2. */
-        if(stricmp(name, s) == 0) {
-          return car(x);
-        }
+       d = stricmp(name, s);
+        if (d == 0)
+          return car(x);       /* Hit.  */
+        else if (d > 0)
+         break;                /* Miss.  */
      }
      return sc->NIL;
 }
 
-/* returns the new symbol */
-static pointer oblist_add_by_name(scheme *sc, const char *name)
+/* Add a new symbol NAME at SLOT.  SLOT must be obtained using
+ * oblist_find_by_name, and no insertion must be done between
+ * obtaining the SLOT and calling this function.  Returns the new
+ * symbol.  */
+static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot)
 {
+#define oblist_add_by_name_allocates   3
   pointer x;
 
   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
   typeflag(x) = T_SYMBOL;
   setimmutable(car(x));
-  sc->oblist = immutable_cons(sc, x, sc->oblist);
+  *slot = immutable_cons(sc, x, *slot);
   return x;
 }
 static pointer oblist_all_symbols(scheme *sc)
@@ -958,7 +1204,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 +1220,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);
@@ -989,16 +1235,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 n) {
-  pointer x = get_cell(sc,sc->NIL, sc->NIL);
+  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)= 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);
 
@@ -1042,7 +1336,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 +1344,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);
@@ -1060,62 +1354,57 @@ INTERFACE static pointer mk_vector(scheme *sc, int len)
 { return get_vector_object(sc,len,sc->NIL); }
 
 INTERFACE static void fill_vector(pointer vec, pointer obj) {
-     int 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;
-          cdr(vec+1+i)=obj;
+     size_t i;
+     assert (is_vector (vec));
+     for(i = 0; i < vector_length(vec); i++) {
+          vec->_object._vector._elements[i] = set_immediate(obj);
      }
 }
 
 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
-     int n=ielem/2;
-     if(ielem%2==0) {
-          return car(vec+1+n);
-     } else {
-          return cdr(vec+1+n);
-     }
+     assert (is_vector (vec));
+     assert (ielem < vector_length(vec));
+     return clr_immediate(vec->_object._vector._elements[ielem]);
 }
 
 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
-     int n=ielem/2;
-     if(ielem%2==0) {
-          return car(vec+1+n)=a;
-     } else {
-          return cdr(vec+1+n)=a;
-     }
+     assert (is_vector (vec));
+     assert (ielem < vector_length(vec));
+     vec->_object._vector._elements[ielem] = set_immediate(a);
+     return a;
 }
 
 /* get new symbol */
 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
+#define mk_symbol_allocates    oblist_add_by_name_allocates
      pointer x;
+     pointer *slot;
 
      /* first check oblist */
-     x = oblist_find_by_name(sc, name);
+     x = oblist_find_by_name(sc, name, &slot);
      if (x != sc->NIL) {
           return (x);
      } else {
-          x = oblist_add_by_name(sc, name);
+          x = oblist_add_by_name(sc, name, slot);
           return (x);
      }
 }
 
 INTERFACE pointer gensym(scheme *sc) {
      pointer x;
+     pointer *slot;
      char name[40];
 
      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
 
           /* first check oblist */
-          x = oblist_find_by_name(sc, name);
+          x = oblist_find_by_name(sc, name, &slot);
 
           if (x != sc->NIL) {
                continue;
           } else {
-               x = oblist_add_by_name(sc, name);
+              x = oblist_add_by_name(sc, name, slot);
                return (x);
           }
      }
@@ -1145,14 +1434,23 @@ static pointer mk_atom(scheme *sc, char *q) {
      int has_fp_exp = 0;
 
 #if USE_COLON_HOOK
-     if((p=strstr(q,"::"))!=0) {
+     char *next;
+     next = p = q;
+     while ((next = strstr(next, "::")) != 0) {
+         /* Keep looking for the last occurrence.  */
+         p = next;
+         next = next + 2;
+     }
+
+     if (p != q) {
           *p=0;
           return cons(sc, sc->COLON_HOOK,
                           cons(sc,
                               cons(sc,
                                    sc->QUOTE,
-                                   cons(sc, mk_atom(sc,p+2), sc->NIL)),
-                              cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
+                                   cons(sc, mk_symbol(sc, strlwr(p + 2)),
+                                       sc->NIL)),
+                              cons(sc, mk_atom(sc, q), sc->NIL)));
      }
 #endif
 
@@ -1273,12 +1571,22 @@ static void mark(pointer a) {
 E2:  setmark(p);
      if(is_vector(p)) {
           int 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);
+          for (i = 0; i < vector_length(p); i++) {
+               mark(clr_immediate(p->_object._vector._elements[i]));
           }
      }
+#if SHOW_ERROR_LINE
+     else if (is_port(p)) {
+         port *pt = p->_object._port;
+         if (pt->kind & port_file) {
+              mark(pt->rep.stdio.curr_line);
+              mark(pt->rep.stdio.filename);
+         }
+     }
+#endif
+     /* Mark tag if p has one.  */
+     if (has_tag(p))
+       mark(p + 1);
      if (is_atom(p))
           goto E6;
      /* E4: down car */
@@ -1320,6 +1628,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...");
   }
@@ -1332,12 +1642,20 @@ static void gc(scheme *sc, pointer a, pointer b) {
   mark(sc->args);
   mark(sc->envir);
   mark(sc->code);
+  history_mark(sc);
   dump_stack_mark(sc);
   mark(sc->value);
   mark(sc->inport);
   mark(sc->save_inport);
   mark(sc->outport);
   mark(sc->loadport);
+  for (i = 0; i <= sc->file_i; i++) {
+    if (! (sc->load_stack[i].kind & port_file))
+      continue;
+
+    mark(sc->load_stack[i].rep.stdio.filename);
+    mark(sc->load_stack[i].rep.stdio.curr_line);
+  }
 
   /* Mark recent objects the interpreter doesn't know about yet. */
   mark(car(sc->sink));
@@ -1360,16 +1678,18 @@ static void gc(scheme *sc, pointer a, pointer b) {
   for (i = sc->last_cell_seg; i >= 0; i--) {
     p = sc->cell_seg[i] + CELL_SEGSIZE;
     while (--p >= sc->cell_seg[i]) {
+      if (typeflag(p) & IMMEDIATE_TAG)
+        continue;
       if (is_mark(p)) {
     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;
         }
         ++sc->fcells;
+       typeflag(p) = 0;
+        car(p) = sc->NIL;
         cdr(p) = sc->free_cell;
         sc->free_cell = p;
       }
@@ -1396,17 +1716,52 @@ static void finalize_cell(scheme *sc, pointer a) {
     sc->free(a->_object._port);
   } else if(is_foreign_object(a)) {
     a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
+  } else if (is_vector(a)) {
+    int i;
+    for (i = vector_size(vector_length(a)) - 1; i > 0; i--) {
+      pointer p = a + i;
+      typeflag(p) = 0;
+      car(p) = sc->NIL;
+      cdr(p) = sc->free_cell;
+      sc->free_cell = p;
+      sc->fcells += 1;
+    }
   }
 }
 
+#if SHOW_ERROR_LINE
+static void
+port_clear_location (scheme *sc, port *p)
+{
+  assert(p->kind & port_file);
+  p->rep.stdio.curr_line = sc->NIL;
+  p->rep.stdio.filename = sc->NIL;
+}
+
+static void
+port_reset_current_line (scheme *sc, port *p)
+{
+  assert(p->kind & port_file);
+  p->rep.stdio.curr_line = mk_integer(sc, 0);
+}
+
+static void
+port_increment_current_line (scheme *sc, port *p, long delta)
+{
+  assert(p->kind & port_file);
+  p->rep.stdio.curr_line =
+    mk_integer(sc, ivalue_unchecked(p->rep.stdio.curr_line) + delta);
+}
+#endif
+
 /* ========== Routines for Reading ========== */
 
-static int file_push(scheme *sc, const char *fname) {
+static int file_push(scheme *sc, pointer fname) {
   FILE *fin = NULL;
 
   if (sc->file_i == MAXFIL-1)
      return 0;
-  fin=fopen(fname,"r");
+  fin = fopen(string_value(fname), "r");
   if(fin!=0) {
     sc->file_i++;
     sc->load_stack[sc->file_i].kind=port_file|port_input;
@@ -1416,9 +1771,8 @@ static int file_push(scheme *sc, const char *fname) {
     sc->loadport->_object._port=sc->load_stack+sc->file_i;
 
 #if SHOW_ERROR_LINE
-    sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
-    if(fname)
-      sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
+    port_reset_current_line(sc, &sc->load_stack[sc->file_i]);
+    sc->load_stack[sc->file_i].rep.stdio.filename = fname;
 #endif
   }
   return fin!=0;
@@ -1428,6 +1782,10 @@ static void file_pop(scheme *sc) {
  if(sc->file_i != 0) {
    sc->nesting=sc->nesting_stack[sc->file_i];
    port_close(sc,sc->loadport,port_input);
+#if SHOW_ERROR_LINE
+   if (sc->load_stack[sc->file_i].kind & port_file)
+     port_clear_location(sc, &sc->load_stack[sc->file_i]);
+#endif
    sc->file_i--;
    sc->loadport->_object._port=sc->load_stack+sc->file_i;
  }
@@ -1457,10 +1815,12 @@ static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
   pt->rep.stdio.closeit=1;
 
 #if SHOW_ERROR_LINE
-  if(fn)
-    pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
+  if (fn)
+    pt->rep.stdio.filename = mk_string(sc, fn);
+  else
+    pt->rep.stdio.filename = mk_string(sc, "<unknown>");
 
-  pt->rep.stdio.curr_line = 0;
+  port_reset_current_line(sc, pt);
 #endif
   return pt;
 }
@@ -1485,6 +1845,10 @@ static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
     pt->kind = port_file | prop;
     pt->rep.stdio.file = f;
     pt->rep.stdio.closeit = 0;
+#if SHOW_ERROR_LINE
+    pt->rep.stdio.filename = mk_string(sc, "<unknown>");
+    port_reset_current_line(sc, pt);
+#endif
     return pt;
 }
 
@@ -1558,10 +1922,7 @@ static void port_close(scheme *sc, pointer p, int flag) {
 
 #if SHOW_ERROR_LINE
       /* Cleanup is here so (close-*-port) functions could work too */
-      pt->rep.stdio.curr_line = 0;
-
-      if(pt->rep.stdio.filename)
-        sc->free(pt->rep.stdio.filename);
+      port_clear_location(sc, pt);
 #endif
 
       fclose(pt->rep.stdio.file);
@@ -1840,8 +2201,11 @@ static INLINE int skipspace(scheme *sc) {
 
 /* record it */
 #if SHOW_ERROR_LINE
-     if (sc->load_stack[sc->file_i].kind & port_file)
-       sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
+     {
+       port *p = &sc->load_stack[sc->file_i];
+       if (p->kind & port_file)
+        port_increment_current_line(sc, p, curr_line);
+     }
 #endif
 
      if(c!=EOF) {
@@ -1881,7 +2245,7 @@ static int token(scheme *sc) {
 
 #if SHOW_ERROR_LINE
            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
-             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+             port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
 #endif
 
        if(c == EOF)
@@ -1909,7 +2273,7 @@ static int token(scheme *sc) {
 
 #if SHOW_ERROR_LINE
            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
-             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+             port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
 #endif
 
            if(c == EOF)
@@ -2041,7 +2405,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;
@@ -2151,9 +2517,9 @@ static pointer list_star(scheme *sc, pointer d) {
 }
 
 /* reverse list -- produce new list */
-static pointer reverse(scheme *sc, pointer a) {
+static pointer reverse(scheme *sc, pointer term, pointer list) {
 /* a must be checked by gc */
-     pointer p = sc->NIL;
+     pointer a = list, p = term;
 
      for ( ; is_pair(a); a = cdr(a)) {
           p = cons(sc, car(a), p);
@@ -2248,6 +2614,22 @@ static int hash_fn(const char *key, int table_size)
 }
 #endif
 
+/* Compares A and B.  Returns an integer less than, equal to, or
+ * greater than zero if A is stored at a memory location that is
+ * numerical less than, equal to, or greater than that of B.  */
+static int
+pointercmp(pointer a, pointer b)
+{
+  uintptr_t a_n = (uintptr_t) a;
+  uintptr_t b_n = (uintptr_t) b;
+
+  if (a_n < b_n)
+    return -1;
+  if (a_n > b_n)
+    return 1;
+  return 0;
+}
+
 #ifndef USE_ALIST_ENV
 
 /*
@@ -2262,60 +2644,88 @@ static void new_frame_in_env(scheme *sc, pointer old_env)
 {
   pointer new_frame;
 
-  /* The interaction-environment has about 300 variables in it. */
+  /* The interaction-environment has about 480 variables in it. */
   if (old_env == sc->NIL) {
-    new_frame = mk_vector(sc, 461);
+    new_frame = mk_vector(sc, 751);
   } else {
     new_frame = sc->NIL;
   }
 
+  gc_disable(sc, 1);
   sc->envir = immutable_cons(sc, new_frame, old_env);
+  gc_enable(sc);
   setenvironment(sc->envir);
 }
 
+/* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function.
+ *
+ * If SSLOT is NULL, the new slot is put into the appropriate place in
+ * the environment vector.  */
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-                                        pointer variable, pointer value)
+                                        pointer variable, pointer value,
+                                       pointer *sslot)
 {
-  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)));
+  if (sslot == NULL) {
+    int location;
+    assert(is_vector(car(env)));
+    location = hash_fn(symname(variable), vector_length(car(env)));
 
     set_vector_elem(car(env), location,
                     immutable_cons(sc, slot, vector_elem(car(env), location)));
   } else {
-    car(env) = immutable_cons(sc, slot, car(env));
+    *sslot = immutable_cons(sc, slot, *sslot);
   }
+  gc_enable(sc);
 }
 
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+/* Find the slot in ENV under the key HDL.  If ALL is given, look in
+ * all environments enclosing ENV.  If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT.
+ *
+ * SSLOT may be set to NULL if the new symbol should be placed at the
+ * appropriate place in the vector.  */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
 {
   pointer x,y;
   int location;
+  pointer *sl;
+  int d;
+  assert(is_symbol(hdl));
 
   for (x = env; x != sc->NIL; x = cdr(x)) {
     if (is_vector(car(x))) {
-      location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
+      location = hash_fn(symname(hdl), vector_length(car(x)));
+      sl = NULL;
       y = vector_elem(car(x), location);
     } else {
-      y = car(x);
-    }
-    for ( ; y != sc->NIL; y = cdr(y)) {
-              if (caar(y) == hdl) {
-                   break;
-              }
-         }
-         if (y != sc->NIL) {
-              break;
-         }
-         if(!all) {
-           return sc->NIL;
-         }
+      sl = &car(x);
+      y = *sl;
     }
-    if (x != sc->NIL) {
-          return car(y);
+    for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) {
+      d = pointercmp(caar(y), hdl);
+      if (d == 0)
+       return car(y);          /* Hit.  */
+      else if (d > 0)
+       break;                  /* Miss.  */
     }
-    return sc->NIL;
+
+    if (x == env && sslot)
+      *sslot = sl;             /* Insert here.  */
+
+    if (!all)
+      return sc->NIL;          /* Miss, and stop looking.  */
+  }
+
+  return sc->NIL;              /* Not found in any environment.  */
 }
 
 #else /* USE_ALIST_ENV */
@@ -2326,39 +2736,66 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
   setenvironment(sc->envir);
 }
 
+/* Insert (VARIABLE, VALUE) at SSLOT.  SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function.  */
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-                                        pointer variable, pointer value)
+                                        pointer variable, pointer value,
+                                       pointer *sslot)
 {
-  car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
-}
-
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+#define new_slot_spec_in_env_allocates 2
+  (void) env;
+  assert(is_symbol(variable));
+  *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot);
+}
+
+/* Find the slot in ENV under the key HDL.  If ALL is given, look in
+ * all environments enclosing ENV.  If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT.  */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
 {
     pointer x,y;
+    pointer *sl;
+    int d;
+    assert(is_symbol(hdl));
+
     for (x = env; x != sc->NIL; x = cdr(x)) {
-         for (y = car(x); y != sc->NIL; y = cdr(y)) {
-              if (caar(y) == hdl) {
-                   break;
-              }
-         }
-         if (y != sc->NIL) {
-              break;
-         }
-         if(!all) {
-           return sc->NIL;
-         }
-    }
-    if (x != sc->NIL) {
-          return car(y);
+      for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) {
+       d = pointercmp(caar(y), hdl);
+       if (d == 0)
+         return car(y);        /* Hit.  */
+       else if (d > 0)
+         break;                /* Miss.  */
+      }
+
+      if (x == env && sslot)
+       *sslot = sl;            /* Insert here.  */
+
+      if (!all)
+       return sc->NIL;         /* Miss, and stop looking.  */
     }
-    return sc->NIL;
+
+    return sc->NIL;            /* Not found in any environment.  */
 }
 
 #endif /* USE_ALIST_ENV else */
 
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+  return find_slot_spec_in_env(sc, env, hdl, all, NULL);
+}
+
 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
 {
-  new_slot_spec_in_env(sc, sc->envir, variable, value);
+#define new_slot_in_env_allocates      new_slot_spec_in_env_allocates
+  pointer slot;
+  pointer *sslot;
+  assert(is_symbol(variable));
+  slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
+  assert(slot == sc->NIL);
+  new_slot_spec_in_env(sc, sc->envir, variable, value, sslot);
 }
 
 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
@@ -2377,6 +2814,7 @@ static INLINE pointer slot_value_in_env(pointer slot)
 
 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
      const char *str = s;
+     pointer history;
 #if USE_ERROR_HOOK
      pointer x;
      pointer hdl=sc->ERROR_HOOK;
@@ -2384,19 +2822,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 
 #if SHOW_ERROR_LINE
      char sbuf[STRBUFFSIZE];
+#endif
+
+     history = history_flatten(sc);
 
+#if SHOW_ERROR_LINE
      /* make sure error is not in REPL */
      if (sc->load_stack[sc->file_i].kind & port_file &&
          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
-       int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
-       const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+       pointer tag;
+       const char *fname;
+       int ln;
+
+       if (history != sc->NIL && has_tag(car(history))
+          && (tag = get_tag(sc, car(history)))
+          && is_string(car(tag)) && is_integer(cdr(tag))) {
+        fname = string_value(car(tag));
+        ln = ivalue_unchecked(cdr(tag));
+       } else {
+        fname = string_value(sc->load_stack[sc->file_i].rep.stdio.filename);
+        ln = ivalue_unchecked(sc->load_stack[sc->file_i].rep.stdio.curr_line);
+       }
 
        /* should never happen */
        if(!fname) fname = "<unknown>";
 
        /* we started from 0 */
        ln++;
-       snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+       snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
 
        str = (const char*)sbuf;
      }
@@ -2405,11 +2858,15 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 #if USE_ERROR_HOOK
      x=find_slot_in_env(sc,sc->envir,hdl,1);
     if (x != sc->NIL) {
+        sc->code = cons(sc, cons(sc, sc->QUOTE,
+                                 cons(sc, history, sc->NIL)),
+                        sc->NIL);
          if(a!=0) {
-               sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+          sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+                          sc->code);
          } else {
-               sc->code = sc->NIL;
-         }
+          sc->code = cons(sc, sc->F, sc->code);
+        }
          sc->code = cons(sc, mk_string(sc, str), sc->code);
          setimmutable(car(sc->code));
          sc->code = cons(sc, slot_value_in_env(x), sc->code);
@@ -2434,158 +2891,379 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 /* Too small to turn into function */
 # define  BEGIN     do {
 # define  END  } while (0)
+
+\f
+
+/* Flags.  The interpreter has a flags field.  When the interpreter
+ * pushes a frame to the dump stack, it is encoded with the opcode.
+ * Therefore, we do not use the least significant byte.  */
+
+/* Masks used to encode and decode opcode and flags.  */
+#define S_OP_MASK      0x000000ff
+#define S_FLAG_MASK    0xffffff00
+
+/* Set if the interpreter evaluates an expression in a tail context
+ * (see R5RS, section 3.5).  If a function, procedure, or continuation
+ * is invoked while this flag is set, the call is recorded as tail
+ * call in the history buffer.  */
+#define S_FLAG_TAIL_CONTEXT    0x00000100
+
+/* Set flag F.  */
+#define s_set_flag(sc, f)                      \
+          BEGIN                                \
+          (sc)->flags |= S_FLAG_ ## f;         \
+          END
+
+/* Clear flag F.  */
+#define s_clear_flag(sc, f)                    \
+          BEGIN                                \
+          (sc)->flags &= ~ S_FLAG_ ## f;       \
+          END
+
+/* Check if flag F is set.  */
+#define s_get_flag(sc, f)                      \
+          !!((sc)->flags & S_FLAG_ ## f)
+
+\f
+
+/* 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
+
+#else  /* USE_THREADED_CODE */
+#define s_thread_to(sc, a)     s_goto(sc, a)
+#define CASE(OP)               case OP
+#endif /* USE_THREADED_CODE */
+
+/* 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)
 
-#define STACK_GROWTH 3
+/* 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 void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
+static INLINE void dump_stack_reset(scheme *sc)
 {
-  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);
+  sc->dump = sc->NIL;
+}
+
+static INLINE void dump_stack_initialize(scheme *sc)
+{
+  dump_stack_reset(sc);
 }
 
-static pointer _s_return(scheme *sc, pointer a)
+static void dump_stack_free(scheme *sc)
 {
-  int nframes = (int)sc->dump;
-  struct dump_stack_frame *frame;
+  sc->dump = sc->NIL;
+}
 
+static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
+  pointer dump = sc->dump;
+  pointer op;
+  unsigned long v;
   sc->value = (a);
-  if (nframes <= 0) {
+  if (enable_gc)
+       gc_enable(sc);
+  if (dump == sc->NIL)
     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;
+  free_cons(sc, dump, &op, &dump);
+  v = (unsigned long) ivalue_unchecked(op);
+  sc->op = (int) (v & S_OP_MASK);
+  sc->flags = v & S_FLAG_MASK;
+#ifdef USE_SMALL_INTEGERS
+  if (v < MAX_SMALL_INTEGER) {
+    /* This is a small integer, we must not free it.  */
+  } else
+    /* Normal integer.  Recover the cell.  */
+#endif
+    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 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 void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
+#define s_save_allocates       5
+    pointer dump;
+    unsigned long v = sc->flags | ((unsigned long) op);
+    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) v), dump);
+    gc_enable(sc);
 }
 
-static INLINE void dump_stack_initialize(scheme *sc)
+static INLINE void dump_stack_mark(scheme *sc)
 {
-  sc->dump_size = 0;
-  sc->dump_base = NULL;
-  dump_stack_reset(sc);
+  mark(sc->dump);
 }
 
-static void dump_stack_free(scheme *sc)
+\f
+
+#if USE_HISTORY
+
+static void
+history_free(scheme *sc)
 {
-  free(sc->dump_base);
-  sc->dump_base = NULL;
-  sc->dump = (pointer)0;
-  sc->dump_size = 0;
+  sc->free(sc->history.m);
+  sc->history.tailstacks = sc->NIL;
+  sc->history.callstack = sc->NIL;
 }
 
-static INLINE void dump_stack_mark(scheme *sc)
+static pointer
+history_init(scheme *sc, size_t N, size_t M)
 {
-  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);
+  size_t i;
+  struct history *h = &sc->history;
+
+  h->N = N;
+  h->mask_N = N - 1;
+  h->n = N - 1;
+  assert ((N & h->mask_N) == 0);
+
+  h->M = M;
+  h->mask_M = M - 1;
+  assert ((M & h->mask_M) == 0);
+
+  h->callstack = mk_vector(sc, N);
+  if (h->callstack == sc->sink)
+    goto fail;
+
+  h->tailstacks = mk_vector(sc, N);
+  for (i = 0; i < N; i++) {
+    pointer tailstack = mk_vector(sc, M);
+    if (tailstack == sc->sink)
+      goto fail;
+    set_vector_elem(h->tailstacks, i, tailstack);
   }
+
+  h->m = sc->malloc(N * sizeof *h->m);
+  if (h->m == NULL)
+    goto fail;
+
+  for (i = 0; i < N; i++)
+    h->m[i] = 0;
+
+  return sc->T;
+
+fail:
+  history_free(sc);
+  return sc->F;
 }
 
-#else
+static void
+history_mark(scheme *sc)
+{
+  struct history *h = &sc->history;
+  mark(h->callstack);
+  mark(h->tailstacks);
+}
 
-static INLINE void dump_stack_reset(scheme *sc)
+#define add_mod(a, b, mask)    (((a) + (b)) & (mask))
+#define sub_mod(a, b, mask)    add_mod(a, (mask) + 1 - (b), mask)
+
+static INLINE void
+tailstack_clear(scheme *sc, pointer v)
 {
-  sc->dump = sc->NIL;
+  assert(is_vector(v));
+  /* XXX optimize */
+  fill_vector(v, sc->NIL);
 }
 
-static INLINE void dump_stack_initialize(scheme *sc)
+static pointer
+callstack_pop(scheme *sc)
 {
-  dump_stack_reset(sc);
+  struct history *h = &sc->history;
+  size_t n = h->n;
+  pointer item;
+
+  if (h->callstack == sc->NIL)
+    return sc->NIL;
+
+  item = vector_elem(h->callstack, n);
+  /* Clear our frame so that it can be gc'ed and we don't run into it
+   * when walking the history.  */
+  set_vector_elem(h->callstack, n, sc->NIL);
+  tailstack_clear(sc, vector_elem(h->tailstacks, n));
+
+  /* Exit from the frame.  */
+  h->n = sub_mod(h->n, 1, h->mask_N);
+
+  return item;
 }
 
-static void dump_stack_free(scheme *sc)
+static void
+callstack_push(scheme *sc, pointer item)
 {
-  sc->dump = sc->NIL;
+  struct history *h = &sc->history;
+  size_t n = h->n;
+
+  if (h->callstack == sc->NIL)
+    return;
+
+  /* Enter a new frame.  */
+  n = h->n = add_mod(n, 1, h->mask_N);
+
+  /* Initialize tail stack.  */
+  tailstack_clear(sc, vector_elem(h->tailstacks, n));
+  h->m[n] = h->mask_M;
+
+  set_vector_elem(h->callstack, n, item);
 }
 
-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 void
+tailstack_push(scheme *sc, pointer item)
+{
+  struct history *h = &sc->history;
+  size_t n = h->n;
+  size_t m = h->m[n];
+
+  if (h->callstack == sc->NIL)
+    return;
+
+  /* Enter a new tail frame.  */
+  m = h->m[n] = add_mod(m, 1, h->mask_M);
+  set_vector_elem(vector_elem(h->tailstacks, n), m, item);
 }
 
-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);
+static pointer
+tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
+                 pointer acc)
+{
+  struct history *h = &sc->history;
+  pointer frame;
+
+  assert(i <= h->M);
+  assert(n < h->M);
+
+  if (acc == sc->sink)
+    return sc->sink;
+
+  if (i == 0) {
+    /* We reached the end, but we did not see a unused frame.  Signal
+       this using '... .  */
+    return cons(sc, mk_symbol(sc, "..."), acc);
+  }
+
+  frame = vector_elem(tailstack, n);
+  if (frame == sc->NIL) {
+    /* A unused frame.  We reached the end of the history.  */
+    return acc;
+  }
+
+  /* Add us.  */
+  acc = cons(sc, frame, acc);
+
+  return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
+                          acc);
 }
 
-static INLINE void dump_stack_mark(scheme *sc)
+static pointer
+callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
 {
-  mark(sc->dump);
+  struct history *h = &sc->history;
+  pointer frame;
+
+  assert(i <= h->N);
+  assert(n < h->N);
+
+  if (acc == sc->sink)
+    return sc->sink;
+
+  if (i == 0) {
+    /* We reached the end, but we did not see a unused frame.  Signal
+       this using '... .  */
+    return cons(sc, mk_symbol(sc, "..."), acc);
+  }
+
+  frame = vector_elem(h->callstack, n);
+  if (frame == sc->NIL) {
+    /* A unused frame.  We reached the end of the history.  */
+    return acc;
+  }
+
+  /* First, emit the tail calls.  */
+  acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
+                         acc);
+
+  /* Then us.  */
+  acc = cons(sc, frame, acc);
+
+  return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
 }
-#endif
+
+static pointer
+history_flatten(scheme *sc)
+{
+  struct history *h = &sc->history;
+  pointer history;
+
+  if (h->callstack == sc->NIL)
+    return sc->NIL;
+
+  history = callstack_flatten(sc, h->N, h->n, sc->NIL);
+  if (history == sc->sink)
+    return sc->sink;
+
+  return reverse_in_place(sc, sc->NIL, history);
+}
+
+#undef add_mod
+#undef sub_mod
+
+#else  /* USE_HISTORY */
+
+#define history_init(SC, A, B) (void) 0
+#define history_free(SC)       (void) 0
+#define callstack_pop(SC)      (void) 0
+#define callstack_push(SC, X)  (void) 0
+#define tailstack_push(SC, X)  (void) 0
+
+#endif /* USE_HISTORY */
+
+\f
 
 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
 
 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
      pointer x, y;
+     pointer callsite;
 
      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)));
           }
-          if (!file_push(sc,strvalue(car(sc->args)))) {
+          if (!file_push(sc, car(sc->args))) {
                Error_1(sc,"unable to open", car(sc->args));
           }
       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 +3297,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 +3328,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 +3338,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 +3355,69 @@ 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_clear_flag(sc, TAIL_CONTEXT);
+                    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_clear_flag(sc, TAIL_CONTEXT);
+               s_thread_to(sc,OP_APPLY);
           } else {
-               sc->code = cdr(sc->code);
-               s_goto(sc,OP_E1ARGS);
+              gc_disable(sc, 1);
+              sc->args = cons(sc, sc->code, sc->NIL);
+              gc_enable(sc);
+              sc->code = cdr(sc->code);
+               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_clear_flag(sc, TAIL_CONTEXT);
+               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_CODE);
           }
 
 #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' */
+#if USE_HISTORY
+     CASE(OP_CALLSTACK_POP):      /* pop the call stack */
+         callstack_pop(sc);
+         s_return(sc, sc->value);
+#endif
+
+     CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
+                          * record in the history as invoked from
+                          * 'car(args)' */
+         free_cons(sc, sc->args, &callsite, &sc->args);
+         sc->code = car(sc->args);
+         sc->args = cdr(sc->args);
+         /* Fallthrough.  */
+
+     CASE(OP_APPLY):      /* apply 'code' to 'args' */
 #if USE_TRACING
        if(sc->tracing) {
          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
@@ -2726,8 +3427,20 @@ 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 USE_HISTORY
+          if (op != OP_APPLY_CODE)
+            callsite = sc->code;
+          if (s_get_flag(sc, TAIL_CONTEXT)) {
+            /* We are evaluating a tail call.  */
+            tailstack_push(sc, callsite);
+          } else {
+            callstack_push(sc, callsite);
+            s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
+          }
+#endif
+
           if (is_proc(sc->code)) {
                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
           } else if (is_foreign(sc->code))
@@ -2750,11 +3463,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                     }
                }
                if (x == sc->NIL) {
-                    /*--
-                     * if (y != sc->NIL) {
-                     *   Error_0(sc,"too many arguments");
-                     * }
-                     */
+                    if (y != sc->NIL) {
+                      Error_0(sc, "too many arguments");
+                    }
                } else if (is_symbol(x))
                     new_slot_in_env(sc, x, y);
                else {
@@ -2762,7 +3473,8 @@ 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_set_flag(sc, TAIL_CONTEXT);
+               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 +3482,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 +3496,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));
-
 #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);
@@ -2810,18 +3526,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,33 +3549,34 @@ 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 */
-          x=find_slot_in_env(sc,sc->envir,sc->code,0);
+     CASE(OP_DEF1): { /* define */
+         pointer *sslot;
+          x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
           if (x != sc->NIL) {
                set_slot_in_env(sc, x, sc->value);
           } else {
-               new_slot_in_env(sc, sc->code, sc->value);
+              new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
           }
           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,54 +3586,70 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           }
 
 
-     case OP_BEGIN:      /* begin */
-          if (!is_pair(sc->code)) {
-               s_return(sc,sc->code);
-          }
-          if (cdr(sc->code) != sc->NIL) {
-               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
-          }
-          sc->code = car(sc->code);
-          s_goto(sc,OP_EVAL);
+     CASE(OP_BEGIN):      /* begin */
+         {
+           int last;
 
-     case OP_IF0:        /* if */
+           if (!is_pair(sc->code)) {
+             s_return(sc,sc->code);
+           }
+
+           last = cdr(sc->code) == sc->NIL;
+           if (!last) {
+             s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
+           }
+           sc->code = car(sc->code);
+           if (! last)
+             /* This is not the end of the list.  This is not a tail
+              * position.  */
+             s_clear_flag(sc, TAIL_CONTEXT);
+           s_thread_to(sc,OP_EVAL);
+         }
+
+     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_clear_flag(sc, TAIL_CONTEXT);
+          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_clear_flag(sc, TAIL_CONTEXT);
+               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 +3661,53 @@ 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_clear_flag(sc, TAIL_CONTEXT);
+          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_clear_flag(sc, TAIL_CONTEXT);
+               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 +3720,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 :",
@@ -2995,15 +3739,16 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
+              s_clear_flag(sc, TAIL_CONTEXT);
                s_goto(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_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,15 +3756,16 @@ 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");
           }
           s_save(sc,OP_COND1, sc->NIL, sc->code);
           sc->code = caar(sc->code);
+         s_clear_flag(sc, TAIL_CONTEXT);
           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 +3774,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);
@@ -3039,68 +3787,81 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                } else {
                     s_save(sc,OP_COND1, sc->NIL, sc->code);
                     sc->code = caar(sc->code);
+                   s_clear_flag(sc, TAIL_CONTEXT);
                     s_goto(sc,OP_EVAL);
                }
           }
 
-     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);
           }
           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+         if (cdr(sc->code) != sc->NIL)
+              s_clear_flag(sc, TAIL_CONTEXT);
           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) {
                s_return(sc,sc->value);
           } else {
                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+              if (cdr(sc->code) != sc->NIL)
+                   s_clear_flag(sc, TAIL_CONTEXT);
                sc->code = car(sc->code);
                s_goto(sc,OP_EVAL);
           }
 
-     case OP_OR0:        /* or */
+     CASE(OP_OR0):        /* or */
           if (sc->code == sc->NIL) {
                s_return(sc,sc->F);
           }
           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+         if (cdr(sc->code) != sc->NIL)
+              s_clear_flag(sc, TAIL_CONTEXT);
           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) {
                s_return(sc,sc->value);
           } else {
                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+              if (cdr(sc->code) != sc->NIL)
+                   s_clear_flag(sc, TAIL_CONTEXT);
                sc->code = car(sc->code);
                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,22 +3872,25 @@ 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 */
+         pointer *sslot;
           typeflag(sc->value) = T_MACRO;
-          x = find_slot_in_env(sc, sc->envir, sc->code, 0);
+          x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
           if (x != sc->NIL) {
                set_slot_in_env(sc, x, sc->value);
           } else {
-               new_slot_in_env(sc, sc->code, sc->value);
+              new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
           }
           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_clear_flag(sc, TAIL_CONTEXT);
           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 +3917,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:
@@ -3185,6 +3951,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;
@@ -3194,7 +4006,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 +4016,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 +4053,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 +4086,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 +4105,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 +4139,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 +4157,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 +4175,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 +4216,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 +4224,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 +4293,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 +4319,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 +4335,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 +4355,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 +4381,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 +4391,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 +4425,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 +4448,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,22 +4466,23 @@ 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, vector_length(car(sc->args))));
 
-     case OP_VECREF: { /* vector-ref */
+     CASE(OP_VECREF): { /* vector-ref */
           int index;
 
           index=ivalue(cadr(sc->args));
 
-          if(index>=ivalue(car(sc->args))) {
+          if(index >= vector_length(car(sc->args))) {
                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
           }
 
           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))) {
@@ -3657,7 +4490,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
 
           index=ivalue(cadr(sc->args));
-          if(index>=ivalue(car(sc->args))) {
+          if(index >= vector_length(car(sc->args))) {
                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
           }
 
@@ -3720,19 +4553,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 +4585,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 +4623,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 +4647,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 +4658,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 +4680,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 +4691,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 +4700,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 +4718,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                }
           }
 
-     case OP_REVERSE:   /* reverse */
-          s_return(sc,reverse(sc, car(sc->args)));
+     CASE(OP_REVERSE):   /* reverse */
+          s_return(sc,reverse(sc, sc->NIL, 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,73 +4744,74 @@ 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 */
+
+#if USE_TAGS
+     CASE(OP_TAG_VALUE): {      /* not exposed */
+         /* This tags sc->value with car(sc->args).  Useful to tag
+          * results of opcode evaluations.  */
+         pointer a, b, c;
+         free_cons(sc, sc->args, &a, &b);
+         free_cons(sc, b, &b, &c);
+         assert(c == sc->NIL);
+          s_return(sc, mk_tagged_value(sc, sc->value, a, b));
+       }
+
+     CASE(OP_MK_TAGGED):        /* make-tagged-value */
+         if (is_vector(car(sc->args)))
+              Error_0(sc, "cannot tag vector");
+          s_return(sc, mk_tagged_value(sc, car(sc->args),
+                                      car(cadr(sc->args)),
+                                      cdr(cadr(sc->args))));
+
+     CASE(OP_GET_TAG):        /* get-tag */
+         s_return(sc, get_tag(sc, car(sc->args)));
+#endif /* USE_TAGS */
+
+     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 +4830,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 +4846,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 +4863,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 +4886,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 +4916,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 +4932,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 +4953,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 +4963,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 */
@@ -4164,31 +4987,43 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                     Error_0(sc,"syntax error: illegal dot expression");
                } else {
                     sc->nesting_stack[sc->file_i]++;
+#if USE_TAGS && SHOW_ERROR_LINE
+                   if (sc->load_stack[sc->file_i].kind & port_file) {
+                     pointer filename =
+                       sc->load_stack[sc->file_i].rep.stdio.filename;
+                     pointer lineno =
+                       sc->load_stack[sc->file_i].rep.stdio.curr_line;
+
+                     s_save(sc, OP_TAG_VALUE,
+                            cons(sc, filename, cons(sc, lineno, sc->NIL)),
+                            sc->NIL);
+                   }
+#endif
                     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 +5053,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) {
@@ -4237,21 +5066,22 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                  backchar(sc,c);
 #if SHOW_ERROR_LINE
                else if (sc->load_stack[sc->file_i].kind & port_file)
-                  sc->load_stack[sc->file_i].rep.stdio.curr_line++;
+                  port_increment_current_line(sc,
+                                             &sc->load_stack[sc->file_i], 1);
 #endif
                sc->nesting_stack[sc->file_i]--;
                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
           } 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 +5089,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 +5129,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 +5143,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,10 +5181,10 @@ 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);
+          int len = vector_length(vec);
           if(i==len) {
                putstr(sc,")");
                s_return(sc,sc->T);
@@ -4356,7 +5195,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 +5212,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,25 +5236,31 @@ 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)));
+     CASE(OP_VM_HISTORY):          /* *vm-history* */
+          s_return(sc, history_flatten(sc));
      default:
           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
           Error_0(sc,sc->strbuff);
@@ -4576,8 +5422,12 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
 
 static void assign_syntax(scheme *sc, char *name) {
      pointer x;
+     pointer *slot;
+
+     x = oblist_find_by_name(sc, name, &slot);
+     assert (x == sc->NIL);
 
-     x = oblist_add_by_name(sc, name);
+     x = oblist_add_by_name(sc, name, slot);
      typeflag(x) |= T_SYNTAX;
 }
 
@@ -4757,8 +5607,19 @@ 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;
@@ -4782,6 +5643,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   dump_stack_initialize(sc);
   sc->code = sc->NIL;
   sc->tracing=0;
+  sc->op = -1;
+  sc->flags = 0;
 
   /* init sc->NIL */
   typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
@@ -4797,7 +5660,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
   /* init sink */
   typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
-  car(sc->sink) = sc->NIL;
+  car(sc->sink) = cdr(sc->sink) = sc->NIL;
   /* init c_nest */
   sc->c_nest = sc->NIL;
 
@@ -4832,6 +5695,8 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
     }
   }
 
+  history_init(sc, 8, 8);
+
   /* initialization of global pointers to special symbols */
   sc->LAMBDA = mk_symbol(sc, "lambda");
   sc->QUOTE = mk_symbol(sc, "quote");
@@ -4842,7 +5707,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;
 }
@@ -4870,15 +5737,12 @@ void scheme_set_external_data(scheme *sc, void *p) {
 void scheme_deinit(scheme *sc) {
   int i;
 
-#if SHOW_ERROR_LINE
-  char *fname;
-#endif
-
   sc->oblist=sc->NIL;
   sc->global_env=sc->NIL;
   dump_stack_free(sc);
   sc->envir=sc->NIL;
   sc->code=sc->NIL;
+  history_free(sc);
   sc->args=sc->NIL;
   sc->value=sc->NIL;
   if(is_port(sc->inport)) {
@@ -4894,23 +5758,25 @@ void scheme_deinit(scheme *sc) {
     typeflag(sc->loadport) = T_ATOM;
   }
   sc->loadport=sc->NIL;
+
+#if SHOW_ERROR_LINE
+  for(i=0; i<=sc->file_i; i++) {
+    if (sc->load_stack[i].kind & port_file)
+      port_clear_location(sc, &sc->load_stack[i]);
+  }
+#endif
+
   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++) {
-    if (sc->load_stack[i].kind & port_file) {
-      fname = sc->load_stack[i].rep.stdio.filename;
-      if(fname)
-        sc->free(fname);
-    }
-  }
-#endif
 }
 
 void scheme_load_file(scheme *sc, FILE *fin)
@@ -4929,11 +5795,11 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
   }
 
 #if SHOW_ERROR_LINE
-  sc->load_stack[0].rep.stdio.curr_line = 0;
+  port_reset_current_line(sc, &sc->load_stack[0]);
   if(fin!=stdin && filename)
-    sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
+    sc->load_stack[0].rep.stdio.filename = mk_string(sc, filename);
   else
-    sc->load_stack[0].rep.stdio.filename = NULL;
+    sc->load_stack[0].rep.stdio.filename = mk_string(sc, "<unknown>");
 #endif
 
   sc->inport=sc->loadport;
@@ -4945,8 +5811,7 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
   }
 
 #if SHOW_ERROR_LINE
-  sc->free(sc->load_stack[0].rep.stdio.filename);
-  sc->load_stack[0].rep.stdio.filename = NULL;
+  port_clear_location(sc, &sc->load_stack[0]);
 #endif
 }
 
@@ -4972,12 +5837,12 @@ void scheme_load_string(scheme *sc, const char *cmd) {
 
 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
      pointer x;
-
-     x=find_slot_in_env(sc,envir,symbol,0);
+     pointer *sslot;
+     x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot);
      if (x != sc->NIL) {
           set_slot_in_env(sc, x, value);
      } else {
-          new_slot_spec_in_env(sc, envir, symbol, value);
+          new_slot_spec_in_env(sc, envir, symbol, value, sslot);
      }
 }