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

@@ -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))))

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-lib>");
   ffi_obj_tag = scheme_make_type("<ffi-obj>");
@@ -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);

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 "<C>")]
                              [else (list c->s"(<C>)")]) \\
-     " */" \\))
+     " */" \\
+     ;; 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);")):}