tests/gpgscm: Foreign objects support for TinySCHEME.

* tests/gpgscm/scheme-private.h (struct cell): Add 'foreign_object'.
(is_foreign_object): New prototype.
(get_foreign_object_{vtable,data}): Likewise.
* tests/gpgscm/scheme.c (enum scheme_types): New type.
(is_foreign_object): New function.
(get_foreign_object_{vtable,data}): Likewise.
(mk_foreign_object): Likewise.
(finalize_cell): Free foreign objects.
(atom2str): Pretty-print foreign objects.
(vtbl): Add new functions.
* tests/gpgscm/scheme.h (struct foreign_object_vtable): New type.
(mk_foreign_object): New prototype.
(struct scheme_interface): Add new functions.

Patch from Thomas Munro,
https://sourceforge.net/p/tinyscheme/patches/13/

Signed-off-by: Justus Winter <[email protected]>

3 files changed, 45 insertions, 1 deletions

diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index 0ddfdbcc5..9eafe766d 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -55,6 +55,10 @@ struct cell {
       struct cell *_car;
       struct cell *_cdr;
     } _cons;
+    struct {
+         char *_data;
+         const foreign_object_vtable *_vtable;
+    } _foreign_object;
   } _object;
 };
 
@@ -207,6 +211,10 @@ int is_environment(pointer p);
 int is_immutable(pointer p);
 void setimmutable(pointer p);
 
+int is_foreign_object(pointer p);
+const foreign_object_vtable *get_foreign_object_vtable(pointer p);
+void *get_foreign_object_data(pointer p);
+
 #ifdef __cplusplus
 }
 #endif
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 1f40bb2fd..748a02210 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -125,7 +125,8 @@ enum scheme_types {
   T_MACRO=12,
   T_PROMISE=13,
   T_ENVIRONMENT=14,
-  T_LAST_SYSTEM_TYPE=14
+  T_FOREIGN_OBJECT=15,
+  T_LAST_SYSTEM_TYPE=15
 };
 
 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
@@ -235,6 +236,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 +939,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);
 
@@ -1341,6 +1359,8 @@ static void finalize_cell(scheme *sc, pointer a) {
       port_close(sc,a,port_input|port_output);
     }
     sc->free(a->_object._port);
+  } else if(is_foreign_object(a)) {
+    a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
   }
 }
 
@@ -2047,6 +2067,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>";
      }
@@ -4591,6 +4614,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,
 
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 4ba2daa76..f4231c474 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -118,6 +118,12 @@ typedef struct cell *pointer;
 typedef void * (*func_alloc)(size_t);
 typedef void (*func_dealloc)(void *);
 
+/* table of functions required for foreign objects */
+typedef struct foreign_object_vtable {
+     void (*finalize)(scheme *sc, void *data);
+     void (*to_string)(scheme *sc, char *out, size_t size, void *data);
+} foreign_object_vtable;
+
 /* num, for generic arithmetic */
 typedef struct num {
      char is_fixnum;
@@ -157,6 +163,7 @@ pointer mk_counted_string(scheme *sc, const char *str, int len);
 pointer mk_empty_string(scheme *sc, int len, char fill);
 pointer mk_character(scheme *sc, int c);
 pointer mk_foreign_func(scheme *sc, foreign_func f);
+pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data);
 void putstr(scheme *sc, const char *s);
 int list_length(scheme *sc, pointer a);
 int eqv(pointer a, pointer b);
@@ -177,6 +184,9 @@ struct scheme_interface {
   pointer (*mk_character)(scheme *sc, int c);
   pointer (*mk_vector)(scheme *sc, int len);
   pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+  pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data);
+  const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p);
+  void *(*get_foreign_object_data)(pointer p);
   void (*putstr)(scheme *sc, const char *s);
   void (*putcharacter)(scheme *sc, int c);