gpgscm: Fix initialization of 'sink'.
[gnupg.git] / tests / gpgscm / scheme.c
index 105d2a1..673d199 100644 (file)
@@ -144,7 +144,7 @@ type_to_string (enum scheme_types typ)
      case T_PROC: return "proc";
      case T_PAIR: return "pair";
      case T_CLOSURE: return "closure";
-     case T_CONTINUATION: return "configuration";
+     case T_CONTINUATION: return "continuation";
      case T_FOREIGN: return "foreign";
      case T_CHARACTER: return "character";
      case T_PORT: return "port";
@@ -165,6 +165,7 @@ type_to_string (enum scheme_types typ)
 #define ADJ 32
 #define TYPE_BITS 5
 #define T_MASKTYPE      31    /* 0000000000011111 */
+#define T_FINALIZE    2048    /* 0000100000000000 */
 #define T_SYNTAX      4096    /* 0001000000000000 */
 #define T_IMMUTABLE   8192    /* 0010000000000000 */
 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
@@ -249,7 +250,7 @@ INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
 #if USE_PLIST
-SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (typeflag(p)&T_SYMBOL); }
+SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (is_symbol(p)); }
 #define symprop(p)       cdr(p)
 #endif
 
@@ -597,34 +598,47 @@ static long binary_decode(const char *s) {
  return x;
 }
 
+/* Allocate a new cell segment but do not make it available yet.  */
+static int
+_alloc_cellseg(scheme *sc, size_t len, void **alloc, pointer *cells)
+{
+  int adj = ADJ;
+  void *cp;
+
+  if (adj < sizeof(struct cell))
+    adj = sizeof(struct cell);
+
+  cp = sc->malloc(len * sizeof(struct cell) + adj);
+  if (cp == NULL)
+    return 1;
+
+  *alloc = cp;
+
+  /* adjust in TYPE_BITS-bit boundary */
+  if (((unsigned long) cp) % adj != 0)
+    cp = (void *) (adj * ((unsigned long) cp / adj + 1));
+
+  *cells = cp;
+  return 0;
+}
+
 /* allocate new cell segment */
 static int alloc_cellseg(scheme *sc, int n) {
      pointer newp;
      pointer last;
      pointer p;
-     void *cp;
      long i;
      int k;
-     int adj=ADJ;
-
-     if(adj<sizeof(struct cell)) {
-       adj=sizeof(struct cell);
-     }
 
      for (k = 0; k < n; k++) {
          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
               return k;
-         cp = sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
-         if (cp == 0)
-              return k;
-         i = ++sc->last_cell_seg ;
-         sc->alloc_seg[i] = cp;
-         /* adjust in TYPE_BITS-bit boundary */
-         if(((unsigned long)cp)%adj!=0) {
-           cp=(void *)(adj*((unsigned long)cp/adj+1));
-         }
+        i = ++sc->last_cell_seg;
+        if (_alloc_cellseg(sc, CELL_SEGSIZE, &sc->alloc_seg[i], &newp)) {
+             sc->last_cell_seg--;
+             return k;
+        }
          /* insert new segment in address order */
-         newp=(pointer)cp;
          sc->cell_seg[i] = newp;
          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
              p = sc->cell_seg[i];
@@ -653,13 +667,120 @@ static int alloc_cellseg(scheme *sc, int n) {
      return n;
 }
 
+\f
+
+/* Controlling the garbage collector.
+ *
+ * Every time a cell is allocated, the interpreter may run out of free
+ * cells and do a garbage collection.  This is problematic because it
+ * might garbage collect objects that have been allocated, but are not
+ * yet made available to the interpreter.
+ *
+ * Previously, we would plug such newly allocated cells into the list
+ * of newly allocated objects rooted at car(sc->sink), but that
+ * requires allocating yet another cell increasing pressure on the
+ * memory management system.
+ *
+ * A faster alternative is to preallocate the cells needed for an
+ * operation and make sure the garbage collection is not run until all
+ * allocated objects are plugged in.  This can be done with gc_disable
+ * and gc_enable.
+ */
+
+/* The garbage collector is enabled if the inhibit counter is
+ * zero.  */
+#define GC_ENABLED     0
+
+/* For now we provide a way to disable this optimization for
+ * benchmarking and because it produces slightly smaller code.  */
+#ifndef USE_GC_LOCKING
+# define USE_GC_LOCKING 1
+#endif
+
+/* To facilitate nested calls to gc_disable, functions that allocate
+ * more than one cell may define a macro, e.g. foo_allocates.  This
+ * macro can be used to compute the amount of preallocation at the
+ * call site with the help of this macro.  */
+#define gc_reservations(fn) fn ## _allocates
+
+#if USE_GC_LOCKING
+
+/* Report a shortage in reserved cells, and terminate the program.  */
+static void
+gc_reservation_failure(struct scheme *sc)
+{
+#ifdef NDEBUG
+  fprintf(stderr,
+         "insufficient reservation\n")
+#else
+  fprintf(stderr,
+         "insufficient reservation in line %d\n",
+         sc->reserved_lineno);
+#endif
+  abort();
+}
+
+/* Disable the garbage collection and reserve the given number of
+ * cells.  gc_disable may be nested, but the enclosing reservation
+ * must include the reservations of all nested calls.  Note: You must
+ * re-enable the gc before calling Error_X.  */
+static void
+_gc_disable(struct scheme *sc, size_t reserve, int lineno)
+{
+  if (sc->inhibit_gc == 0) {
+    reserve_cells(sc, (reserve));
+    sc->reserved_cells = (reserve);
+#ifndef NDEBUG
+    (void) lineno;
+#else
+    sc->reserved_lineno = lineno;
+#endif
+  } else if (sc->reserved_cells < (reserve))
+    gc_reservation_failure (sc);
+  sc->inhibit_gc += 1;
+}
+#define gc_disable(sc, reserve)                        \
+     _gc_disable (sc, reserve, __LINE__)
+
+/* Enable the garbage collector.  */
+#define gc_enable(sc)                          \
+     do {                                      \
+         assert(sc->inhibit_gc);               \
+         sc->inhibit_gc -= 1;                  \
+     } while (0)
+
+/* Test whether the garbage collector is enabled.  */
+#define gc_enabled(sc)                         \
+     (sc->inhibit_gc == GC_ENABLED)
+
+/* Consume a reserved cell.  */
+#define gc_consume(sc)                                                 \
+     do {                                                              \
+         assert(! gc_enabled (sc));                                    \
+         if (sc->reserved_cells == 0)                                  \
+              gc_reservation_failure (sc);                             \
+         sc->reserved_cells -= 1;                                      \
+     } while (0)
+
+#else /* USE_GC_LOCKING */
+
+#define gc_disable(sc, reserve)        (void) 0
+#define gc_enable(sc)  (void) 0
+#define gc_enabled(sc) 1
+#define gc_consume(sc) (void) 0
+
+#endif /* USE_GC_LOCKING */
+
 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
-  if (sc->free_cell != sc->NIL) {
+  if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
     pointer x = sc->free_cell;
+    if (! gc_enabled (sc))
+        gc_consume (sc);
     sc->free_cell = cdr(x);
     --sc->fcells;
     return (x);
   }
+  assert (gc_enabled (sc));
   return _get_cell (sc, a, b);
 }
 
@@ -672,6 +793,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) {
     return sc->sink;
   }
 
+  assert (gc_enabled (sc));
   if (sc->free_cell == sc->NIL) {
     const int min_to_be_recovered = sc->last_cell_seg*8;
     gc(sc,a, b);
@@ -805,6 +927,17 @@ static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
   car(sc->sink) = holder;
 }
 
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+  pointer a = car(sc->sink), next;
+  car(sc->sink) = sc->NIL;
+  while (a != sc->NIL)
+    {
+      next = cdr(a);
+      free_cell(sc, a);
+      a = next;
+    }
+}
 
 static pointer get_cell(scheme *sc, pointer a, pointer b)
 {
@@ -815,7 +948,8 @@ static pointer get_cell(scheme *sc, pointer a, pointer b)
   typeflag(cell) = T_PAIR;
   car(cell) = a;
   cdr(cell) = b;
-  push_recent_alloc(sc, cell, sc->NIL);
+  if (gc_enabled (sc))
+    push_recent_alloc(sc, cell, sc->NIL);
   return cell;
 }
 
@@ -828,16 +962,11 @@ static pointer get_vector_object(scheme *sc, int len, pointer init)
   ivalue_unchecked(cells)=len;
   set_num_integer(cells);
   fill_vector(cells,init);
-  push_recent_alloc(sc, cells, sc->NIL);
+  if (gc_enabled (sc))
+    push_recent_alloc(sc, cells, sc->NIL);
   return cells;
 }
 
-static INLINE void ok_to_freely_gc(scheme *sc)
-{
-  car(sc->sink) = sc->NIL;
-}
-
-
 #if defined TSGRIND
 static void check_cell_alloced(pointer p, int expect_alloced)
 {
@@ -891,9 +1020,11 @@ static pointer oblist_initial_value(scheme *sc)
 /* returns the new symbol */
 static pointer oblist_add_by_name(scheme *sc, const char *name)
 {
+#define oblist_add_by_name_allocates   3
   pointer x;
   int location;
 
+  gc_disable(sc, gc_reservations (oblist_add_by_name));
   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
   typeflag(x) = T_SYMBOL;
   setimmutable(car(x));
@@ -901,6 +1032,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name)
   location = hash_fn(name, ivalue_unchecked(sc->oblist));
   set_vector_elem(sc->oblist, location,
                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
+  gc_enable(sc);
   return x;
 }
 
@@ -978,7 +1110,7 @@ static pointer oblist_all_symbols(scheme *sc)
 static pointer mk_port(scheme *sc, port *p) {
   pointer x = get_cell(sc, sc->NIL, sc->NIL);
 
-  typeflag(x) = T_PORT|T_ATOM;
+  typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
   x->_object._port=p;
   return (x);
 }
@@ -994,7 +1126,7 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) {
 pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
   pointer x = get_cell(sc, sc->NIL, sc->NIL);
 
-  typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM);
+  typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
   x->_object._foreign_object._vtable=vtable;
   x->_object._foreign_object._data = data;
   return (x);
@@ -1009,16 +1141,64 @@ INTERFACE pointer mk_character(scheme *sc, int c) {
   return (x);
 }
 
+\f
+
+#if USE_SMALL_INTEGERS
+
+/* s_save assumes that all opcodes can be expressed as a small
+ * integer.  */
+#define MAX_SMALL_INTEGER      OP_MAXDEFINED
+
+static int
+initialize_small_integers(scheme *sc)
+{
+  int i;
+  if (_alloc_cellseg(sc, MAX_SMALL_INTEGER, &sc->integer_alloc,
+                    &sc->integer_cells))
+    return 1;
+
+  for (i = 0; i < MAX_SMALL_INTEGER; i++) {
+    pointer x = &sc->integer_cells[i];
+    typeflag(x) = T_NUMBER | T_ATOM | MARK;
+    ivalue_unchecked(x) = i;
+    set_num_integer(x);
+  }
+
+  return 0;
+}
+
+static INLINE pointer
+mk_small_integer(scheme *sc, long n)
+{
+#define mk_small_integer_allocates     0
+  assert(0 <= n && n < MAX_SMALL_INTEGER);
+  return &sc->integer_cells[n];
+}
+#else
+
+#define mk_small_integer_allocates     1
+#define mk_small_integer       mk_integer
+
+#endif
+
 /* get number atom (integer) */
 INTERFACE pointer mk_integer(scheme *sc, long n) {
-  pointer x = get_cell(sc,sc->NIL, sc->NIL);
+  pointer x;
+
+#if USE_SMALL_INTEGERS
+  if (0 <= n && n < MAX_SMALL_INTEGER)
+    return mk_small_integer(sc, n);
+#endif
 
+  x = get_cell(sc,sc->NIL, sc->NIL);
   typeflag(x) = (T_NUMBER | T_ATOM);
   ivalue_unchecked(x)= n;
   set_num_integer(x);
   return (x);
 }
 
+\f
+
 INTERFACE pointer mk_real(scheme *sc, double n) {
   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 
@@ -1062,7 +1242,7 @@ INTERFACE pointer mk_string(scheme *sc, const char *str) {
 
 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
      pointer x = get_cell(sc, sc->NIL, sc->NIL);
-     typeflag(x) = (T_STRING | T_ATOM);
+     typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
      strvalue(x) = store_string(sc,len,str,0);
      strlength(x) = len;
      return (x);
@@ -1070,7 +1250,7 @@ INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
 
 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
      pointer x = get_cell(sc, sc->NIL, sc->NIL);
-     typeflag(x) = (T_STRING | T_ATOM);
+     typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
      strvalue(x) = store_string(sc,len,0,fill);
      strlength(x) = len;
      return (x);
@@ -1110,6 +1290,7 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
 
 /* get new symbol */
 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
+#define mk_symbol_allocates    oblist_add_by_name_allocates
      pointer x;
 
      /* first check oblist */
@@ -1340,6 +1521,8 @@ static void gc(scheme *sc, pointer a, pointer b) {
   pointer p;
   int i;
 
+  assert (gc_enabled (sc));
+
   if(sc->gc_verbose) {
     putstr(sc, "gc...");
   }
@@ -1384,7 +1567,7 @@ static void gc(scheme *sc, pointer a, pointer b) {
     clrmark(p);
       } else {
     /* reclaim cell */
-        if (typeflag(p) != 0) {
+        if (typeflag(p) & T_FINALIZE) {
           finalize_cell(sc, p);
           typeflag(p) = 0;
           car(p) = sc->NIL;
@@ -2291,14 +2474,19 @@ static void new_frame_in_env(scheme *sc, pointer old_env)
     new_frame = sc->NIL;
   }
 
+  gc_disable(sc, 1);
   sc->envir = immutable_cons(sc, new_frame, old_env);
+  gc_enable(sc);
   setenvironment(sc->envir);
 }
 
 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
                                         pointer variable, pointer value)
 {
-  pointer slot = immutable_cons(sc, variable, value);
+#define new_slot_spec_in_env_allocates 2
+  pointer slot;
+  gc_disable(sc, gc_reservations (new_slot_spec_in_env));
+  slot = immutable_cons(sc, variable, value);
 
   if (is_vector(car(env))) {
     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
@@ -2308,6 +2496,7 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
   } else {
     car(env) = immutable_cons(sc, slot, car(env));
   }
+  gc_enable(sc);
 }
 
 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
@@ -2380,6 +2569,7 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
 
 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
 {
+#define new_slot_in_env_allocates      new_slot_spec_in_env_allocates
   new_slot_spec_in_env(sc, sc->envir, variable, value);
 }
 
@@ -2483,7 +2673,13 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
 #define CASE(OP)               case OP
 #endif /* USE_THREADED_CODE */
 
-#define s_return(sc,a) return _s_return(sc,a)
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A.  */
+#define s_return(sc, a) return _s_return(sc, a, 0)
+
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A, and re-enable the garbage collector.  */
+#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
 
 static INLINE void dump_stack_reset(scheme *sc)
 {
@@ -2500,14 +2696,19 @@ static void dump_stack_free(scheme *sc)
   sc->dump = sc->NIL;
 }
 
-static pointer _s_return(scheme *sc, pointer a) {
+static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
   pointer dump = sc->dump;
   pointer op;
   sc->value = (a);
+  if (enable_gc)
+       gc_enable(sc);
   if (dump == sc->NIL)
     return sc->NIL;
   free_cons(sc, dump, &op, &dump);
   sc->op = ivalue(op);
+#ifndef USE_SMALL_INTEGERS
+  free_cell(sc, op);
+#endif
   free_cons(sc, dump, &sc->args, &dump);
   free_cons(sc, dump, &sc->envir, &dump);
   free_cons(sc, dump, &sc->code, &sc->dump);
@@ -2515,9 +2716,13 @@ static pointer _s_return(scheme *sc, pointer a) {
 }
 
 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-    sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
-    sc->dump = cons(sc, (args), sc->dump);
-    sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
+#define s_save_allocates       (4 + mk_small_integer_allocates)
+    pointer dump;
+    gc_disable(sc, gc_reservations (s_save));
+    dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
+    dump = cons(sc, (args), dump);
+    sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump);
+    gc_enable(sc);
 }
 
 static INLINE void dump_stack_mark(scheme *sc)
@@ -2645,8 +2850,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
 
      CASE(OP_E0ARGS):     /* eval arguments */
           if (is_macro(sc->value)) {    /* macro expansion */
+              gc_disable(sc, 1 + gc_reservations (s_save));
                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
                sc->args = cons(sc,sc->code, sc->NIL);
+              gc_enable(sc);
                sc->code = sc->value;
                s_thread_to(sc,OP_APPLY);
           } else {
@@ -2655,7 +2862,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           }
 
      CASE(OP_E1ARGS):     /* eval arguments */
-          sc->args = cons(sc, sc->value, sc->args);
+         gc_disable(sc, 1);
+         sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           if (is_pair(sc->code)) { /* continue */
                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
                sc->code = car(sc->code);
@@ -2672,7 +2881,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
      CASE(OP_TRACING): {
        int tr=sc->tracing;
        sc->tracing=ivalue(car(sc->args));
-       s_return(sc,mk_integer(sc,tr));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_integer(sc, tr));
      }
 #endif
 
@@ -2744,22 +2954,26 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                     sc->value = sc->code;
                     /* Fallthru */
                } else {
+                   gc_disable(sc, 1 + gc_reservations (s_save));
                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
                     sc->args=cons(sc,sc->code,sc->NIL);
+                   gc_enable(sc);
                     sc->code=slot_value_in_env(f);
                     s_thread_to(sc,OP_APPLY);
                }
           }
 
-     CASE(OP_LAMBDA1):
-          s_return(sc,mk_closure(sc, sc->value, sc->envir));
-
 #else
      CASE(OP_LAMBDA):     /* lambda */
-          s_return(sc,mk_closure(sc, sc->code, sc->envir));
-
+         sc->value = sc->code;
+         /* Fallthrough. */
 #endif
 
+     CASE(OP_LAMBDA1):
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
+
+
      CASE(OP_MKCLOSURE): /* make-closure */
        x=car(sc->args);
        if(car(x)==sc->LAMBDA) {
@@ -2770,7 +2984,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
        } else {
          y=cadr(sc->args);
        }
-       s_return(sc,mk_closure(sc, x, y));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_closure(sc, x, y));
 
      CASE(OP_QUOTE):      /* quote */
           s_return(sc,car(sc->code));
@@ -2781,7 +2996,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
 
           if (is_pair(car(sc->code))) {
                x = caar(sc->code);
+              gc_disable(sc, 2);
                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+              gc_enable(sc);
           } else {
                x = car(sc->code);
                sc->code = cadr(sc->code);
@@ -2856,17 +3073,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           s_thread_to(sc,OP_LET1);
 
      CASE(OP_LET1):       /* let (calculate parameters) */
+         gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
           sc->args = cons(sc, sc->value, sc->args);
           if (is_pair(sc->code)) { /* continue */
                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+                   gc_enable(sc);
                     Error_1(sc, "Bad syntax of binding spec in let :",
                             car(sc->code));
                }
                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
+              gc_enable(sc);
                sc->code = cadar(sc->code);
                sc->args = sc->NIL;
                s_thread_to(sc,OP_EVAL);
           } else {  /* end */
+              gc_enable(sc);
                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
                sc->code = car(sc->args);
                sc->args = cdr(sc->args);
@@ -2885,10 +3106,14 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                         Error_1(sc, "Bad syntax of binding in let :", x);
                     if (!is_list(sc, car(x)))
                         Error_1(sc, "Bad syntax of binding in let :", car(x));
+                   gc_disable(sc, 1);
                     sc->args = cons(sc, caar(x), sc->args);
+                   gc_enable(sc);
                }
+              gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
                new_slot_in_env(sc, car(sc->code), x);
+              gc_enable(sc);
                sc->code = cddr(sc->code);
                sc->args = sc->NIL;
           } else {
@@ -2946,7 +3171,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           s_thread_to(sc,OP_LET1REC);
 
      CASE(OP_LET1REC):    /* letrec (calculate parameters) */
+         gc_disable(sc, 1);
           sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           if (is_pair(sc->code)) { /* continue */
                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                     Error_1(sc, "Bad syntax of binding spec in letrec :",
@@ -2988,8 +3215,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
                     if(!is_pair(cdr(sc->code))) {
                          Error_0(sc,"syntax error in cond");
                     }
+                   gc_disable(sc, 4);
                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
+                   gc_enable(sc);
                     s_goto(sc,OP_EVAL);
                }
                s_goto(sc,OP_BEGIN);
@@ -3004,9 +3233,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
           }
 
      CASE(OP_DELAY):      /* delay */
+         gc_disable(sc, 2);
           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
           typeflag(x)=T_PROMISE;
-          s_return(sc,x);
+          s_return_enable_gc(sc,x);
 
      CASE(OP_AND0):       /* and */
           if (sc->code == sc->NIL) {
@@ -3053,14 +3283,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
 
      CASE(OP_C1STREAM):   /* cons-stream */
           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
+         gc_disable(sc, 3);
           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
           typeflag(x)=T_PROMISE;
-          s_return(sc,cons(sc, sc->args, x));
+          s_return_enable_gc(sc, cons(sc, sc->args, x));
 
      CASE(OP_MACRO0):     /* macro */
           if (is_pair(car(sc->code))) {
                x = caar(sc->code);
+              gc_disable(sc, 2);
                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+              gc_enable(sc);
           } else {
                x = car(sc->code);
                sc->code = cadr(sc->code);
@@ -3135,7 +3368,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
 
      CASE(OP_CONTINUATION):    /* call-with-current-continuation */
           sc->code = car(sc->args);
+         gc_disable(sc, 2);
           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
+         gc_enable(sc);
           s_goto(sc,OP_APPLY);
 
      default:
@@ -3145,6 +3380,52 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
      return sc->T;
 }
 
+#if USE_PLIST
+static pointer
+get_property(scheme *sc, pointer obj, pointer key)
+{
+  pointer x;
+
+  assert (is_symbol(obj));
+  assert (is_symbol(key));
+
+  for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+    if (caar(x) == key)
+      break;
+  }
+
+  if (x != sc->NIL)
+    return cdar(x);
+
+  return sc->NIL;
+}
+
+static pointer
+set_property(scheme *sc, pointer obj, pointer key, pointer value)
+{
+#define set_property_allocates 2
+  pointer x;
+
+  assert (is_symbol(obj));
+  assert (is_symbol(key));
+
+  for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+    if (caar(x) == key)
+      break;
+  }
+
+  if (x != sc->NIL)
+    cdar(x) = value;
+  else {
+    gc_disable(sc, gc_reservations(set_property));
+    symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
+    gc_enable(sc);
+  }
+
+  return sc->T;
+}
+#endif
+
 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
      pointer x;
      num v;
@@ -3265,14 +3546,16 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          v=num_add(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_MUL):        /* * */
        v=num_one;
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          v=num_mul(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_SUB):        /* - */
        if(cdr(sc->args)==sc->NIL) {
@@ -3285,7 +3568,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
        for (; x != sc->NIL; x = cdr(x)) {
          v=num_sub(v,nvalue(car(x)));
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_DIV):        /* / */
        if(cdr(sc->args)==sc->NIL) {
@@ -3302,7 +3586,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
            Error_0(sc,"/: division by zero");
          }
        }
-       s_return(sc,mk_number(sc, v));
+       gc_disable(sc, 1);
+       s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_INTDIV):        /* quotient */
           if(cdr(sc->args)==sc->NIL) {
@@ -3319,7 +3604,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                     Error_0(sc,"quotient: division by zero");
                }
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_REM):        /* remainder */
           v = nvalue(car(sc->args));
@@ -3328,7 +3614,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           else {
                Error_0(sc,"remainder: division by zero");
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_MOD):        /* modulo */
           v = nvalue(car(sc->args));
@@ -3337,7 +3624,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           else {
                Error_0(sc,"modulo: division by zero");
           }
-          s_return(sc,mk_number(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_number(sc, v));
 
      CASE(OP_CAR):        /* car */
           s_return(sc,caar(sc->args));
@@ -3368,31 +3656,36 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
      CASE(OP_CHAR2INT): { /* char->integer */
           char c;
           c=(char)ivalue(car(sc->args));
-          s_return(sc,mk_integer(sc,(unsigned char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
      }
 
      CASE(OP_INT2CHAR): { /* integer->char */
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
      CASE(OP_CHARUPCASE): {
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
           c=toupper(c);
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
      CASE(OP_CHARDNCASE): {
           unsigned char c;
           c=(unsigned char)ivalue(car(sc->args));
           c=tolower(c);
-          s_return(sc,mk_character(sc,(char)c));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_character(sc, (char) c));
      }
 
      CASE(OP_STR2SYM):  /* string->symbol */
-          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
+          gc_disable(sc, gc_reservations (mk_symbol));
+          s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
 
      CASE(OP_STR2ATOM): /* string->atom */ {
           char *s=strvalue(car(sc->args));
@@ -3430,9 +3723,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
         }
 
      CASE(OP_SYM2STR): /* symbol->string */
+         gc_disable(sc, 1);
           x=mk_string(sc,symname(car(sc->args)));
           setimmutable(x);
-          s_return(sc,x);
+          s_return_enable_gc(sc, x);
 
      CASE(OP_ATOM2STR): /* atom->string */ {
           long pf = 0;
@@ -3454,7 +3748,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
             char *p;
             int len;
             atom2str(sc,x,(int )pf,&p,&len);
-            s_return(sc,mk_counted_string(sc,p,len));
+           gc_disable(sc, 1);
+            s_return_enable_gc(sc, mk_counted_string(sc, p, len));
           } else {
             Error_1(sc, "atom->string: not an atom:", x);
           }
@@ -3469,11 +3764,13 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           if(cdr(sc->args)!=sc->NIL) {
                fill=charvalue(cadr(sc->args));
           }
-          s_return(sc,mk_empty_string(sc,len,(char)fill));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
      }
 
      CASE(OP_STRLEN):  /* string-length */
-          s_return(sc,mk_integer(sc,strlength(car(sc->args))));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
 
      CASE(OP_STRREF): { /* string-ref */
           char *str;
@@ -3487,7 +3784,9 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
           }
 
-          s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc,
+                            mk_character(sc, ((unsigned char*) str)[index]));
      }
 
      CASE(OP_STRSET): { /* string-set! */
@@ -3521,13 +3820,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
           len += strlength(car(x));
        }
+       gc_disable(sc, 1);
        newstr = mk_empty_string(sc, len, ' ');
        /* store the contents of the argument strings into the new string */
        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
            pos += strlength(car(x)), x = cdr(x)) {
            memcpy(pos, strvalue(car(x)), strlength(car(x)));
        }
-       s_return(sc, newstr);
+       s_return_enable_gc(sc, newstr);
      }
 
      CASE(OP_SUBSTR): { /* substring */
@@ -3554,11 +3854,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
           }
 
           len=index1-index0;
+         gc_disable(sc, 1);
           x=mk_empty_string(sc,len,' ');
           memcpy(strvalue(x),str+index0,len);
           strvalue(x)[len]=0;
 
-          s_return(sc,x);
+          s_return_enable_gc(sc, x);
      }
 
      CASE(OP_VECTOR): {   /* vector */
@@ -3595,7 +3896,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
      }
 
      CASE(OP_VECLEN):  /* vector-length */
-          s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
 
      CASE(OP_VECREF): { /* vector-ref */
           int index;
@@ -3871,36 +4173,14 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           s_return(sc, reverse_in_place(sc, car(y), x));
 
 #if USE_PLIST
-     CASE(OP_PUT):        /* put */
-          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-               Error_0(sc,"illegal use of put");
-          }
-          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-               if (caar(x) == y) {
-                    break;
-               }
-          }
-          if (x != sc->NIL)
-               cdar(x) = caddr(sc->args);
-          else
-               symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
-                                symprop(car(sc->args)));
-          s_return(sc,sc->T);
-
-     CASE(OP_GET):        /* get */
-          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-               Error_0(sc,"illegal use of get");
-          }
-          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-               if (caar(x) == y) {
-                    break;
-               }
-          }
-          if (x != sc->NIL) {
-               s_return(sc,cdar(x));
-          } else {
-               s_return(sc,sc->NIL);
-          }
+     CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
+         gc_disable(sc, gc_reservations(set_property));
+          s_return_enable_gc(sc,
+                            set_property(sc, car(sc->args),
+                                         cadr(sc->args), caddr(sc->args)));
+
+     CASE(OP_SYMBOL_PROPERTY):  /* symbol-property */
+         s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
 #endif /* USE_PLIST */
      CASE(OP_QUIT):       /* quit */
           if(is_pair(sc->args)) {
@@ -4168,7 +4448,9 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           break;
 
      CASE(OP_RDLIST): {
+         gc_disable(sc, 1);
           sc->args = cons(sc, sc->value, sc->args);
+         gc_enable(sc);
           sc->tok = token(sc);
           if (sc->tok == TOK_EOF)
                { s_return(sc,sc->EOF_OBJ); }
@@ -4201,23 +4483,32 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
           }
 
      CASE(OP_RDQUOTE):
-          s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->QUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
      CASE(OP_RDQQUOTE):
-          s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
      CASE(OP_RDQQUOTEVEC):
-           s_return(sc,cons(sc, mk_symbol(sc,"apply"),
+         gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
+         s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
            cons(sc, mk_symbol(sc,"vector"),
                  cons(sc,cons(sc, sc->QQUOTE,
                   cons(sc,sc->value,sc->NIL)),
                   sc->NIL))));
 
      CASE(OP_RDUNQUOTE):
-          s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
+                                     cons(sc, sc->value, sc->NIL)));
 
      CASE(OP_RDUQTSP):
-          s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
+         gc_disable(sc, 2);
+          s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
+                                     cons(sc, sc->value, sc->NIL)));
 
      CASE(OP_RDVEC):
           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
@@ -4319,7 +4610,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
           if(v<0) {
                Error_1(sc,"length: not a list:",car(sc->args));
           }
-          s_return(sc,mk_integer(sc, v));
+         gc_disable(sc, 1);
+          s_return_enable_gc(sc, mk_integer(sc, v));
 
      CASE(OP_ASSQ):       /* assq */     /* a.k */
           x = car(sc->args);
@@ -4342,9 +4634,13 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
           if (sc->args == sc->NIL) {
                s_return(sc,sc->F);
           } else if (is_closure(sc->args)) {
-               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+              gc_disable(sc, 1);
+               s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+                                          closure_code(sc->value)));
           } else if (is_macro(sc->args)) {
-               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
+              gc_disable(sc, 1);
+               s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+                                          closure_code(sc->value)));
           } else {
                s_return(sc,sc->F);
           }
@@ -4698,8 +4994,19 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->T = &sc->_HASHT;
   sc->F = &sc->_HASHF;
   sc->EOF_OBJ=&sc->_EOF_OBJ;
+
+#if USE_SMALL_INTEGERS
+  if (initialize_small_integers(sc)) {
+    sc->no_memory=1;
+    return 0;
+  }
+#endif
+
   sc->free_cell = &sc->_NIL;
   sc->fcells = 0;
+  sc->inhibit_gc = GC_ENABLED;
+  sc->reserved_cells = 0;
+  sc->reserved_lineno = 0;
   sc->no_memory=0;
   sc->inport=sc->NIL;
   sc->outport=sc->NIL;
@@ -4738,7 +5045,7 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
   /* init sink */
   typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
-  car(sc->sink) = sc->NIL;
+  car(sc->sink) = cdr(sc->sink) = sc->NIL;
   /* init c_nest */
   sc->c_nest = sc->NIL;
 
@@ -4840,6 +5147,10 @@ void scheme_deinit(scheme *sc) {
   sc->gc_verbose=0;
   gc(sc,sc->NIL,sc->NIL);
 
+#if USE_SMALL_INTEGERS
+  sc->free(sc->integer_alloc);
+#endif
+
   for(i=0; i<=sc->last_cell_seg; i++) {
     sc->free(sc->alloc_seg[i]);
   }