gpg,common: Make sure that all fd given are valid.
[gnupg.git] / tests / gpgscm / scheme.c
index c73a832..1265c62 100644 (file)
@@ -111,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 *
@@ -163,9 +179,9 @@ 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 */
@@ -210,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);
@@ -308,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); }
@@ -369,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);
@@ -785,7 +814,7 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno)
   if (sc->inhibit_gc == 0) {
     reserve_cells(sc, (reserve));
     sc->reserved_cells = (reserve);
-#ifndef NDEBUG
+#ifdef NDEBUG
     (void) lineno;
 #else
     sc->reserved_lineno = lineno;
@@ -1010,42 +1039,17 @@ static pointer get_cell(scheme *sc, pointer a, pointer b)
 
 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);
   if (gc_enabled (sc))
     push_recent_alloc(sc, cells, sc->NIL);
   return cells;
 }
 
-#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 */
@@ -1069,11 +1073,19 @@ 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;
@@ -1084,26 +1096,42 @@ static pointer oblist_add_by_name(scheme *sc, const char *name)
   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;
 }
@@ -1114,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);
     }
@@ -1129,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)
@@ -1315,63 +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);
           }
      }
@@ -1401,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
 
@@ -1529,12 +1571,19 @@ 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);
@@ -1593,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));
@@ -1621,6 +1678,8 @@ 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 {
@@ -1657,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;
@@ -1677,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;
@@ -1689,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;
  }
@@ -1718,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;
 }
@@ -1746,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;
 }
 
@@ -1819,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);
@@ -2101,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) {
@@ -2142,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)
@@ -2170,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)
@@ -2511,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
 
 /*
@@ -2525,9 +2644,9 @@ 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;
   }
@@ -2538,53 +2657,75 @@ static 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.
+ *
+ * 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)
 {
 #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);
+      sl = &car(x);
+      y = *sl;
     }
-    for ( ; 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 ( ; 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 */
@@ -2595,40 +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));
+#define new_slot_spec_in_env_allocates 2
+  (void) env;
+  assert(is_symbol(variable));
+  *sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot);
 }
 
-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.  */
+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)
 {
 #define new_slot_in_env_allocates      new_slot_spec_in_env_allocates
-  new_slot_spec_in_env(sc, sc->envir, variable, value);
+  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)
@@ -2647,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;
@@ -2654,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;
      }
@@ -2675,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);
@@ -2705,6 +2892,40 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 # 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);                                      \
@@ -2757,16 +2978,23 @@ static void dump_stack_free(scheme *sc)
 static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
   pointer dump = sc->dump;
   pointer op;
+  unsigned long v;
   sc->value = (a);
   if (enable_gc)
        gc_enable(sc);
   if (dump == sc->NIL)
     return sc->NIL;
   free_cons(sc, dump, &op, &dump);
-  sc->op = ivalue(op);
-#ifndef USE_SMALL_INTEGERS
-  free_cell(sc, op);
+  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);
@@ -2774,12 +3002,13 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
 }
 
 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-#define s_save_allocates       (4 + mk_small_integer_allocates)
+#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_small_integer(sc, (long)(op)), dump);
+    sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
     gc_enable(sc);
 }
 
@@ -2788,10 +3017,236 @@ static INLINE void dump_stack_mark(scheme *sc)
   mark(sc->dump);
 }
 
+\f
+
+#if USE_HISTORY
+
+static void
+history_free(scheme *sc)
+{
+  sc->free(sc->history.m);
+  sc->history.tailstacks = sc->NIL;
+  sc->history.callstack = sc->NIL;
+}
+
+static pointer
+history_init(scheme *sc, size_t N, size_t M)
+{
+  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;
+}
+
+static void
+history_mark(scheme *sc)
+{
+  struct history *h = &sc->history;
+  mark(h->callstack);
+  mark(h->tailstacks);
+}
+
+#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)
+{
+  assert(is_vector(v));
+  /* XXX optimize */
+  fill_vector(v, sc->NIL);
+}
+
+static pointer
+callstack_pop(scheme *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
+callstack_push(scheme *sc, pointer item)
+{
+  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 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 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 pointer
+callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
+{
+  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);
+}
+
+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 */
@@ -2799,7 +3254,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                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
@@ -2900,6 +3355,7 @@ 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_clear_flag(sc, TAIL_CONTEXT);
                     s_thread_to(sc,OP_EVAL);
                }
           } else {
@@ -2913,9 +3369,13 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                sc->args = cons(sc,sc->code, sc->NIL);
               gc_enable(sc);
                sc->code = sc->value;
+              s_clear_flag(sc, TAIL_CONTEXT);
                s_thread_to(sc,OP_APPLY);
           } else {
-               sc->code = cdr(sc->code);
+              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);
           }
 
@@ -2927,12 +3387,11 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
                sc->code = car(sc->code);
                sc->args = sc->NIL;
+              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_thread_to(sc,OP_APPLY);
+               s_thread_to(sc,OP_APPLY_CODE);
           }
 
 #if USE_TRACING
@@ -2944,6 +3403,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
      }
 #endif
 
+#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) {
@@ -2956,6 +3429,18 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
        /* fall through */
      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))
@@ -2978,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 {
@@ -2990,6 +3473,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                }
                sc->code = cdr(closure_code(sc->code));
                sc->args = sc->NIL;
+              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);
@@ -3067,15 +3551,16 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           s_save(sc,OP_DEF1, sc->NIL, x);
           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? */
           x=sc->envir;
@@ -3102,18 +3587,29 @@ 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_thread_to(sc,OP_EVAL);
+         {
+           int last;
+
+           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_clear_flag(sc, TAIL_CONTEXT);
           s_thread_to(sc,OP_EVAL);
 
      CASE(OP_IF1):        /* if */
@@ -3143,6 +3639,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
               gc_enable(sc);
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
+              s_clear_flag(sc, TAIL_CONTEXT);
                s_thread_to(sc,OP_EVAL);
           } else {  /* end */
               gc_enable(sc);
@@ -3191,6 +3688,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           }
           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
           sc->code = cadaar(sc->code);
+         s_clear_flag(sc, TAIL_CONTEXT);
           s_thread_to(sc,OP_EVAL);
 
      CASE(OP_LET1AST):    /* let* (make new frame) */
@@ -3204,6 +3702,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                s_save(sc,OP_LET2AST, sc->args, sc->code);
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
+              s_clear_flag(sc, TAIL_CONTEXT);
                s_thread_to(sc,OP_EVAL);
           } else {  /* end */
                sc->code = sc->args;
@@ -3240,6 +3739,7 @@ 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);
@@ -3262,6 +3762,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           }
           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 */
@@ -3286,6 +3787,7 @@ 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);
                }
           }
@@ -3301,6 +3803,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                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);
 
@@ -3311,6 +3815,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                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);
           }
@@ -3320,6 +3826,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                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);
 
@@ -3330,6 +3838,8 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                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);
           }
@@ -3362,19 +3872,22 @@ 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 */
           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 */
@@ -3955,14 +4468,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
 
      CASE(OP_VECLEN):  /* vector-length */
          gc_disable(sc, 1);
-          s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
+          s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args))));
 
      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));
           }
 
@@ -3977,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));
           }
 
@@ -4474,6 +4987,18 @@ 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_thread_to(sc,OP_RDSEXPR);
                }
@@ -4541,7 +5066,8 @@ 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));
@@ -4658,7 +5184,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
      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);
@@ -4733,6 +5259,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
           s_retbool(is_closure(car(sc->args)));
      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);
@@ -4894,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_add_by_name(sc, name);
+     x = oblist_find_by_name(sc, name, &slot);
+     assert (x == sc->NIL);
+
+     x = oblist_add_by_name(sc, name, slot);
      typeflag(x) |= T_SYNTAX;
 }
 
@@ -5111,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);
@@ -5161,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");
@@ -5201,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)) {
@@ -5225,6 +5758,14 @@ 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);
 
@@ -5236,16 +5777,6 @@ void scheme_deinit(scheme *sc) {
     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)
@@ -5264,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;
@@ -5280,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
 }
 
@@ -5307,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);
      }
 }