From 6283205982477aec904affbffa8eab57d239dd31 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 06:48:10 +0000 Subject: [PATCH] ctype-basetype now holds: * a symbol naming the type for primitive types * a list of ctypes for cstruct types * another ctype for user-defined ctypes svn: r12882 --- collects/mzlib/foreign.ss | 2 +- src/foreign/foreign.c | 105 ++++++++++++++++++++++++-------------- src/foreign/foreign.ssc | 47 +++++++++++------ 3 files changed, 98 insertions(+), 56 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8c7ccf7610..8737faa41c 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1500,7 +1500,7 @@ ;; Used by set-ffi-obj! to get the actual value so it can be kept around (define (get-lowlevel-object x type) (let ([basetype (ctype-basetype type)]) - (if basetype + (if (ctype? basetype) (let ([s->c (ctype-scheme->c type)]) (get-lowlevel-object (if s->c (s->c x) x) basetype)) (values x type)))) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index ae7d050e1e..6d97a28770 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -810,9 +810,16 @@ typedef union _ForeignAny { /* Type objects */ /* This struct is used for both user types and primitive types (including - * struct types). If it is a primitive type then basetype will be NULL, and + * struct types). If it is a user type then basetype will be another ctype, + * otherwise, + * - if it's a primitive type, then basetype will be a symbol naming that type + * - if it's a struct, then basetype will be the list of ctypes that + * made this struct * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an - * integer (a label value) for non-struct type. */ + * integer (a label value) for non-struct type. (Note that the + * integer is not really needed, since it is possible to identify the + * type by the basetype field.) + */ /* ctype structure definition */ static Scheme_Type ctype_tag; typedef struct ctype_struct { @@ -849,8 +856,8 @@ END_XFORM_SKIP; #endif #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) -#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) -#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) +#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) +#define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) #define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c)) #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme)) #define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) @@ -861,12 +868,9 @@ END_XFORM_SKIP; #define MYNAME "ctype-basetype" static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[]) { - Scheme_Object *base; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); - base = CTYPE_BASETYPE(argv[0]); - if (NULL == base) return scheme_false; - else return base; + return CTYPE_BASETYPE(argv[0]); } #undef MYNAME @@ -1046,7 +1050,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[]) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type->so.type = ctype_tag; - type->basetype = (NULL); + type->basetype = (argv[0]); type->scheme_to_c = ((Scheme_Object*)libffi_type); type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct); scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); @@ -1166,12 +1170,11 @@ END_XFORM_SKIP; static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc) { - Scheme_Object *res, *base; + Scheme_Object *res; if (!SCHEME_CTYPEP(type)) scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); - base = CTYPE_BASETYPE(type); - if (base != NULL) { - res = C2SCHEME(base, src, delta, args_loc); + if (CTYPE_USERP(type)) { + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -2632,6 +2635,7 @@ void scheme_init_foreign(Scheme_Env *env) { Scheme_Env *menv; ctype_struct *t; + Scheme_Object *s; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); ffi_lib_tag = scheme_make_type(""); ffi_obj_tag = scheme_make_type(""); @@ -2749,153 +2753,178 @@ void scheme_init_foreign(Scheme_Env *env) scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv); + s = scheme_intern_symbol("void"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_void); scheme_add_global("_void", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); scheme_add_global("_int8", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8); scheme_add_global("_uint8", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); scheme_add_global("_int16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16); scheme_add_global("_uint16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); scheme_add_global("_int32", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32); scheme_add_global("_uint32", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("int64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); scheme_add_global("_int64", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("uint64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64); scheme_add_global("_uint64", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint); scheme_add_global("_fixint", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("ufixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint); scheme_add_global("_ufixint", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum); scheme_add_global("_fixnum", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("ufixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum); scheme_add_global("_ufixnum", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("float"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_float); scheme_add_global("_float", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("double"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_double); scheme_add_global("_double", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("double*"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS); scheme_add_global("_double*", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("bool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool); scheme_add_global("_bool", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("string/ucs-4"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); scheme_add_global("_bytes", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); scheme_add_global("_path", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("symbol"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol); scheme_add_global("_symbol", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("pointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); scheme_add_global("_pointer", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("scheme"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); scheme_add_global("_scheme", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("fpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; - t->basetype = (NULL); + t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); scheme_add_global("_fpointer", (Scheme_Object*)t, menv); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index b7fd9cc618..50a0ce63ac 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" ** to make changes, edit that file and ** run it to generate an updated version ** of this file. + ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with + ** the scribble/text preprocessor instead. ********************************************/ {:(load "ssc-utils.ss"):} @@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (define *type-counter* 0) -(define (describe-type stype cname ftype ctype pred s->c c->s offset) +(define (describe-type type stype cname ftype ctype pred s->c c->s offset) (set! *type-counter* (add1 *type-counter*)) (~ "#define FOREIGN_"cname" ("*type-counter*")" \\ "/* Type Name: "stype (and (not (equal? cname stype)) @@ -466,7 +468,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) " * C->Scheme: "(cond [(not c->s) "-none-"] [(procedure? c->s) (c->s "")] [else (list c->s"()")]) \\ - " */" \\)) + " */" \\ + ;; no need for these, at least for now: + ;; "static Scheme_Object *"cname"_sym;"\\ + )) (define (make-ctype type args) (define (prop p . default) @@ -491,7 +496,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) [s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))] [c->s (prop 'c->s)] [offset (prop 'offset #f)]) - (describe-type stype cname ftype ctype pred s->c c->s offset) + (describe-type type stype cname ftype ctype pred s->c c->s offset) `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) @@ -726,17 +731,24 @@ typedef union _ForeignAny { /* Type objects */ /* This struct is used for both user types and primitive types (including - * struct types). If it is a primitive type then basetype will be NULL, and + * struct types). If it is a user type then basetype will be another ctype, + * otherwise, + * - if it's a primitive type, then basetype will be a symbol naming that type + * - if it's a struct, then basetype will be the list of ctypes that + * made this struct * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an - * integer (a label value) for non-struct type. */ + * integer (a label value) for non-struct type. (Note that the + * integer is not really needed, since it is possible to identify the + * type by the basetype field.) + */ {:(cdefstruct ctype (basetype "Scheme_Object*") (scheme_to_c "Scheme_Object*") (c_to_scheme "Scheme_Object*")):} #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) -#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x))) -#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x))) +#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) +#define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) #define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c)) #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme)) #define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) @@ -745,12 +757,9 @@ typedef union _ForeignAny { /* Returns #f for primitive types. */ {:(cdefine ctype-basetype 1):} { - Scheme_Object *base; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); - base = CTYPE_BASETYPE(argv[0]); - if (NULL == base) return scheme_false; - else return base; + return CTYPE_BASETYPE(argv[0]); } {:(cdefine ctype-scheme->c 1):} @@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) dummy = &libffi_type; if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); - {:(cmake-object "type" ctype "NULL" + {:(cmake-object "type" ctype "argv[0]" "(Scheme_Object*)libffi_type" "(Scheme_Object*)FOREIGN_struct"):} scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); @@ -974,12 +983,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc) { - Scheme_Object *res, *base; + Scheme_Object *res; if (!SCHEME_CTYPEP(type)) scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); - base = CTYPE_BASETYPE(type); - if (base != NULL) { - res = C2SCHEME(base, src, delta, args_loc); + if (CTYPE_USERP(type)) { + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -2066,6 +2074,7 @@ void scheme_init_foreign(Scheme_Env *env) { Scheme_Env *menv; ctype_struct *t; + Scheme_Object *s; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); {:(for-each (lambda (x) (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");")) @@ -2090,7 +2099,11 @@ void scheme_init_foreign(Scheme_Env *env) (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);")) (reverse! cfunctions)) (for-each-type - (cmake-object "t" ctype "NULL" + ;; no need for these, at least for now: + ;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\ + ;; cname"_sym = scheme_intern_symbol(\""stype"\");") + (~ "s = scheme_intern_symbol(\""stype"\");") + (cmake-object "t" ctype "s" (list "(Scheme_Object*)(void*)(&ffi_type_"ftype")") (list "(Scheme_Object*)FOREIGN_"cname)) (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):}