Merge branch 'master' into STABLE-BRANCH-2-2
[gnupg.git] / tests / gpgscm / scheme.c
index 3d4330d..0a76205 100644 (file)
@@ -27,6 +27,7 @@
 # include <math.h>
 #endif
 
+#include <assert.h>
 #include <limits.h>
 #include <float.h>
 #include <ctype.h>
@@ -66,6 +67,7 @@
 #define banner "TinyScheme 1.41"
 
 #include <string.h>
+#include <stddef.h>
 #include <stdlib.h>
 
 #ifdef __APPLE__
@@ -123,9 +125,42 @@ enum scheme_types {
   T_MACRO=12,
   T_PROMISE=13,
   T_ENVIRONMENT=14,
-  T_LAST_SYSTEM_TYPE=14
+  T_FOREIGN_OBJECT=15,
+  T_BOOLEAN=16,
+  T_NIL=17,
+  T_EOF_OBJ=18,
+  T_SINK=19,
+  T_LAST_SYSTEM_TYPE=19
 };
 
+static const char *
+type_to_string (enum scheme_types typ)
+{
+     switch (typ)
+     {
+     case T_STRING: return "string";
+     case T_NUMBER: return "number";
+     case T_SYMBOL: return "symbol";
+     case T_PROC: return "proc";
+     case T_PAIR: return "pair";
+     case T_CLOSURE: return "closure";
+     case T_CONTINUATION: return "configuration";
+     case T_FOREIGN: return "foreign";
+     case T_CHARACTER: return "character";
+     case T_PORT: return "port";
+     case T_VECTOR: return "vector";
+     case T_MACRO: return "macro";
+     case T_PROMISE: return "promise";
+     case T_ENVIRONMENT: return "environment";
+     case T_FOREIGN_OBJECT: return "foreign object";
+     case T_BOOLEAN: return "boolean";
+     case T_NIL: return "nil";
+     case T_EOF_OBJ: return "eof object";
+     case T_SINK: return "sink";
+     }
+     assert (! "not reached");
+}
+
 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
 #define ADJ 32
 #define TYPE_BITS 5
@@ -233,6 +268,14 @@ INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
 #define cont_dump(p)     cdr(p)
 
+INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
+INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
+  return p->_object._foreign_object._vtable;
+}
+INTERFACE void *get_foreign_object_data(pointer p) {
+  return p->_object._foreign_object._data;
+}
+
 /* To do: promise should be forced ONCE only */
 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
 
@@ -928,6 +971,15 @@ pointer mk_foreign_func(scheme *sc, foreign_func f) {
   return (x);
 }
 
+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);
+  x->_object._foreign_object._vtable=vtable;
+  x->_object._foreign_object._data = data;
+  return (x);
+}
+
 INTERFACE pointer mk_character(scheme *sc, int c) {
   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 
@@ -938,11 +990,11 @@ INTERFACE pointer mk_character(scheme *sc, int c) {
 }
 
 /* get number atom (integer) */
-INTERFACE pointer mk_integer(scheme *sc, long num) {
+INTERFACE pointer mk_integer(scheme *sc, long n) {
   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 
   typeflag(x) = (T_NUMBER | T_ATOM);
-  ivalue_unchecked(x)= num;
+  ivalue_unchecked(x)= n;
   set_num_integer(x);
   return (x);
 }
@@ -974,7 +1026,8 @@ static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
           return sc->strbuff;
      }
      if(str!=0) {
-          snprintf(q, len_str+1, "%s", str);
+         memcpy (q, str, len_str);
+          q[len_str]=0;
      } else {
           memset(q, fill, len_str);
           q[len_str]=0;
@@ -1008,8 +1061,8 @@ INTERFACE static pointer mk_vector(scheme *sc, int len)
 
 INTERFACE static void fill_vector(pointer vec, pointer obj) {
      int i;
-     int num=ivalue(vec)/2+ivalue(vec)%2;
-     for(i=0; i<num; 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;
@@ -1070,6 +1123,21 @@ INTERFACE pointer gensym(scheme *sc) {
      return sc->NIL;
 }
 
+/* double the size of the string buffer */
+static int expand_strbuff(scheme *sc) {
+  size_t new_size = sc->strbuff_size * 2;
+  char *new_buffer = sc->malloc(new_size);
+  if (new_buffer == 0) {
+    sc->no_memory = 1;
+    return 1;
+  }
+  memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
+  sc->free(sc->strbuff);
+  sc->strbuff = new_buffer;
+  sc->strbuff_size = new_size;
+  return 0;
+}
+
 /* make symbol or number atom from string */
 static pointer mk_atom(scheme *sc, char *q) {
      char    c, *p;
@@ -1205,8 +1273,8 @@ static void mark(pointer a) {
 E2:  setmark(p);
      if(is_vector(p)) {
           int i;
-          int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
-          for(i=0; i<num; 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);
           }
@@ -1322,8 +1390,12 @@ static void finalize_cell(scheme *sc, pointer a) {
     if(a->_object._port->kind&port_file
        && a->_object._port->rep.stdio.closeit) {
       port_close(sc,a,port_input|port_output);
+    } else if (a->_object._port->kind & port_srfi6) {
+      sc->free(a->_object._port->rep.string.start);
     }
     sc->free(a->_object._port);
+  } else if(is_foreign_object(a)) {
+    a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
   }
 }
 
@@ -1548,12 +1620,13 @@ static void backchar(scheme *sc, int c) {
 static int realloc_port_string(scheme *sc, port *p)
 {
   char *start=p->rep.string.start;
+  size_t old_size = p->rep.string.past_the_end - start;
   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
   char *str=sc->malloc(new_size);
   if(str) {
     memset(str,' ',new_size-1);
     str[new_size-1]='\0';
-    strcpy(str,start);
+    memcpy(str, start, old_size);
     p->rep.string.start=str;
     p->rep.string.past_the_end=str+new_size-1;
     p->rep.string.curr-=start-str;
@@ -1611,7 +1684,7 @@ INTERFACE void putcharacter(scheme *sc, int c) {
 static char *readstr_upto(scheme *sc, char *delim) {
   char *p = sc->strbuff;
 
-  while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
+  while ((p - sc->strbuff < sc->strbuff_size) &&
          !is_one_of(delim, (*p++ = inchar(sc))));
 
   if(p == sc->strbuff+2 && p[-2] == '\\') {
@@ -1632,9 +1705,16 @@ static pointer readstrexp(scheme *sc) {
 
   for (;;) {
     c=inchar(sc);
-    if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
+    if(c == EOF) {
       return sc->F;
     }
+    if(p-sc->strbuff > (sc->strbuff_size)-1) {
+      ptrdiff_t offset = p - sc->strbuff;
+      if (expand_strbuff(sc) != 0) {
+        return sc->F;
+      }
+      p = sc->strbuff + offset;
+    }
     switch(state) {
         case st_ok:
             switch(c) {
@@ -2023,6 +2103,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
      } else if (is_continuation(l)) {
           p = "#<CONTINUATION>";
+     } else if (is_foreign_object(l)) {
+          p = sc->strbuff;
+          l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
      } else {
           p = "#<ERROR>";
      }
@@ -2280,6 +2363,7 @@ static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
 
 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
 {
+  (void)sc;
   cdr(slot) = value;
 }
 
@@ -2682,7 +2766,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
                sc->dump = cont_dump(sc->code);
                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
           } else {
-               Error_0(sc,"illegal function");
+               Error_1(sc,"illegal function",sc->code);
           }
 
      case OP_DOMACRO:    /* do macro */
@@ -3654,6 +3738,7 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
                case OP_GRE:   comp_func=num_gt; break;
                case OP_LEQ:   comp_func=num_le; break;
                case OP_GEQ:   comp_func=num_ge; break;
+               default: assert (! "reached");
           }
           x=sc->args;
           v=nvalue(car(x));
@@ -3898,12 +3983,15 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
                case OP_OPEN_INFILE:     prop=port_input; break;
                case OP_OPEN_OUTFILE:    prop=port_output; break;
                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
+               default: assert (! "reached");
           }
           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
           if(p==sc->NIL) {
                s_return(sc,sc->F);
           }
           s_return(sc,p);
+         break;
+     default: assert (! "reached");
      }
 
 #if USE_STRING_PORTS
@@ -3914,6 +4002,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
           switch(op) {
                case OP_OPEN_INSTRING:     prop=port_input; break;
                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
+               default: assert (! "reached");
           }
           p=port_from_string(sc, strvalue(car(sc->args)),
                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
@@ -4335,7 +4424,11 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
 
 typedef int (*test_predicate)(pointer);
-static int is_any(pointer p) { return 1;}
+
+static int is_any(pointer p) {
+   (void)p;
+   return 1;
+}
 
 static int is_nonneg(pointer p) {
   return ivalue(p)>=0 && is_integer(p);
@@ -4452,10 +4545,11 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
           } while(i<n);
           if(i<n) {
             ok=0;
-            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
+            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
                 pcd->name,
                 i+1,
-                tests[j].kind);
+               tests[j].kind,
+               type_to_string(type(car(arglist))));
           }
         }
       }
@@ -4472,7 +4566,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
     }
     if(sc->no_memory) {
       fprintf(stderr,"No memory!\n");
-      return;
+      exit(1);
     }
   }
 }
@@ -4562,6 +4656,9 @@ static struct scheme_interface vtbl ={
   mk_character,
   mk_vector,
   mk_foreign_func,
+  mk_foreign_object,
+  get_foreign_object_vtable,
+  get_foreign_object_data,
   putstr,
   putcharacter,
 
@@ -4608,7 +4705,8 @@ static struct scheme_interface vtbl ={
   setimmutable,
 
   scheme_load_file,
-  scheme_load_string
+  scheme_load_string,
+  port_from_file
 };
 #endif
 
@@ -4667,6 +4765,12 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->loadport=sc->NIL;
   sc->nesting=0;
   sc->interactive_repl=0;
+  sc->strbuff = sc->malloc(STRBUFFSIZE);
+  if (sc->strbuff == 0) {
+     sc->no_memory=1;
+     return 0;
+  }
+  sc->strbuff_size = STRBUFFSIZE;
 
   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
     sc->no_memory=1;
@@ -4678,16 +4782,19 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
   sc->tracing=0;
 
   /* init sc->NIL */
-  typeflag(sc->NIL) = (T_ATOM | MARK);
+  typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
   /* init T */
-  typeflag(sc->T) = (T_ATOM | MARK);
+  typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
   car(sc->T) = cdr(sc->T) = sc->T;
   /* init F */
-  typeflag(sc->F) = (T_ATOM | MARK);
+  typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
   car(sc->F) = cdr(sc->F) = sc->F;
+  /* init EOF_OBJ */
+  typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
+  car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
   /* init sink */
-  typeflag(sc->sink) = (T_PAIR | MARK);
+  typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
   car(sc->sink) = sc->NIL;
   /* init c_nest */
   sc->c_nest = sc->NIL;
@@ -4791,6 +4898,7 @@ void scheme_deinit(scheme *sc) {
   for(i=0; i<=sc->last_cell_seg; i++) {
     sc->free(sc->alloc_seg[i]);
   }
+  sc->free(sc->strbuff);
 
 #if SHOW_ERROR_LINE
   for(i=0; i<=sc->file_i; i++) {
@@ -4833,6 +4941,11 @@ void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
   if(sc->retcode==0) {
     sc->retcode=sc->nesting!=0;
   }
+
+#if SHOW_ERROR_LINE
+  sc->free(sc->load_stack[0].rep.stdio.filename);
+  sc->load_stack[0].rep.stdio.filename = NULL;
+#endif
 }
 
 void scheme_load_string(scheme *sc, const char *cmd) {