From e86e90cc031a0670fdb0d9c23e23f90b009ba3da Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Thu, 31 Mar 2016 13:49:56 +0200 Subject: [PATCH] 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 --- tests/gpgscm/scheme-private.h | 8 ++++++++ tests/gpgscm/scheme.c | 28 +++++++++++++++++++++++++++- tests/gpgscm/scheme.h | 10 ++++++++++ 3 files changed, 45 insertions(+), 1 deletion(-) 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 b62f70e2f..656c6b97e 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); } } @@ -2043,6 +2063,9 @@ static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { snprintf(p,STRBUFFSIZE,"#", procnum(l)); } else if (is_continuation(l)) { p = "#"; + } 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 = "#"; } @@ -4587,6 +4610,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);