gpg,common: Make sure that all fd given are valid.
[gnupg.git] / tests / gpgscm / scheme.c
index 86df851..1265c62 100644 (file)
@@ -1050,30 +1050,6 @@ static pointer get_vector_object(scheme *sc, int len, pointer init)
   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 */
@@ -1097,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;
@@ -1112,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, vector_length(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, vector_length(sc->oblist));
-  for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
+  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;
 }
@@ -1157,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)
@@ -1367,31 +1378,33 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
 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);
           }
      }
@@ -2601,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
 
 /*
@@ -2615,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;
   }
@@ -2628,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), vector_length(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), 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 */
@@ -2685,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)
@@ -3474,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;
@@ -3794,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));
@@ -5342,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;
 }
 
@@ -5753,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);
      }
 }