Merge branch 'master' into STABLE-BRANCH-2-2
[gnupg.git] / tests / gpgscm / scheme.c
index 1f40bb2..0a76205 100644 (file)
@@ -125,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
@@ -235,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); }
 
@@ -930,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);
 
@@ -940,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);
 }
@@ -976,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;
@@ -1010,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;
@@ -1222,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);
           }
@@ -1339,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);
   }
 }
 
@@ -1565,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;
@@ -2047,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>";
      }
@@ -2304,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;
 }
 
@@ -4364,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);
@@ -4481,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))));
           }
         }
       }
@@ -4501,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);
     }
   }
 }
@@ -4591,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,
 
@@ -4714,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;
@@ -4870,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) {