gpgscm: Fix initialization of 'sink'.
[gnupg.git] / tests / gpgscm / scheme.c
index ce31f8d..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];
@@ -708,7 +722,8 @@ gc_reservation_failure(struct scheme *sc)
 
 /* 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.  */
+ * 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)
 {
@@ -1095,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);
 }
@@ -1111,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);
@@ -1126,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);
 
@@ -1179,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);
@@ -1187,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);
@@ -1504,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;
@@ -2643,6 +2706,9 @@ static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
     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);
@@ -2650,12 +2716,12 @@ 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       5
+#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_integer(sc, (long)(op)), dump);
+    sc->dump = cons(sc, mk_small_integer(sc, (long)(op)), dump);
     gc_enable(sc);
 }
 
@@ -2897,16 +2963,16 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                }
           }
 
-     CASE(OP_LAMBDA1):
-         gc_disable(sc, 1);
-          s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
-
 #else
      CASE(OP_LAMBDA):     /* lambda */
+         sc->value = sc->code;
+         /* Fallthrough. */
+#endif
+
+     CASE(OP_LAMBDA1):
          gc_disable(sc, 1);
-          s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir));
+          s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
 
-#endif
 
      CASE(OP_MKCLOSURE): /* make-closure */
        x=car(sc->args);
@@ -3011,6 +3077,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
           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));
                }
@@ -3313,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;
@@ -4060,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_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_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_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)) {
@@ -4903,6 +4994,14 @@ 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;
@@ -4946,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;
 
@@ -5048,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]);
   }