gpg,common: Make sure that all fd given are valid.
[gnupg.git] / tests / gpgscm / scheme.c
index a5b7691..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);
@@ -377,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);
@@ -793,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;
@@ -1018,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 */
@@ -1077,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;
@@ -1092,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;
 }
@@ -1122,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);
     }
@@ -1137,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)
@@ -1323,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);
           }
      }
@@ -1546,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);
@@ -1617,6 +1649,13 @@ static void gc(scheme *sc, pointer a, pointer b) {
   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));
@@ -1639,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 {
@@ -1675,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;
@@ -1695,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;
@@ -1707,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;
  }
@@ -1736,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;
 }
@@ -1764,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;
 }
 
@@ -1837,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);
@@ -2119,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) {
@@ -2160,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)
@@ -2188,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)
@@ -2529,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
 
 /*
@@ -2543,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;
   }
@@ -2556,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);
-    }
-    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 */
@@ -2613,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)
@@ -2691,8 +2840,8 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
         fname = string_value(car(tag));
         ln = ivalue_unchecked(cdr(tag));
        } else {
-        fname = sc->load_stack[sc->file_i].rep.stdio.filename;
-        ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+        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 */
@@ -3105,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
@@ -3314,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 {
@@ -3404,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;
@@ -3724,15 +3872,17 @@ 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));
@@ -4318,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));
           }
 
@@ -4340,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));
           }
 
@@ -4838,15 +4988,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
                } else {
                     sc->nesting_stack[sc->file_i]++;
 #if USE_TAGS && SHOW_ERROR_LINE
-                   {
-                     const char *filename =
+                   if (sc->load_stack[sc->file_i].kind & port_file) {
+                     pointer filename =
                        sc->load_stack[sc->file_i].rep.stdio.filename;
-                     int lineno =
+                     pointer lineno =
                        sc->load_stack[sc->file_i].rep.stdio.curr_line;
 
                      s_save(sc, OP_TAG_VALUE,
-                            cons(sc, mk_string(sc, filename),
-                                 cons(sc, mk_integer(sc, lineno), sc->NIL)),
+                            cons(sc, filename, cons(sc, lineno, sc->NIL)),
                             sc->NIL);
                    }
 #endif
@@ -4917,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));
@@ -5034,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);
@@ -5272,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;
 }
 
@@ -5583,10 +5737,6 @@ 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);
@@ -5608,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);
 
@@ -5619,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)
@@ -5647,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;
@@ -5663,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
 }
 
@@ -5690,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);
      }
 }