Back to index

plt-scheme  4.2.1
foreign.c
Go to the documentation of this file.
00001 /********************************************
00002  ** Do not edit this file!
00003  ** This file is generated from foreign.ssc,
00004  ** to make changes, edit that file and
00005  ** run it to generate an updated version
00006  ** of this file.
00007  ********************************************/
00008 
00009 #include "schpriv.h"
00010 
00011 #ifndef WINDOWS_DYNAMIC_LOAD
00012 
00013 # include <dlfcn.h>
00014 
00015 # if SIZEOF_CHAR == 1
00016    typedef   signed char Tsint8;
00017    typedef unsigned char Tuint8;
00018 # else
00019 #  error "configuration error, please contact PLT (int8)"
00020 # endif
00021 
00022 # if SIZEOF_SHORT == 2
00023    typedef   signed short Tsint16;
00024    typedef unsigned short Tuint16;
00025 # elif SIZEOF_INT == 2
00026    typedef   signed int Tsint16;
00027    typedef unsigned int Tuint16;
00028 # else
00029 #  error "configuration error, please contact PLT (int16)"
00030 # endif
00031 
00032 # if SIZEOF_INT == 4
00033    typedef   signed int Tsint32;
00034    typedef unsigned int Tuint32;
00035 # elif SIZEOF_LONG == 4
00036    typedef   signed long Tsint32;
00037    typedef unsigned long Tuint32;
00038 # else
00039 #  error "configuration error, please contact PLT (int32)"
00040 # endif
00041 
00042 # if SIZEOF_LONG == 8
00043    typedef   signed long Tsint64;
00044    typedef unsigned long Tuint64;
00045 # elif SIZEOF_LONG_LONG == 8
00046    typedef   signed long long Tsint64;
00047    typedef unsigned long long Tuint64;
00048 # else
00049 #  error "configuration error, please contact PLT (int64)"
00050 # endif
00051 
00052 #else /* WINDOWS_DYNAMIC_LOAD defined */
00053 
00054 # include <windows.h>
00055 # ifndef __CYGWIN32__
00056 #  include <wtypes.h>
00057    typedef          _int8  Tsint8;
00058    typedef unsigned _int8  Tuint8;
00059    typedef          _int16 Tsint16;
00060    typedef unsigned _int16 Tuint16;
00061    typedef          _int32 Tsint32;
00062    typedef unsigned _int32 Tuint32;
00063    typedef          _int64 Tsint64;
00064    typedef unsigned _int64 Tuint64;
00065 # endif
00066 
00067 #endif /* WINDOWS_DYNAMIC_LOAD */
00068 
00069 #include "ffi.h"
00070 
00071 #ifndef MZ_PRECISE_GC
00072 # define XFORM_OK_PLUS +
00073 # define GC_CAN_IGNORE /* empty */
00074 #endif
00075 
00076 #define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
00077 
00078 /* same as the macro in file.c */
00079 #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
00080 
00081 /*****************************************************************************/
00082 /* Defining EnumProcessModules for openning `self' as an ffi-lib */
00083 
00084 /* We'd like to use EnumProcessModules to find all loaded DLLs, but it's
00085    only available in NT 4.0 and later. The alternative, Module32{First,Next},
00086    is available *except* for NT 4.0! So we try EnumProcessModules first. */
00087 
00088 #ifdef WINDOWS_DYNAMIC_LOAD
00089 #ifdef MZ_PRECISE_GC
00090 START_XFORM_SKIP;
00091 #endif
00092 
00093 int epm_tried = 0;
00094 typedef BOOL (WINAPI *EnumProcessModules_t)(HANDLE hProcess,
00095                                             HMODULE* lphModule,
00096                                             DWORD cb,
00097                                             LPDWORD lpcbNeeded);
00098 EnumProcessModules_t _EnumProcessModules;
00099 #include <tlhelp32.h>
00100 
00101 BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule,
00102                           DWORD cb, LPDWORD lpcbNeeded)
00103 {
00104   if (!epm_tried) {
00105     HMODULE hm;
00106     hm = LoadLibrary("psapi.dll");
00107     if (hm) {
00108       _EnumProcessModules =
00109         (EnumProcessModules_t)GetProcAddress(hm, "EnumProcessModules");
00110     }
00111     epm_tried = 1;
00112   }
00113 
00114   if (_EnumProcessModules)
00115     return _EnumProcessModules(hProcess, lphModule, cb, lpcbNeeded);
00116   else {
00117     HANDLE snapshot;
00118     MODULEENTRY32 mod;
00119     int i, ok;
00120 
00121     snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,
00122                                         GetCurrentProcessId());
00123     if (snapshot == INVALID_HANDLE_VALUE)
00124       return FALSE;
00125 
00126     for (i = 0; 1; i++) {
00127       mod.dwSize = sizeof(mod);
00128       if (!i)
00129         ok = Module32First(snapshot, &mod);
00130       else
00131         ok = Module32Next(snapshot, &mod);
00132       if (!ok)
00133         break;
00134       if (cb >= sizeof(HMODULE)) {
00135         lphModule[i] = mod.hModule;
00136         cb -= sizeof(HMODULE);
00137       }
00138     }
00139 
00140     CloseHandle(snapshot);
00141     *lpcbNeeded = i * sizeof(HMODULE);
00142     return GetLastError() == ERROR_NO_MORE_FILES;
00143   }
00144 }
00145 
00146 #ifdef MZ_PRECISE_GC
00147 END_XFORM_SKIP;
00148 #endif
00149 #endif /* WINDOWS_DYNAMIC_LOAD */
00150 
00151 /*****************************************************************************/
00152 /* Library objects */
00153 
00154 /* ffi-lib structure definition */
00155 static Scheme_Type ffi_lib_tag;
00156 typedef struct ffi_lib_struct {
00157   Scheme_Object so;
00158   void* handle;
00159   Scheme_Object* name;
00160   Scheme_Hash_Table* objects;
00161 } ffi_lib_struct;
00162 #define SCHEME_FFILIBP(x) (SCHEME_TYPE(x)==ffi_lib_tag)
00163 #define MYNAME "ffi-lib?"
00164 static Scheme_Object *foreign_ffi_lib_p(int argc, Scheme_Object *argv[])
00165 {
00166   return SCHEME_FFILIBP(argv[0]) ? scheme_true : scheme_false;
00167 }
00168 #undef MYNAME
00169 /* 3m stuff for ffi_lib */
00170 #ifdef MZ_PRECISE_GC
00171 START_XFORM_SKIP;
00172 int ffi_lib_SIZE(void *p) {
00173   return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
00174 }
00175 int ffi_lib_MARK(void *p) {
00176   ffi_lib_struct *s = (ffi_lib_struct *)p;
00177   gcMARK(s->handle);
00178   gcMARK(s->name);
00179   gcMARK(s->objects);
00180   return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
00181 }
00182 int ffi_lib_FIXUP(void *p) {
00183   ffi_lib_struct *s = (ffi_lib_struct *)p;
00184   gcFIXUP(s->handle);
00185   gcFIXUP(s->name);
00186   gcFIXUP(s->objects);
00187   return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
00188 }
00189 END_XFORM_SKIP;
00190 #endif
00191 
00192 static Scheme_Hash_Table *opened_libs;
00193 
00194 /* (ffi-lib filename no-error?) -> ffi-lib */
00195 #define MYNAME "ffi-lib"
00196 static Scheme_Object *foreign_ffi_lib(int argc, Scheme_Object *argv[])
00197 {
00198   char *name;
00199   Scheme_Object *path, *hashname;
00200   void *handle;
00201   int null_ok = 0;
00202   ffi_lib_struct *lib;
00203   if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
00204     scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv);
00205   /* leave the filename as given, the system will look for it */
00206   /* (`#f' means open the executable) */
00207   path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]);
00208   name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path);
00209   hashname = (Scheme_Object*)((name==NULL) ? "" : name);
00210   lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname);
00211   if (!lib) {
00212     Scheme_Hash_Table *ht;
00213 #   ifdef WINDOWS_DYNAMIC_LOAD
00214     if (name==NULL) {
00215       /* openning the executable is marked by a NULL handle */
00216       handle = NULL;
00217       null_ok = 1;
00218     } else
00219       handle = LoadLibrary(name);
00220 #   else /* WINDOWS_DYNAMIC_LOAD undefined */
00221     handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL);
00222 #   endif /* WINDOWS_DYNAMIC_LOAD */
00223     if (handle == NULL && !null_ok) {
00224       if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false;
00225       else {
00226 #       ifdef WINDOWS_DYNAMIC_LOAD
00227         long err;
00228         err = GetLastError();
00229         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00230                          MYNAME": couldn't open %V (%E)", argv[0], err);
00231 #       else /* WINDOWS_DYNAMIC_LOAD undefined */
00232         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00233                          MYNAME": couldn't open %V (%s)", argv[0], dlerror());
00234 #       endif /* WINDOWS_DYNAMIC_LOAD */
00235       }
00236     }
00237     ht = scheme_make_hash_table(SCHEME_hash_string);
00238     lib = (ffi_lib_struct*)scheme_malloc_tagged(sizeof(ffi_lib_struct));
00239     lib->so.type = ffi_lib_tag;
00240     lib->handle = (handle);
00241     lib->name = (argv[0]);
00242     lib->objects = (ht);
00243     scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib);
00244     /* no dlclose finalizer - since the hash table always keeps a reference */
00245     /* maybe add some explicit unload at some point */
00246   }
00247   return (Scheme_Object*)lib;
00248 }
00249 #undef MYNAME
00250 
00251 /* (ffi-lib-name ffi-lib) -> string */
00252 #define MYNAME "ffi-lib-name"
00253 static Scheme_Object *foreign_ffi_lib_name(int argc, Scheme_Object *argv[])
00254 {
00255   if (!SCHEME_FFILIBP(argv[0]))
00256     scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv);
00257   return ((ffi_lib_struct*)argv[0])->name;
00258 }
00259 #undef MYNAME
00260 
00261 /*****************************************************************************/
00262 /* Pull pointers (mostly functions) out of ffi-lib objects */
00263 
00264 /* ffi-obj structure definition */
00265 static Scheme_Type ffi_obj_tag;
00266 typedef struct ffi_obj_struct {
00267   Scheme_Object so;
00268   void* obj;
00269   char* name;
00270   ffi_lib_struct* lib;
00271 } ffi_obj_struct;
00272 #define SCHEME_FFIOBJP(x) (SCHEME_TYPE(x)==ffi_obj_tag)
00273 #define MYNAME "ffi-obj?"
00274 static Scheme_Object *foreign_ffi_obj_p(int argc, Scheme_Object *argv[])
00275 {
00276   return SCHEME_FFIOBJP(argv[0]) ? scheme_true : scheme_false;
00277 }
00278 #undef MYNAME
00279 /* 3m stuff for ffi_obj */
00280 #ifdef MZ_PRECISE_GC
00281 START_XFORM_SKIP;
00282 int ffi_obj_SIZE(void *p) {
00283   return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
00284 }
00285 int ffi_obj_MARK(void *p) {
00286   ffi_obj_struct *s = (ffi_obj_struct *)p;
00287   gcMARK(s->obj);
00288   gcMARK(s->name);
00289   gcMARK(s->lib);
00290   return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
00291 }
00292 int ffi_obj_FIXUP(void *p) {
00293   ffi_obj_struct *s = (ffi_obj_struct *)p;
00294   gcFIXUP(s->obj);
00295   gcFIXUP(s->name);
00296   gcFIXUP(s->lib);
00297   return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
00298 }
00299 END_XFORM_SKIP;
00300 #endif
00301 
00302 /* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */
00303 #define MYNAME "ffi-obj"
00304 static Scheme_Object *foreign_ffi_obj(int argc, Scheme_Object *argv[])
00305 {
00306   ffi_obj_struct *obj;
00307   void *dlobj;
00308   ffi_lib_struct *lib = NULL;
00309   char *dlname;
00310   if (SCHEME_FFILIBP(argv[1]))
00311     lib = (ffi_lib_struct*)argv[1];
00312   else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1]))
00313     lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1]));
00314   else
00315     scheme_wrong_type(MYNAME, "ffi-lib", 1, argc, argv);
00316   if (!SCHEME_BYTE_STRINGP(argv[0]))
00317     scheme_wrong_type(MYNAME, "bytes", 0, argc, argv);
00318   dlname = SCHEME_BYTE_STR_VAL(argv[0]);
00319   obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname);
00320   if (!obj) {
00321 #   ifdef WINDOWS_DYNAMIC_LOAD
00322     if (lib->handle) {
00323       dlobj = GetProcAddress(lib->handle, dlname);
00324     } else {
00325       /* this is for the executable-open case, which was marked by a NULL
00326        * handle, deal with it by searching all current modules */
00327 #     define NUM_QUICK_MODS 16
00328       HMODULE *mods, me, quick_mods[NUM_QUICK_MODS];
00329       DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i;
00330       me = GetCurrentProcess();
00331       mods = quick_mods;
00332       if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) {
00333         if (actual_cnt > cnt) {
00334           cnt = actual_cnt;
00335           mods = (HMODULE *)scheme_malloc_atomic(cnt);
00336           if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt))
00337             mods = NULL;
00338         } else
00339           cnt = actual_cnt;
00340       } else
00341         mods = NULL;
00342       if (mods) {
00343         cnt /= sizeof(HMODULE);
00344         for (i = 0; i < cnt; i++) {
00345           dlobj = GetProcAddress(mods[i], dlname);
00346           if (dlobj) break;
00347         }
00348       } else
00349         dlobj = NULL;
00350     }
00351     if (!dlobj) {
00352       long err;
00353       err = GetLastError();
00354       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00355                        MYNAME": couldn't get \"%s\" from %V (%E)",
00356                        dlname, lib->name, err);
00357     }
00358 #   else /* WINDOWS_DYNAMIC_LOAD undefined */
00359     dlobj = dlsym(lib->handle, dlname);
00360     if (!dlobj) {
00361       const char *err;
00362       err = dlerror();
00363       if (err != NULL)
00364         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
00365                          MYNAME": couldn't get \"%s\" from %V (%s)",
00366                          dlname, lib->name, err);
00367     }
00368 #   endif /* WINDOWS_DYNAMIC_LOAD */
00369     obj = (ffi_obj_struct*)scheme_malloc_tagged(sizeof(ffi_obj_struct));
00370     obj->so.type = ffi_obj_tag;
00371     obj->obj = (dlobj);
00372     obj->name = (dlname);
00373     obj->lib = (lib);
00374     scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj);
00375   }
00376   return (obj == NULL) ? scheme_false : (Scheme_Object*)obj;
00377 }
00378 #undef MYNAME
00379 
00380 /* (ffi-obj-lib ffi-obj) -> ffi-lib */
00381 #define MYNAME "ffi-obj-lib"
00382 static Scheme_Object *foreign_ffi_obj_lib(int argc, Scheme_Object *argv[])
00383 {
00384   if (!SCHEME_FFIOBJP(argv[0]))
00385     scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
00386   return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
00387 }
00388 #undef MYNAME
00389 
00390 /* (ffi-obj-name ffi-obj) -> string */
00391 #define MYNAME "ffi-obj-name"
00392 static Scheme_Object *foreign_ffi_obj_name(int argc, Scheme_Object *argv[])
00393 {
00394   if (!SCHEME_FFIOBJP(argv[0]))
00395     scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
00396   return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
00397 }
00398 #undef MYNAME
00399 
00400 /*****************************************************************************/
00401 /* Type helpers */
00402 
00403 /* These are not defined in MzScheme because:
00404  * - SCHEME_UINT_VAL is not really a simple accessor like other SCHEME_X_VALs
00405  * - scheme_make_integer_from_unsigned behaves the same as the signed version
00406  */
00407 #define SCHEME_UINT_VAL(obj) ((unsigned)(SCHEME_INT_VAL(obj)))
00408 #define scheme_make_integer_from_unsigned(i) \
00409   ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1))
00410 
00411 #ifndef SIXTY_FOUR_BIT_INTEGERS
00412 
00413 /* longs and ints are really the same */
00414 #define scheme_get_realint_val(x,y) \
00415   scheme_get_int_val(x,(long*)(y))
00416 #define scheme_get_unsigned_realint_val(x,y) \
00417   scheme_get_unsigned_int_val(x,(unsigned long*)(y))
00418 #define scheme_make_realinteger_value \
00419   scheme_make_integer_value
00420 #define scheme_make_realinteger_value_from_unsigned \
00421   scheme_make_integer_value_from_unsigned
00422 
00423 #else /* SIXTY_FOUR_BIT_INTEGERS defined */
00424 
00425 /* These will make sense in MzScheme when longs are longer than ints (needed
00426  * for libffi's int32 types).  There is no need to deal with bignums because
00427  * mzscheme's fixnums are longs. */
00428 inline int scheme_get_realint_val(Scheme_Object *o, int *v)
00429 {
00430   if (SCHEME_INTP(o)) {
00431     unsigned long lv = SCHEME_INT_VAL(o);
00432     int i = (int)lv;
00433     if (i != lv)
00434       return 0;
00435     *v = i;
00436     return 1;
00437   } else return 0;
00438 }
00439 inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
00440 {
00441   if (SCHEME_INTP(o)) {
00442     unsigned long lv = SCHEME_INT_VAL(o);
00443     unsigned int i = (unsigned int)lv;
00444     if (i != lv)
00445       return 0;
00446     *v = i;
00447     return 1;
00448   } else return 0;
00449 }
00450 #define scheme_make_realinteger_value(ri) \
00451   scheme_make_integer((long)(ri))
00452 #define scheme_make_realinteger_value_from_unsigned(ri) \
00453   scheme_make_integer((unsigned long)(ri))
00454 
00455 #endif /* SIXTY_FOUR_BIT_INTEGERS */
00456 
00457 /* This is related to the section of scheme.h that defines mzlonglong. */
00458 #ifndef INT64_AS_LONG_LONG
00459 #ifdef  NO_LONG_LONG_TYPE
00460 #ifndef SIXTY_FOUR_BIT_INTEGERS
00461 #error foreign requires a 64-bit integer type type.
00462 #endif
00463 #endif
00464 #endif
00465 
00466 #define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
00467 
00468 static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
00469 {
00470   if (SCHEME_FALSEP(ucs)) return NULL;
00471   return SCHEME_CHAR_STR_VAL(ucs);
00472 }
00473 
00474 static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
00475 {
00476   long ulen;
00477   unsigned short *res;
00478   res = scheme_ucs4_to_utf16
00479           (SCHEME_CHAR_STR_VAL(ucs), 0, 1+SCHEME_CHAR_STRLEN_VAL(ucs),
00480            NULL, -1, &ulen, 0);
00481   return res;
00482 }
00483 
00484 static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
00485 {
00486   if (SCHEME_FALSEP(ucs)) return NULL;
00487   return ucs4_string_to_utf16_pointer(ucs);
00488 }
00489 
00490 Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
00491 {
00492   long ulen;
00493   mzchar *res;
00494   int end;
00495   if (!utf) return scheme_false;
00496   for (end=0; utf[end] != 0; end++) {  }
00497   res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
00498   return scheme_make_sized_char_string(res, ulen, 0);
00499 }
00500 
00501 /*****************************************************************************/
00502 /* Types */
00503 
00504 /***********************************************************************
00505  * The following are the only primitive types.
00506  * The tricky part is figuring out what width-ed types correspond to
00507  * what internal types.  Matthew says:
00508  *   MzScheme expects to be compiled such that sizeof(int) == 4,
00509  *   sizeof(long) == sizeof(void*), sizeof(short) >= 2,
00510  *   sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8.
00511  *   So, on a 64-bit OS, MzScheme expects only `long' to change.
00512  **********************************************************************/
00513 
00514 /* returns #<void> when used as output type, not for input types. */
00515 #define FOREIGN_void (1)
00516 /* Type Name:   void
00517  * LibFfi type: ffi_type_void
00518  * C type:      -none-
00519  * Predicate:   -none-
00520  * Scheme->C:   -none-
00521  * S->C offset: 0
00522  * C->Scheme:   scheme_void
00523  */
00524 
00525 #define FOREIGN_int8 (2)
00526 /* Type Name:   int8
00527  * LibFfi type: ffi_type_sint8
00528  * C type:      Tsint8
00529  * Predicate:   SCHEME_INTP(<Scheme>)
00530  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
00531  * S->C offset: 0
00532  * C->Scheme:   scheme_make_integer(<C>)
00533  */
00534 
00535 #define FOREIGN_uint8 (3)
00536 /* Type Name:   uint8
00537  * LibFfi type: ffi_type_uint8
00538  * C type:      Tuint8
00539  * Predicate:   SCHEME_INTP(<Scheme>)
00540  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
00541  * S->C offset: 0
00542  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
00543  */
00544 
00545 #define FOREIGN_int16 (4)
00546 /* Type Name:   int16
00547  * LibFfi type: ffi_type_sint16
00548  * C type:      Tsint16
00549  * Predicate:   SCHEME_INTP(<Scheme>)
00550  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
00551  * S->C offset: 0
00552  * C->Scheme:   scheme_make_integer(<C>)
00553  */
00554 
00555 #define FOREIGN_uint16 (5)
00556 /* Type Name:   uint16
00557  * LibFfi type: ffi_type_uint16
00558  * C type:      Tuint16
00559  * Predicate:   SCHEME_INTP(<Scheme>)
00560  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
00561  * S->C offset: 0
00562  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
00563  */
00564 
00565 /* Treats integers properly: */
00566 #define FOREIGN_int32 (6)
00567 /* Type Name:   int32
00568  * LibFfi type: ffi_type_sint32
00569  * C type:      Tsint32
00570  * Predicate:   scheme_get_realint_val(<Scheme>,&aux)
00571  * Scheme->C:   -none- (set by the predicate)
00572  * S->C offset: 0
00573  * C->Scheme:   scheme_make_realinteger_value(<C>)
00574  */
00575 
00576 /* Treats integers properly: */
00577 #define FOREIGN_uint32 (7)
00578 /* Type Name:   uint32
00579  * LibFfi type: ffi_type_uint32
00580  * C type:      Tuint32
00581  * Predicate:   scheme_get_unsigned_realint_val(<Scheme>,&aux)
00582  * Scheme->C:   -none- (set by the predicate)
00583  * S->C offset: 0
00584  * C->Scheme:   scheme_make_realinteger_value_from_unsigned(<C>)
00585  */
00586 
00587 #define FOREIGN_int64 (8)
00588 /* Type Name:   int64
00589  * LibFfi type: ffi_type_sint64
00590  * C type:      Tsint64
00591  * Predicate:   scheme_get_long_long_val(<Scheme>,&aux)
00592  * Scheme->C:   -none- (set by the predicate)
00593  * S->C offset: 0
00594  * C->Scheme:   scheme_make_integer_value_from_long_long(<C>)
00595  */
00596 
00597 #define FOREIGN_uint64 (9)
00598 /* Type Name:   uint64
00599  * LibFfi type: ffi_type_uint64
00600  * C type:      Tuint64
00601  * Predicate:   scheme_get_unsigned_long_long_val(<Scheme>,&aux)
00602  * Scheme->C:   -none- (set by the predicate)
00603  * S->C offset: 0
00604  * C->Scheme:   scheme_make_integer_value_from_unsigned_long_long(<C>)
00605  */
00606 
00607 /* This is like int32, but always assumes fixnum: */
00608 #define FOREIGN_fixint (10)
00609 /* Type Name:   fixint
00610  * LibFfi type: ffi_type_sint32
00611  * C type:      Tsint32
00612  * Predicate:   SCHEME_INTP(<Scheme>)
00613  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
00614  * S->C offset: 0
00615  * C->Scheme:   scheme_make_integer(<C>)
00616  */
00617 
00618 /* This is like uint32, but always assumes fixnum: */
00619 #define FOREIGN_ufixint (11)
00620 /* Type Name:   ufixint
00621  * LibFfi type: ffi_type_uint32
00622  * C type:      Tuint32
00623  * Predicate:   SCHEME_INTP(<Scheme>)
00624  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
00625  * S->C offset: 0
00626  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
00627  */
00628 
00629 /* This is what mzscheme defines as long: */
00630 #ifndef SIXTY_FOUR_BIT_INTEGERS
00631 #define ffi_type_smzlong ffi_type_sint32
00632 #define ffi_type_umzlong ffi_type_uint32
00633 #else /* SIXTY_FOUR_BIT_INTEGERS defined */
00634 #define ffi_type_smzlong ffi_type_sint64
00635 #define ffi_type_umzlong ffi_type_uint64
00636 #endif /* SIXTY_FOUR_BIT_INTEGERS */
00637 
00638 /* This is what mzscheme defines as long, assuming fixnums: */
00639 #define FOREIGN_fixnum (12)
00640 /* Type Name:   fixnum
00641  * LibFfi type: ffi_type_smzlong
00642  * C type:      long
00643  * Predicate:   SCHEME_INTP(<Scheme>)
00644  * Scheme->C:   SCHEME_INT_VAL(<Scheme>)
00645  * S->C offset: 0
00646  * C->Scheme:   scheme_make_integer(<C>)
00647  */
00648 
00649 /* This is what mzscheme defines as ulong, assuming fixnums: */
00650 #define FOREIGN_ufixnum (13)
00651 /* Type Name:   ufixnum
00652  * LibFfi type: ffi_type_umzlong
00653  * C type:      unsigned long
00654  * Predicate:   SCHEME_INTP(<Scheme>)
00655  * Scheme->C:   SCHEME_UINT_VAL(<Scheme>)
00656  * S->C offset: 0
00657  * C->Scheme:   scheme_make_integer_from_unsigned(<C>)
00658  */
00659 
00660 #define FOREIGN_float (14)
00661 /* Type Name:   float
00662  * LibFfi type: ffi_type_float
00663  * C type:      float
00664  * Predicate:   SCHEME_FLTP(<Scheme>)
00665  * Scheme->C:   SCHEME_FLT_VAL(<Scheme>)
00666  * S->C offset: 0
00667  * C->Scheme:   scheme_make_float(<C>)
00668  */
00669 
00670 #define FOREIGN_double (15)
00671 /* Type Name:   double
00672  * LibFfi type: ffi_type_double
00673  * C type:      double
00674  * Predicate:   SCHEME_DBLP(<Scheme>)
00675  * Scheme->C:   SCHEME_DBL_VAL(<Scheme>)
00676  * S->C offset: 0
00677  * C->Scheme:   scheme_make_double(<C>)
00678  */
00679 
00680 /* A double that will coerce numbers to doubles: */
00681 #define FOREIGN_doubleS (16)
00682 /* Type Name:   double* (doubleS)
00683  * LibFfi type: ffi_type_double
00684  * C type:      double
00685  * Predicate:   SCHEME_REALP(<Scheme>)
00686  * Scheme->C:   scheme_real_to_double(<Scheme>)
00687  * S->C offset: 0
00688  * C->Scheme:   scheme_make_double(<C>)
00689  */
00690 
00691 /* Booleans -- implemented as an int which is 1 or 0: */
00692 #define FOREIGN_bool (17)
00693 /* Type Name:   bool
00694  * LibFfi type: ffi_type_sint
00695  * C type:      int
00696  * Predicate:   1
00697  * Scheme->C:   SCHEME_TRUEP(<Scheme>)
00698  * S->C offset: 0
00699  * C->Scheme:   (<C>?scheme_true:scheme_false)
00700  */
00701 
00702 /* Strings -- no copying is done (when possible).
00703  * #f is not NULL only for byte-strings, for other strings it is
00704  * meaningless to use NULL. */
00705 
00706 #define FOREIGN_string_ucs_4 (18)
00707 /* Type Name:   string/ucs-4 (string_ucs_4)
00708  * LibFfi type: ffi_type_pointer
00709  * C type:      mzchar*
00710  * Predicate:   SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
00711  * Scheme->C:   ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
00712  * S->C offset: 0
00713  * C->Scheme:   scheme_make_char_string_without_copying(<C>)
00714  */
00715 
00716 #define FOREIGN_string_utf_16 (19)
00717 /* Type Name:   string/utf-16 (string_utf_16)
00718  * LibFfi type: ffi_type_pointer
00719  * C type:      unsigned short*
00720  * Predicate:   SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
00721  * Scheme->C:   ucs4_string_or_null_to_utf16_pointer(<Scheme>)
00722  * S->C offset: 0
00723  * C->Scheme:   utf16_pointer_to_ucs4_string(<C>)
00724  */
00725 
00726 /* Byte strings -- not copying C strings, #f is NULL.
00727  * (note: these are not like char* which is just a pointer) */
00728 
00729 #define FOREIGN_bytes (20)
00730 /* Type Name:   bytes
00731  * LibFfi type: ffi_type_pointer
00732  * C type:      char*
00733  * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
00734  * Scheme->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
00735  * S->C offset: 0
00736  * C->Scheme:   (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
00737  */
00738 
00739 #define FOREIGN_path (21)
00740 /* Type Name:   path
00741  * LibFfi type: ffi_type_pointer
00742  * C type:      char*
00743  * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
00744  * Scheme->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
00745  * S->C offset: 0
00746  * C->Scheme:   (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
00747  */
00748 
00749 #define FOREIGN_symbol (22)
00750 /* Type Name:   symbol
00751  * LibFfi type: ffi_type_pointer
00752  * C type:      char*
00753  * Predicate:   SCHEME_SYMBOLP(<Scheme>)
00754  * Scheme->C:   SCHEME_SYM_VAL(<Scheme>)
00755  * S->C offset: 0
00756  * C->Scheme:   scheme_intern_symbol(<C>)
00757  */
00758 
00759 /* This is for any C pointer: #f is NULL, cpointer values as well as
00760  * ffi-obj and string values pass their pointer.  When used as a return
00761  * value, either a cpointer object or #f is returned. */
00762 #define FOREIGN_pointer (23)
00763 /* Type Name:   pointer
00764  * LibFfi type: ffi_type_pointer
00765  * C type:      void*
00766  * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
00767  * Scheme->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
00768  * S->C offset: FFIANYPTR
00769  * C->Scheme:   scheme_make_foreign_cpointer(<C>)
00770  */
00771 
00772 /* This is used for passing and Scheme_Object* value as is.  Useful for
00773  * functions that know about Scheme_Object*s, like MzScheme's. */
00774 #define FOREIGN_scheme (24)
00775 /* Type Name:   scheme
00776  * LibFfi type: ffi_type_pointer
00777  * C type:      Scheme_Object*
00778  * Predicate:   1
00779  * Scheme->C:   <Scheme>
00780  * S->C offset: 0
00781  * C->Scheme:   <C>
00782  */
00783 
00784 /* Special type, not actually used for anything except to mark values
00785  * that are treated like pointers but not referenced.  Used for
00786  * creating function types. */
00787 #define FOREIGN_fpointer (25)
00788 /* Type Name:   fpointer
00789  * LibFfi type: ffi_type_pointer
00790  * C type:      void*
00791  * Predicate:   -none-
00792  * Scheme->C:   -none-
00793  * S->C offset: 0
00794  * C->Scheme:   -none-
00795  */
00796 
00797 typedef union _ForeignAny {
00798   Tsint8 x_int8;
00799   Tuint8 x_uint8;
00800   Tsint16 x_int16;
00801   Tuint16 x_uint16;
00802   Tsint32 x_int32;
00803   Tuint32 x_uint32;
00804   Tsint64 x_int64;
00805   Tuint64 x_uint64;
00806   Tsint32 x_fixint;
00807   Tuint32 x_ufixint;
00808   long x_fixnum;
00809   unsigned long x_ufixnum;
00810   float x_float;
00811   double x_double;
00812   double x_doubleS;
00813   int x_bool;
00814   mzchar* x_string_ucs_4;
00815   unsigned short* x_string_utf_16;
00816   char* x_bytes;
00817   char* x_path;
00818   char* x_symbol;
00819   void* x_pointer;
00820   Scheme_Object* x_scheme;
00821   void* x_fpointer;
00822 } ForeignAny;
00823 
00824 /* This is a tag that is used to identify user-made struct types. */
00825 #define FOREIGN_struct (26)
00826 
00827 /*****************************************************************************/
00828 /* Type objects */
00829 
00830 /* This struct is used for both user types and primitive types (including
00831  * struct types).  If it is a user type then basetype will be another ctype,
00832  * otherwise,
00833  * - if it's a primitive type, then basetype will be a symbol naming that type
00834  * - if it's a struct, then basetype will be the list of ctypes that
00835  *   made this struct
00836  * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
00837  * integer (a label value) for non-struct type.  (Note that the
00838  * integer is not really needed, since it is possible to identify the
00839  * type by the basetype field.)
00840  */
00841 /* ctype structure definition */
00842 static Scheme_Type ctype_tag;
00843 typedef struct ctype_struct {
00844   Scheme_Object so;
00845   Scheme_Object* basetype;
00846   Scheme_Object* scheme_to_c;
00847   Scheme_Object* c_to_scheme;
00848 } ctype_struct;
00849 #define SCHEME_CTYPEP(x) (SCHEME_TYPE(x)==ctype_tag)
00850 #define MYNAME "ctype?"
00851 static Scheme_Object *foreign_ctype_p(int argc, Scheme_Object *argv[])
00852 {
00853   return SCHEME_CTYPEP(argv[0]) ? scheme_true : scheme_false;
00854 }
00855 #undef MYNAME
00856 /* 3m stuff for ctype */
00857 #ifdef MZ_PRECISE_GC
00858 START_XFORM_SKIP;
00859 int ctype_SIZE(void *p) {
00860   return gcBYTES_TO_WORDS(sizeof(ctype_struct));
00861 }
00862 int ctype_MARK(void *p) {
00863   ctype_struct *s = (ctype_struct *)p;
00864   gcMARK(s->basetype);
00865   gcMARK(s->scheme_to_c);
00866   gcMARK(s->c_to_scheme);
00867   return gcBYTES_TO_WORDS(sizeof(ctype_struct));
00868 }
00869 int ctype_FIXUP(void *p) {
00870   ctype_struct *s = (ctype_struct *)p;
00871   gcFIXUP(s->basetype);
00872   gcFIXUP(s->scheme_to_c);
00873   gcFIXUP(s->c_to_scheme);
00874   return gcBYTES_TO_WORDS(sizeof(ctype_struct));
00875 }
00876 END_XFORM_SKIP;
00877 #endif
00878 
00879 #define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
00880 #define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
00881 #define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
00882 #define CTYPE_PRIMTYPE(x)  ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
00883 #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
00884 #define CTYPE_USER_S2C(x)  (((ctype_struct*)(x))->scheme_to_c)
00885 #define CTYPE_USER_C2S(x)  (((ctype_struct*)(x))->c_to_scheme)
00886 
00887 /* Returns #f for primitive types. */
00888 #define MYNAME "ctype-basetype"
00889 static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
00890 {
00891   if (!SCHEME_CTYPEP(argv[0]))
00892     scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
00893   return CTYPE_BASETYPE(argv[0]);
00894 }
00895 #undef MYNAME
00896 
00897 #define MYNAME "ctype-scheme->c"
00898 static Scheme_Object *foreign_ctype_scheme_to_c(int argc, Scheme_Object *argv[])
00899 {
00900   if (!SCHEME_CTYPEP(argv[0]))
00901     scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
00902   return (CTYPE_PRIMP(argv[0])) ? scheme_false :
00903            ((ctype_struct*)(argv[0]))->scheme_to_c;
00904 }
00905 #undef MYNAME
00906 
00907 #define MYNAME "ctype-c->scheme"
00908 static Scheme_Object *foreign_ctype_c_to_scheme(int argc, Scheme_Object *argv[])
00909 {
00910   if (!SCHEME_CTYPEP(argv[0]))
00911     scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
00912   return (CTYPE_PRIMP(argv[0])) ? scheme_false :
00913            ((ctype_struct*)(argv[0]))->c_to_scheme;
00914 }
00915 #undef MYNAME
00916 
00917 /* Returns a primitive type, or NULL if not a type */
00918 static Scheme_Object *get_ctype_base(Scheme_Object *type)
00919 {
00920   if (!SCHEME_CTYPEP(type)) return NULL;
00921   while (CTYPE_USERP(type)) { type = CTYPE_BASETYPE(type); }
00922   return type;
00923 }
00924 
00925 /* Returns the size, 0 for void, -1 if no such type */
00926 static int ctype_sizeof(Scheme_Object *type)
00927 {
00928   type = get_ctype_base(type);
00929   if (type == NULL) return -1;
00930   switch (CTYPE_PRIMLABEL(type)) {
00931   case FOREIGN_void: return 0;
00932   case FOREIGN_int8: return sizeof(Tsint8);
00933   case FOREIGN_uint8: return sizeof(Tuint8);
00934   case FOREIGN_int16: return sizeof(Tsint16);
00935   case FOREIGN_uint16: return sizeof(Tuint16);
00936   case FOREIGN_int32: return sizeof(Tsint32);
00937   case FOREIGN_uint32: return sizeof(Tuint32);
00938   case FOREIGN_int64: return sizeof(Tsint64);
00939   case FOREIGN_uint64: return sizeof(Tuint64);
00940   case FOREIGN_fixint: return sizeof(Tsint32);
00941   case FOREIGN_ufixint: return sizeof(Tuint32);
00942   case FOREIGN_fixnum: return sizeof(long);
00943   case FOREIGN_ufixnum: return sizeof(unsigned long);
00944   case FOREIGN_float: return sizeof(float);
00945   case FOREIGN_double: return sizeof(double);
00946   case FOREIGN_doubleS: return sizeof(double);
00947   case FOREIGN_bool: return sizeof(int);
00948   case FOREIGN_string_ucs_4: return sizeof(mzchar*);
00949   case FOREIGN_string_utf_16: return sizeof(unsigned short*);
00950   case FOREIGN_bytes: return sizeof(char*);
00951   case FOREIGN_path: return sizeof(char*);
00952   case FOREIGN_symbol: return sizeof(char*);
00953   case FOREIGN_pointer: return sizeof(void*);
00954   case FOREIGN_scheme: return sizeof(Scheme_Object*);
00955   case FOREIGN_fpointer: return sizeof(void*);
00956   /* for structs */
00957   default: return CTYPE_PRIMTYPE(type)->size;
00958   }
00959 }
00960 
00961 /* (make-ctype basetype scheme->c c->scheme) -> ctype */
00962 /* The scheme->c can throw type errors to check for valid arguments */
00963 /* a #f means no conversion function, if both are #f -- then just return the */
00964 /* basetype. */
00965 #define MYNAME "make-ctype"
00966 static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object *argv[])
00967 {
00968   ctype_struct *type;
00969   if (!SCHEME_CTYPEP(argv[0]))
00970     scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
00971   else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
00972     scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
00973   else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
00974     scheme_wrong_type(MYNAME, "procedure-or-false", 2, argc, argv);
00975   else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
00976     return argv[0];
00977   else {
00978     type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
00979     type->so.type = ctype_tag;
00980     type->basetype = (argv[0]);
00981     type->scheme_to_c = (argv[1]);
00982     type->c_to_scheme = (argv[2]);
00983     return (Scheme_Object*)type;
00984   }
00985   return NULL; /* hush the compiler */
00986 }
00987 #undef MYNAME
00988 
00989 /* see below */
00990 void free_libffi_type(void *ignored, void *p)
00991 {
00992   free(((ffi_type*)p)->elements);
00993   free(p);
00994 }
00995 
00996 /*****************************************************************************/
00997 /* ABI spec */
00998 
00999 static Scheme_Object *default_sym;
01000 static Scheme_Object *stdcall_sym;
01001 static Scheme_Object *sysv_sym;
01002 
01003 ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
01004 {
01005   if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym))
01006     return FFI_DEFAULT_ABI;
01007   else if (SAME_OBJ(sym, sysv_sym)) {
01008 #ifdef WINDOWS_DYNAMIC_LOAD
01009     return FFI_SYSV;
01010 #else
01011     scheme_signal_error("%s: ABI not implemented: %V", who, sym);
01012 #endif
01013   } else if (SAME_OBJ(sym, stdcall_sym)) {
01014 #ifdef WINDOWS_DYNAMIC_LOAD
01015     return FFI_STDCALL;
01016 #else
01017     scheme_signal_error("%s: ABI not implemented: %V", who, sym);
01018 #endif
01019   } else {
01020     scheme_signal_error("%s: unknown ABI: %V", who, sym);
01021   }
01022   return 0; /* hush the compiler */
01023 }
01024 
01025 /* helper macro */
01026 #define GET_ABI(name,n) \
01027   ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)
01028 
01029 /*****************************************************************************/
01030 /* cstruct types */
01031 
01032 /* (make-cstruct-type types [abi]) -> ctype */
01033 /* This creates a new primitive type that is a struct.  This type can be used
01034  * with cpointer objects, except that the contents is used rather than the
01035  * pointer value.  Marshaling to lists or whatever should be done in Scheme. */
01036 #define MYNAME "make-cstruct-type"
01037 static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
01038 {
01039   Scheme_Object *p, *base;
01040   /* since ffi_type objects can be used in callbacks, they are allocated using
01041    * malloc so they don't move, and they are freed when the Scheme object is
01042    * GCed. */
01043   GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
01044   ctype_struct *type;
01045   ffi_cif cif;
01046   int i, nargs;
01047   ffi_abi abi;
01048   nargs = scheme_proper_list_length(argv[0]);
01049   if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
01050   abi = GET_ABI(MYNAME,1);
01051   /* allocate the type elements */
01052   elements = malloc((nargs+1) * sizeof(ffi_type*));
01053   elements[nargs] = NULL;
01054   for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
01055     if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
01056       scheme_wrong_type(MYNAME, "list-of-C-types", 0, argc, argv);
01057     if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
01058       scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
01059     elements[i] = CTYPE_PRIMTYPE(base);
01060   }
01061   /* allocate the new libffi type object */
01062   libffi_type = malloc(sizeof(ffi_type));
01063   libffi_type->size      = 0;
01064   libffi_type->alignment = 0;
01065   libffi_type->type      = FFI_TYPE_STRUCT;
01066   libffi_type->elements  = elements;
01067   /* use ffi_prep_cif to set the size and alignment information */
01068   dummy = &libffi_type;
01069   if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
01070     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
01071   type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
01072   type->so.type = ctype_tag;
01073   type->basetype = (argv[0]);
01074   type->scheme_to_c = ((Scheme_Object*)libffi_type);
01075   type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
01076   scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
01077   return (Scheme_Object*)type;
01078 }
01079 #undef MYNAME
01080 
01081 /*****************************************************************************/
01082 /* Callback type */
01083 
01084 /* ffi-callback structure definition */
01085 static Scheme_Type ffi_callback_tag;
01086 typedef struct ffi_callback_struct {
01087   Scheme_Object so;
01088   void* callback;
01089   Scheme_Object* proc;
01090   Scheme_Object* itypes;
01091   Scheme_Object* otype;
01092   int call_in_scheduler;
01093 } ffi_callback_struct;
01094 #define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
01095 #define MYNAME "ffi-callback?"
01096 static Scheme_Object *foreign_ffi_callback_p(int argc, Scheme_Object *argv[])
01097 {
01098   return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false;
01099 }
01100 #undef MYNAME
01101 /* 3m stuff for ffi_callback */
01102 #ifdef MZ_PRECISE_GC
01103 START_XFORM_SKIP;
01104 int ffi_callback_SIZE(void *p) {
01105   return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
01106 }
01107 int ffi_callback_MARK(void *p) {
01108   ffi_callback_struct *s = (ffi_callback_struct *)p;
01109   gcMARK(s->callback);
01110   gcMARK(s->proc);
01111   gcMARK(s->itypes);
01112   gcMARK(s->otype);
01113   return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
01114 }
01115 int ffi_callback_FIXUP(void *p) {
01116   ffi_callback_struct *s = (ffi_callback_struct *)p;
01117   gcFIXUP(s->callback);
01118   gcFIXUP(s->proc);
01119   gcFIXUP(s->itypes);
01120   gcFIXUP(s->otype);
01121   return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
01122 }
01123 END_XFORM_SKIP;
01124 #endif
01125 
01126 /*****************************************************************************/
01127 /* Pointer objects */
01128 /* use cpointer (with a NULL tag when creating), #f for NULL */
01129 
01130 #define SCHEME_FFIANYPTRP(x) \
01131   (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
01132    SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
01133 #define SCHEME_FFIANYPTR_VAL(x) \
01134   (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
01135     (SCHEME_FALSEP(x) ? NULL : \
01136       (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
01137        (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
01138          (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
01139           NULL)))))
01140 #define SCHEME_FFIANYPTR_OFFSET(x) \
01141   (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
01142 #define SCHEME_FFIANYPTR_OFFSETVAL(x) \
01143   W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
01144 
01145 #define SCHEME_CPOINTER_W_OFFSET_P(x) \
01146   SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type)
01147 
01148 #define scheme_make_foreign_cpointer(x) \
01149   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
01150 
01151 #define MYNAME "cpointer?"
01152 static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
01153 {
01154   return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
01155 }
01156 #undef MYNAME
01157 
01158 #define MYNAME "cpointer-tag"
01159 static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
01160 {
01161   Scheme_Object *tag = NULL;
01162   if (!SCHEME_FFIANYPTRP(argv[0]))
01163     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
01164   if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]);
01165   return (tag == NULL) ? scheme_false : tag;
01166 }
01167 #undef MYNAME
01168 
01169 #define MYNAME "set-cpointer-tag!"
01170 static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[])
01171 {
01172   if (!SCHEME_CPTRP(argv[0]))
01173     scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
01174   SCHEME_CPTR_TYPE(argv[0]) = argv[1];
01175   return scheme_void;
01176 }
01177 #undef MYNAME
01178 
01179 /*****************************************************************************/
01180 /* Scheme<-->C conversions */
01181 
01182 /* On big endian machines we need to know whether we're pulling a value from an
01183  * argument location where it always takes a whole word or straight from a
01184  * memory location -- deal with it via a C2SCHEME macro wrapper that is used
01185  * for both the function definition and calls */
01186 #ifdef SCHEME_BIG_ENDIAN
01187 #define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc)
01188 #define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
01189   ? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \
01190   : (((ctype *)W_OFFSET(src,delta))[0]))
01191 #else
01192 #define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
01193 #define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
01194 #endif
01195 
01196 static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
01197                                int delta, int args_loc)
01198 {
01199   Scheme_Object *res;
01200   if (!SCHEME_CTYPEP(type))
01201     scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
01202   if (CTYPE_USERP(type)) {
01203     res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
01204     if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
01205       return res;
01206     else
01207       return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
01208   } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
01209     return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
01210   } else switch (CTYPE_PRIMLABEL(type)) {
01211     case FOREIGN_void: return scheme_void;
01212     case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
01213     case FOREIGN_uint8: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint8));
01214     case FOREIGN_int16: return scheme_make_integer(REF_CTYPE(Tsint16));
01215     case FOREIGN_uint16: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint16));
01216     case FOREIGN_int32: return scheme_make_realinteger_value(REF_CTYPE(Tsint32));
01217     case FOREIGN_uint32: return scheme_make_realinteger_value_from_unsigned(REF_CTYPE(Tuint32));
01218     case FOREIGN_int64: return scheme_make_integer_value_from_long_long(REF_CTYPE(Tsint64));
01219     case FOREIGN_uint64: return scheme_make_integer_value_from_unsigned_long_long(REF_CTYPE(Tuint64));
01220     case FOREIGN_fixint: return scheme_make_integer(REF_CTYPE(Tsint32));
01221     case FOREIGN_ufixint: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint32));
01222     case FOREIGN_fixnum: return scheme_make_integer(REF_CTYPE(long));
01223     case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(unsigned long));
01224     case FOREIGN_float: return scheme_make_float(REF_CTYPE(float));
01225     case FOREIGN_double: return scheme_make_double(REF_CTYPE(double));
01226     case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
01227     case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
01228     case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
01229     case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
01230     case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
01231     case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
01232     case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
01233     case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
01234     case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
01235     case FOREIGN_fpointer: return (REF_CTYPE(void*));
01236     case FOREIGN_struct:
01237            return scheme_make_foreign_cpointer(W_OFFSET(src, delta));
01238     default: scheme_signal_error("corrupt foreign type: %V", type);
01239   }
01240   return NULL; /* hush the compiler */
01241 }
01242 #undef REF_CTYPE
01243 
01244 /* On big endian machines we need to know whether we're pulling a value from an
01245  * argument location where it always takes a whole word or straight from a
01246  * memory location -- deal with it as above, via a SCHEME2C macro wrapper that
01247  * is used for both the function definition and calls, but the actual code in
01248  * the function is different: in the relevant cases zero an int and offset the
01249  * ptr */
01250 
01251 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
01252  * NULL, then any pointer value (any pointer or a struct) is returned, and the
01253  * basetype_p is set to the corrsponding number tag.  If basetype_p is NULL,
01254  * then a struct value will be *copied* into dst. */
01255 static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
01256                       Scheme_Object *val, long *basetype_p, long *_offset,
01257                       int ret_loc)
01258 {
01259   if (!SCHEME_CTYPEP(type))
01260     scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type);
01261   while (CTYPE_USERP(type)) {
01262     if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
01263       val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
01264     type = CTYPE_BASETYPE(type);
01265   }
01266   if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
01267     /* No need for the SET_CTYPE trick for pointers. */
01268     if (SCHEME_FFICALLBACKP(val))
01269       ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
01270     else if (SCHEME_CPTRP(val))
01271       ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
01272     else if (SCHEME_FFIOBJP(val))
01273       ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
01274     else if (SCHEME_FALSEP(val))
01275       ((void**)W_OFFSET(dst,delta))[0] = NULL;
01276     else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
01277          scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
01278   } else switch (CTYPE_PRIMLABEL(type)) {
01279     case FOREIGN_void:
01280       if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
01281       break;
01282     case FOREIGN_int8:
01283 #     ifdef SCHEME_BIG_ENDIAN
01284       if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
01285         ((int*)W_OFFSET(dst,delta))[0] = 0;
01286         delta += (sizeof(int)-sizeof(Tsint8));
01287       }
01288 #     endif /* SCHEME_BIG_ENDIAN */
01289       if (SCHEME_INTP(val)) {
01290         Tsint8 tmp;
01291         tmp = (Tsint8)(SCHEME_INT_VAL(val));
01292         (((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01293       } else {
01294         scheme_wrong_type("Scheme->C","int8",0,1,&(val));
01295         return NULL; /* hush the compiler */
01296       }
01297     case FOREIGN_uint8:
01298 #     ifdef SCHEME_BIG_ENDIAN
01299       if (sizeof(Tuint8)<sizeof(int) && ret_loc) {
01300         ((int*)W_OFFSET(dst,delta))[0] = 0;
01301         delta += (sizeof(int)-sizeof(Tuint8));
01302       }
01303 #     endif /* SCHEME_BIG_ENDIAN */
01304       if (SCHEME_INTP(val)) {
01305         Tuint8 tmp;
01306         tmp = (Tuint8)(SCHEME_UINT_VAL(val));
01307         (((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01308       } else {
01309         scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
01310         return NULL; /* hush the compiler */
01311       }
01312     case FOREIGN_int16:
01313 #     ifdef SCHEME_BIG_ENDIAN
01314       if (sizeof(Tsint16)<sizeof(int) && ret_loc) {
01315         ((int*)W_OFFSET(dst,delta))[0] = 0;
01316         delta += (sizeof(int)-sizeof(Tsint16));
01317       }
01318 #     endif /* SCHEME_BIG_ENDIAN */
01319       if (SCHEME_INTP(val)) {
01320         Tsint16 tmp;
01321         tmp = (Tsint16)(SCHEME_INT_VAL(val));
01322         (((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01323       } else {
01324         scheme_wrong_type("Scheme->C","int16",0,1,&(val));
01325         return NULL; /* hush the compiler */
01326       }
01327     case FOREIGN_uint16:
01328 #     ifdef SCHEME_BIG_ENDIAN
01329       if (sizeof(Tuint16)<sizeof(int) && ret_loc) {
01330         ((int*)W_OFFSET(dst,delta))[0] = 0;
01331         delta += (sizeof(int)-sizeof(Tuint16));
01332       }
01333 #     endif /* SCHEME_BIG_ENDIAN */
01334       if (SCHEME_INTP(val)) {
01335         Tuint16 tmp;
01336         tmp = (Tuint16)(SCHEME_UINT_VAL(val));
01337         (((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01338       } else {
01339         scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
01340         return NULL; /* hush the compiler */
01341       }
01342     case FOREIGN_int32:
01343       if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val));
01344       return NULL;
01345     case FOREIGN_uint32:
01346       if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint32",0,1,&(val));
01347       return NULL;
01348     case FOREIGN_int64:
01349       if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int64",0,1,&(val));
01350       return NULL;
01351     case FOREIGN_uint64:
01352       if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint64",0,1,&(val));
01353       return NULL;
01354     case FOREIGN_fixint:
01355 #     ifdef SCHEME_BIG_ENDIAN
01356       if (sizeof(Tsint32)<sizeof(int) && ret_loc) {
01357         ((int*)W_OFFSET(dst,delta))[0] = 0;
01358         delta += (sizeof(int)-sizeof(Tsint32));
01359       }
01360 #     endif /* SCHEME_BIG_ENDIAN */
01361       if (SCHEME_INTP(val)) {
01362         Tsint32 tmp;
01363         tmp = (Tsint32)(SCHEME_INT_VAL(val));
01364         (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01365       } else {
01366         scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
01367         return NULL; /* hush the compiler */
01368       }
01369     case FOREIGN_ufixint:
01370 #     ifdef SCHEME_BIG_ENDIAN
01371       if (sizeof(Tuint32)<sizeof(int) && ret_loc) {
01372         ((int*)W_OFFSET(dst,delta))[0] = 0;
01373         delta += (sizeof(int)-sizeof(Tuint32));
01374       }
01375 #     endif /* SCHEME_BIG_ENDIAN */
01376       if (SCHEME_INTP(val)) {
01377         Tuint32 tmp;
01378         tmp = (Tuint32)(SCHEME_UINT_VAL(val));
01379         (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01380       } else {
01381         scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
01382         return NULL; /* hush the compiler */
01383       }
01384     case FOREIGN_fixnum:
01385 #     ifdef SCHEME_BIG_ENDIAN
01386       if (sizeof(long)<sizeof(int) && ret_loc) {
01387         ((int*)W_OFFSET(dst,delta))[0] = 0;
01388         delta += (sizeof(int)-sizeof(long));
01389       }
01390 #     endif /* SCHEME_BIG_ENDIAN */
01391       if (SCHEME_INTP(val)) {
01392         long tmp;
01393         tmp = (long)(SCHEME_INT_VAL(val));
01394         (((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01395       } else {
01396         scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
01397         return NULL; /* hush the compiler */
01398       }
01399     case FOREIGN_ufixnum:
01400 #     ifdef SCHEME_BIG_ENDIAN
01401       if (sizeof(unsigned long)<sizeof(int) && ret_loc) {
01402         ((int*)W_OFFSET(dst,delta))[0] = 0;
01403         delta += (sizeof(int)-sizeof(unsigned long));
01404       }
01405 #     endif /* SCHEME_BIG_ENDIAN */
01406       if (SCHEME_INTP(val)) {
01407         unsigned long tmp;
01408         tmp = (unsigned long)(SCHEME_UINT_VAL(val));
01409         (((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01410       } else {
01411         scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
01412         return NULL; /* hush the compiler */
01413       }
01414     case FOREIGN_float:
01415 #     ifdef SCHEME_BIG_ENDIAN
01416       if (sizeof(float)<sizeof(int) && ret_loc) {
01417         ((int*)W_OFFSET(dst,delta))[0] = 0;
01418         delta += (sizeof(int)-sizeof(float));
01419       }
01420 #     endif /* SCHEME_BIG_ENDIAN */
01421       if (SCHEME_FLTP(val)) {
01422         float tmp;
01423         tmp = (float)(SCHEME_FLT_VAL(val));
01424         (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01425       } else {
01426         scheme_wrong_type("Scheme->C","float",0,1,&(val));
01427         return NULL; /* hush the compiler */
01428       }
01429     case FOREIGN_double:
01430 #     ifdef SCHEME_BIG_ENDIAN
01431       if (sizeof(double)<sizeof(int) && ret_loc) {
01432         ((int*)W_OFFSET(dst,delta))[0] = 0;
01433         delta += (sizeof(int)-sizeof(double));
01434       }
01435 #     endif /* SCHEME_BIG_ENDIAN */
01436       if (SCHEME_DBLP(val)) {
01437         double tmp;
01438         tmp = (double)(SCHEME_DBL_VAL(val));
01439         (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01440       } else {
01441         scheme_wrong_type("Scheme->C","double",0,1,&(val));
01442         return NULL; /* hush the compiler */
01443       }
01444     case FOREIGN_doubleS:
01445 #     ifdef SCHEME_BIG_ENDIAN
01446       if (sizeof(double)<sizeof(int) && ret_loc) {
01447         ((int*)W_OFFSET(dst,delta))[0] = 0;
01448         delta += (sizeof(int)-sizeof(double));
01449       }
01450 #     endif /* SCHEME_BIG_ENDIAN */
01451       if (SCHEME_REALP(val)) {
01452         double tmp;
01453         tmp = (double)(scheme_real_to_double(val));
01454         (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01455       } else {
01456         scheme_wrong_type("Scheme->C","double*",0,1,&(val));
01457         return NULL; /* hush the compiler */
01458       }
01459     case FOREIGN_bool:
01460 #     ifdef SCHEME_BIG_ENDIAN
01461       if (sizeof(int)<sizeof(int) && ret_loc) {
01462         ((int*)W_OFFSET(dst,delta))[0] = 0;
01463         delta += (sizeof(int)-sizeof(int));
01464       }
01465 #     endif /* SCHEME_BIG_ENDIAN */
01466       if (1) {
01467         int tmp;
01468         tmp = (int)(SCHEME_TRUEP(val));
01469         (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
01470       } else {
01471         scheme_wrong_type("Scheme->C","bool",0,1,&(val));
01472         return NULL; /* hush the compiler */
01473       }
01474     case FOREIGN_string_ucs_4:
01475 #     ifdef SCHEME_BIG_ENDIAN
01476       if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
01477         ((int*)W_OFFSET(dst,delta))[0] = 0;
01478         delta += (sizeof(int)-sizeof(mzchar*));
01479       }
01480 #     endif /* SCHEME_BIG_ENDIAN */
01481       if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
01482         mzchar* tmp;
01483         tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
01484         if (basetype_p == NULL || tmp == NULL) {
01485           (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
01486           return NULL;
01487         } else {
01488           *basetype_p = FOREIGN_string_ucs_4;
01489           return tmp;
01490         }
01491       } else {
01492         scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
01493         return NULL; /* hush the compiler */
01494       }
01495     case FOREIGN_string_utf_16:
01496 #     ifdef SCHEME_BIG_ENDIAN
01497       if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
01498         ((int*)W_OFFSET(dst,delta))[0] = 0;
01499         delta += (sizeof(int)-sizeof(unsigned short*));
01500       }
01501 #     endif /* SCHEME_BIG_ENDIAN */
01502       if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
01503         unsigned short* tmp;
01504         tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
01505         if (basetype_p == NULL || tmp == NULL) {
01506           (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
01507           return NULL;
01508         } else {
01509           *basetype_p = FOREIGN_string_utf_16;
01510           return tmp;
01511         }
01512       } else {
01513         scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
01514         return NULL; /* hush the compiler */
01515       }
01516     case FOREIGN_bytes:
01517 #     ifdef SCHEME_BIG_ENDIAN
01518       if (sizeof(char*)<sizeof(int) && ret_loc) {
01519         ((int*)W_OFFSET(dst,delta))[0] = 0;
01520         delta += (sizeof(int)-sizeof(char*));
01521       }
01522 #     endif /* SCHEME_BIG_ENDIAN */
01523       if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
01524         char* tmp;
01525         tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
01526         if (basetype_p == NULL || tmp == NULL) {
01527           (((char**)W_OFFSET(dst,delta))[0]) = tmp;
01528           return NULL;
01529         } else {
01530           *basetype_p = FOREIGN_bytes;
01531           return tmp;
01532         }
01533       } else {
01534         scheme_wrong_type("Scheme->C","bytes",0,1,&(val));
01535         return NULL; /* hush the compiler */
01536       }
01537     case FOREIGN_path:
01538 #     ifdef SCHEME_BIG_ENDIAN
01539       if (sizeof(char*)<sizeof(int) && ret_loc) {
01540         ((int*)W_OFFSET(dst,delta))[0] = 0;
01541         delta += (sizeof(int)-sizeof(char*));
01542       }
01543 #     endif /* SCHEME_BIG_ENDIAN */
01544       if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
01545         char* tmp;
01546         tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
01547         if (basetype_p == NULL || tmp == NULL) {
01548           (((char**)W_OFFSET(dst,delta))[0]) = tmp;
01549           return NULL;
01550         } else {
01551           *basetype_p = FOREIGN_path;
01552           return tmp;
01553         }
01554       } else {
01555         scheme_wrong_type("Scheme->C","path",0,1,&(val));
01556         return NULL; /* hush the compiler */
01557       }
01558     case FOREIGN_symbol:
01559 #     ifdef SCHEME_BIG_ENDIAN
01560       if (sizeof(char*)<sizeof(int) && ret_loc) {
01561         ((int*)W_OFFSET(dst,delta))[0] = 0;
01562         delta += (sizeof(int)-sizeof(char*));
01563       }
01564 #     endif /* SCHEME_BIG_ENDIAN */
01565       if (SCHEME_SYMBOLP(val)) {
01566         char* tmp;
01567         tmp = (char*)(SCHEME_SYM_VAL(val));
01568         if (basetype_p == NULL || tmp == NULL) {
01569           (((char**)W_OFFSET(dst,delta))[0]) = tmp;
01570           return NULL;
01571         } else {
01572           *basetype_p = FOREIGN_symbol;
01573           return tmp;
01574         }
01575       } else {
01576         scheme_wrong_type("Scheme->C","symbol",0,1,&(val));
01577         return NULL; /* hush the compiler */
01578       }
01579     case FOREIGN_pointer:
01580 #     ifdef SCHEME_BIG_ENDIAN
01581       if (sizeof(void*)<sizeof(int) && ret_loc) {
01582         ((int*)W_OFFSET(dst,delta))[0] = 0;
01583         delta += (sizeof(int)-sizeof(void*));
01584       }
01585 #     endif /* SCHEME_BIG_ENDIAN */
01586       if (SCHEME_FFIANYPTRP(val)) {
01587         void* tmp; long toff;
01588         tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
01589         toff = SCHEME_FFIANYPTR_OFFSET(val);
01590         if (_offset) *_offset = toff;
01591         if (basetype_p == NULL || (tmp == NULL && toff == 0)) {
01592           (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
01593           return NULL;
01594         } else {
01595           *basetype_p = FOREIGN_pointer;
01596           return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
01597         }
01598       } else {
01599         scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
01600         return NULL; /* hush the compiler */
01601       }
01602     case FOREIGN_scheme:
01603 #     ifdef SCHEME_BIG_ENDIAN
01604       if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
01605         ((int*)W_OFFSET(dst,delta))[0] = 0;
01606         delta += (sizeof(int)-sizeof(Scheme_Object*));
01607       }
01608 #     endif /* SCHEME_BIG_ENDIAN */
01609       if (1) {
01610         Scheme_Object* tmp;
01611         tmp = (Scheme_Object*)(val);
01612         if (basetype_p == NULL || tmp == NULL) {
01613           (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
01614           return NULL;
01615         } else {
01616           *basetype_p = FOREIGN_scheme;
01617           return tmp;
01618         }
01619       } else {
01620         scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
01621         return NULL; /* hush the compiler */
01622       }
01623     case FOREIGN_fpointer:
01624       if (!(ret_loc)) scheme_wrong_type("Scheme->C","fpointer",0,1,&(val));
01625       break;
01626     case FOREIGN_struct:
01627       if (!SCHEME_FFIANYPTRP(val))
01628         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
01629       {
01630         void* p = SCHEME_FFIANYPTR_VAL(val);
01631         long poff = SCHEME_FFIANYPTR_OFFSET(val);
01632         if (basetype_p == NULL) {
01633           if (p == NULL && poff == 0)
01634             scheme_signal_error("FFI pointer value was NULL");
01635           memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff),
01636                  CTYPE_PRIMTYPE(type)->size);
01637           return NULL;
01638         } else {
01639           *basetype_p = FOREIGN_struct;
01640           if (_offset) {
01641             *_offset = poff;
01642             return p;
01643           } else {
01644             return W_OFFSET(p, poff);
01645           }
01646         }
01647       }
01648     default: scheme_signal_error("corrupt foreign type: %V", type);
01649   }
01650   return NULL; /* hush the compiler */
01651 }
01652 #undef SET_CTYPE
01653 
01654 /*****************************************************************************/
01655 /* C type information */
01656 
01657 /* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */
01658 #define MYNAME "ctype-sizeof"
01659 static Scheme_Object *foreign_ctype_sizeof(int argc, Scheme_Object *argv[])
01660 {
01661   int size;
01662   size = ctype_sizeof(argv[0]);
01663   if (size >= 0) return scheme_make_integer(size);
01664   else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
01665   return NULL; /* hush the compiler */
01666 }
01667 #undef MYNAME
01668 
01669 /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
01670 #define MYNAME "ctype-alignof"
01671 static Scheme_Object *foreign_ctype_alignof(int argc, Scheme_Object *argv[])
01672 {
01673   Scheme_Object *type;
01674   type = get_ctype_base(argv[0]);
01675   if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
01676   else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
01677   return NULL; /* hush the compiler */
01678 }
01679 #undef MYNAME
01680 
01681 /* (compiler-sizeof symbols) -> int, where symbols name some C type.
01682  * The symbols are in 'int 'char 'void 'short 'long '*, order does not matter,
01683  * when a single symbol is used, a list is not needed.
01684  * (This is about actual C types, not C type objects.) */
01685 #define MYNAME "compiler-sizeof"
01686 static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
01687 {
01688   int res=0;
01689   int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */
01690   int intsize = 0;  /* "short" => decrement, "long" => increment */
01691   int stars = 0;    /* number of "*"s */
01692   Scheme_Object *l = argv[0], *p;
01693   while (!SAME_OBJ(l, scheme_null)) {
01694     if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); }
01695     else { p = l; l = scheme_null; }
01696     if (!SCHEME_SYMBOLP(p)) {
01697       scheme_wrong_type(MYNAME, "list of symbols", 0, argc, argv);
01698     } else if (!strcmp(SCHEME_SYM_VAL(p),"int")) {
01699       if (basetype==0) basetype=1;
01700       else scheme_signal_error(MYNAME": extraneous type: %V", p);
01701     } else if (!strcmp(SCHEME_SYM_VAL(p),"char")) {
01702       if (basetype==0) basetype=2;
01703       else scheme_signal_error(MYNAME": extraneous type: %V", p);
01704     } else if (!strcmp(SCHEME_SYM_VAL(p),"void")) {
01705       if (basetype==0) basetype=3;
01706       else scheme_signal_error(MYNAME": extraneous type: %V", p);
01707     } else if (!strcmp(SCHEME_SYM_VAL(p),"float")) {
01708       if (basetype==0) basetype=4;
01709       else scheme_signal_error(MYNAME": extraneous type: %V", p);
01710     } else if (!strcmp(SCHEME_SYM_VAL(p),"double")) {
01711       if (basetype==0 || basetype==4) basetype=5;
01712       else scheme_signal_error(MYNAME": extraneous type: %V", p);
01713     } else if (!strcmp(SCHEME_SYM_VAL(p),"short")) {
01714       if (intsize>0)
01715         scheme_signal_error(MYNAME": cannot use both 'short and 'long");
01716       else intsize--;
01717     } else if (!strcmp(SCHEME_SYM_VAL(p),"long")) {
01718       if (intsize<0)
01719         scheme_signal_error(MYNAME": cannot use both 'short and 'long");
01720       else intsize++;
01721     } else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
01722       stars++;
01723     } else {
01724       scheme_wrong_type(MYNAME, "list of C type symbols", 0, argc, argv);
01725     }
01726   }
01727   if (stars > 1)
01728     scheme_signal_error(MYNAME": cannot handle more than one '*");
01729   if (intsize < -1)
01730     scheme_signal_error(MYNAME": cannot handle more than one 'short");
01731   if (intsize > 2)
01732     scheme_signal_error(MYNAME": cannot handle more than two 'long");
01733   if (basetype == 0) basetype = 1; /* int is the default type */
01734   /* don't assume anything, so it can be used to verify compiler assumptions */
01735   /* (only forbid stuff that the compiler doesn't allow) */
01736 # define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))
01737   switch (basetype) {
01738   case 1: /* int */
01739     switch (intsize) {
01740     case 0:  RETSIZE(int); break;
01741     case 1:  RETSIZE(long int); break;
01742 #   ifdef INT64_AS_LONG_LONG
01743     case 2:  RETSIZE(_int64); break; /* MSVC doesn't allow long long */
01744 #   else /* INT64_AS_LONG_LONG undefined */
01745     case 2:  RETSIZE(long long int); break;
01746 #   endif /* INT64_AS_LONG_LONG */
01747     case -1: RETSIZE(short int); break;
01748     }
01749     break;
01750   case 2: /* char */
01751     if (intsize==0) RETSIZE(char);
01752     else scheme_signal_error(MYNAME": cannot qualify 'char");
01753     break;
01754   case 3: /* void */
01755     if (intsize==0 && stars>0) RETSIZE(void);
01756     else if (stars==0)
01757       scheme_signal_error(MYNAME": cannot use 'void without a '*");
01758     else scheme_signal_error(MYNAME": cannot qualify 'void");
01759     break;
01760   case 4: /* float */
01761     if (intsize==0) RETSIZE(float);
01762     else scheme_signal_error(MYNAME": bad qualifiers for 'float");
01763     break;
01764   case 5: /* double */
01765     if (intsize==0) RETSIZE(double);
01766     else if (intsize==1) RETSIZE(long double);
01767     else scheme_signal_error(MYNAME": bad qualifiers for 'double");
01768     break;
01769   default:
01770     scheme_signal_error(MYNAME": internal error (unexpected type %d)",
01771                         basetype);
01772   }
01773 # undef RETSIZE
01774   return scheme_make_integer(res);
01775 }
01776 #undef MYNAME
01777 
01778 /*****************************************************************************/
01779 /* Pointer type user functions */
01780 
01781 static Scheme_Object *nonatomic_sym;
01782 static Scheme_Object *atomic_sym;
01783 static Scheme_Object *stubborn_sym;
01784 static Scheme_Object *uncollectable_sym;
01785 static Scheme_Object *eternal_sym;
01786 static Scheme_Object *interior_sym;
01787 static Scheme_Object *atomic_interior_sym;
01788 static Scheme_Object *raw_sym;
01789 static Scheme_Object *fail_ok_sym;
01790 
01791 /* (malloc num type cpointer mode) -> pointer */
01792 /* The arguments for this function are:
01793  * - num: bytes to allocate, or the number of instances of type when given,
01794  * - type: malloc the size of this type (or num instances of it),
01795  * - cpointer: a source pointer to copy contents from,
01796  * - mode: a symbol for different allocation functions to use - one of
01797  *   'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'raw (the last
01798  *   one is for using the real malloc)
01799  * - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is
01800  *   used with the chosen malloc function
01801  * The arguments can be specified in any order at all since they are all
01802  * different types, the only requirement is for a size, either a number of
01803  * bytes or a type.  If no mode is specified, then scheme_malloc will be used
01804  * when the type is any pointer, otherwise scheme_malloc_atomic is used. */
01805 #define MYNAME "malloc"
01806 static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
01807 {
01808   int i, size=0, num=0, failok=0;
01809   void *from = NULL, *res = NULL;
01810   long foff = 0;
01811   Scheme_Object *mode = NULL, *a, *base = NULL;
01812   void *(*mf)(size_t);
01813   for (i=0; i<argc; i++) {
01814     a = argv[i];
01815     if (SCHEME_INTP(a)) {
01816       if (num != 0)
01817         scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
01818       num = SCHEME_INT_VAL(a);
01819       if (num <= 0)
01820         scheme_wrong_type(MYNAME, "positive-integer", 0, argc, argv);
01821     } else if (SCHEME_CTYPEP(a)) {
01822       if (size != 0)
01823         scheme_signal_error(MYNAME": specifying a second type: %V", a);
01824       if (NULL == (base = get_ctype_base(a)))
01825         scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
01826       size = ctype_sizeof(a);
01827       if (size <= 0)
01828         scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
01829     } else if (SAME_OBJ(a, fail_ok_sym)) {
01830       failok = 1;
01831     } else if (SCHEME_SYMBOLP(a)) {
01832       if (mode != NULL)
01833         scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
01834       mode = a;
01835     } else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
01836       if (from != NULL)
01837         scheme_signal_error(MYNAME": specifying a second source pointer: %V",
01838                             a);
01839       from = SCHEME_FFIANYPTR_VAL(a);
01840       foff = SCHEME_FFIANYPTR_OFFSET(a);
01841     } else {
01842       scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
01843     }
01844   }
01845   if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
01846   size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
01847   if (mode == NULL)
01848     mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
01849       ? scheme_malloc : scheme_malloc_atomic;
01850   else if (SAME_OBJ(mode, nonatomic_sym))     mf = scheme_malloc;
01851   else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
01852   else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
01853   else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
01854   else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
01855   else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_allow_interior;
01856   else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
01857   else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
01858   else {
01859     scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
01860     return NULL; /* hush the compiler */
01861   }
01862   if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
01863   if (((from != NULL) || (foff != 0)) && (res != NULL))
01864     memcpy(res, W_OFFSET(from, foff), size);
01865   return scheme_make_foreign_cpointer(res);
01866 }
01867 #undef MYNAME
01868 
01869 /* (end-stubborn-change ptr) */
01870 #define MYNAME "end-stubborn-change"
01871 static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[])
01872 {
01873   void *ptr;
01874   long poff;
01875   if (!SCHEME_FFIANYPTRP(argv[0]))
01876     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
01877   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
01878   poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
01879   if ((ptr == NULL) && (poff == 0))
01880     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
01881   scheme_end_stubborn_change(W_OFFSET(ptr, poff));
01882   return scheme_void;
01883 }
01884 #undef MYNAME
01885 
01886 /* (free ptr) */
01887 /* This is useful for raw-malloced objects, including objects from C libraries
01888  * that the library is mallocing itself. */
01889 #define MYNAME "free"
01890 static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
01891 {
01892   void *ptr;
01893   long poff;
01894   if (!SCHEME_FFIANYPTRP(argv[0]))
01895     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
01896   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
01897   poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
01898   if ((ptr == NULL) && (poff == 0))
01899     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
01900   free(W_OFFSET(ptr, poff));
01901   return scheme_void;
01902 }
01903 #undef MYNAME
01904 
01905 /* (malloc-immobile-cell v) */
01906 #define MYNAME "malloc-immobile-cell"
01907 static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
01908 {
01909   return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
01910 }
01911 #undef MYNAME
01912 
01913 /* (free-immobile-cell b) */
01914 #define MYNAME "free-immobile-cell"
01915 static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[])
01916 {
01917   void *ptr;
01918   long poff;
01919   if (!SCHEME_FFIANYPTRP(argv[0]))
01920     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
01921   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
01922   poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
01923   if ((ptr == NULL) && (poff == 0))
01924     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
01925   scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
01926   return scheme_void;
01927 }
01928 #undef MYNAME
01929 
01930 #define C_LONG_TYPE_STR "exact integer that fits a C long"
01931 
01932 /* (ptr-add cptr offset-k [type])
01933  *   Adds an offset to a pointer, returning an offset_cpointer value
01934  * (ptr-add! cptr offset-k [type])
01935  *   Modifies an existing offset_cpointer value by adjusting its offset field,
01936  *   returns void
01937  */
01938 static Scheme_Object *do_ptr_add(const char *who, int is_bang,
01939                                  int argc, Scheme_Object **argv)
01940 {
01941   long noff;
01942   if (is_bang) {
01943     if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
01944       scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
01945   } else {
01946     if (!SCHEME_FFIANYPTRP(argv[0]))
01947       scheme_wrong_type(who, "cpointer", 0, argc, argv);
01948   }
01949   if (!scheme_get_int_val(argv[1], &noff))
01950     scheme_wrong_type(who, C_LONG_TYPE_STR, 1, argc, argv);
01951   if (argc > 2) {
01952     if (SCHEME_CTYPEP(argv[2])) {
01953       long size;
01954       size = ctype_sizeof(argv[2]);
01955       if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv);
01956       noff = noff * size;
01957     } else
01958       scheme_wrong_type(who, "C-type", 2, argc, argv);
01959   }
01960   if (is_bang) {
01961     ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
01962     return scheme_void;
01963   } else {
01964     return scheme_make_offset_cptr
01965              (SCHEME_FFIANYPTR_VAL(argv[0]),
01966               SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
01967               (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
01968   }
01969 }
01970 
01971 /* (ptr-add cptr offset-k [type]) */
01972 #define MYNAME "ptr-add"
01973 static Scheme_Object *foreign_ptr_add(int argc, Scheme_Object *argv[])
01974 {
01975   return do_ptr_add(MYNAME, 0, argc, argv);
01976 }
01977 #undef MYNAME
01978 /* (ptr-add! cptr offset-k [type]) */
01979 #define MYNAME "ptr-add!"
01980 static Scheme_Object *foreign_ptr_add_bang(int argc, Scheme_Object *argv[])
01981 {
01982   return do_ptr_add(MYNAME, 1, argc, argv);
01983 }
01984 #undef MYNAME
01985 
01986 /* (offset-ptr? x) */
01987 /* Returns #t if the argument is a cpointer with an offset */
01988 #define MYNAME "offset-ptr?"
01989 static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
01990 {
01991   return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false;
01992 }
01993 #undef MYNAME
01994 
01995 /* (ptr-offset ptr) */
01996 /* Returns the offset of a cpointer (0 if it's not an offset pointer) */
01997 #define MYNAME "ptr-offset"
01998 static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[])
01999 {
02000   if (!SCHEME_FFIANYPTRP(argv[0]))
02001     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02002   return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
02003 }
02004 #undef MYNAME
02005 
02006 /* (set-ptr-offset! ptr offset [type]) */
02007 /* Sets the offset of an offset-cpointer (possibly multiplied by the size of
02008  * the given ctype) */
02009 #define MYNAME "set-ptr-offset!"
02010 static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[])
02011 {
02012   long noff;
02013   if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
02014     scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
02015   if (!scheme_get_int_val(argv[1], &noff)) {
02016     scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
02017   }
02018   if (argc > 2) {
02019     if (SCHEME_CTYPEP(argv[2])) {
02020       long size;
02021       if (NULL == get_ctype_base(argv[2]))
02022         scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
02023       size = ctype_sizeof(argv[2]);
02024       if (size <= 0)
02025         scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
02026       noff = noff * size;
02027     } else
02028       scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
02029   }
02030   ((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
02031   return scheme_void;
02032 }
02033 #undef MYNAME
02034 
02035 /* (mem{move,cpy} dest-ptr [dest-offset] src-ptr [src-offset] count [ctype])
02036  *   Copies count * sizeof(ctype) bytes
02037  *   from src-ptr + src-offset * sizeof(ctype)
02038  *   to dest-ptr + dest-offset * sizeof(ctype).
02039  * --or--
02040  * (memset dest-ptr [dest-offset] byte count [ctype])
02041  *   Sets count * sizeof(ctype) bytes to byte
02042  *   at dest-ptr + dest-offset * sizeof(ctype) */
02043 static Scheme_Object *do_memop(const char *who, int mode,
02044                                int argc, Scheme_Object **argv)
02045 /* mode 0=>memset, 1=>memmove, 2=>memcpy */
02046 {
02047   void *src = NULL, *dest = NULL;
02048   long soff = 0, doff = 0, count, v, mult = 0;
02049   int i, j, ch = 0, argc1 = argc;
02050 
02051   /* arg parsing: last optional ctype, then count, then fill byte for memset,
02052    * then the first and second pointer+offset pair. */
02053 
02054   /* get the optional last ctype multiplier */
02055   if (SCHEME_CTYPEP(argv[argc1-1])) {
02056     argc1--;
02057     mult = ctype_sizeof(argv[argc1]);
02058     if (mult <= 0)
02059       scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv);
02060   }
02061 
02062   /* get the count argument */
02063   argc1--;
02064   if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
02065     scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, argc1, argc, argv);
02066   if (mult) count *= mult;
02067 
02068   /* get the fill byte for memset */
02069   if (!mode) {
02070     argc1--;
02071     ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1;
02072     if ((ch < 0) || (ch > 255))
02073       scheme_wrong_type(who, "byte", argc1, argc, argv);
02074   }
02075 
02076   /* get the two pointers + offsets */
02077   i = 0;
02078   for (j=0; j<2; j++) {
02079     if (!mode && j==1) break; /* memset needs only a dest argument */
02080     if (!(i<argc1))
02081       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02082                        "%s: missing a pointer argument for %s",
02083                        who, (j == 0 ? "destination" : "source"));
02084     if (!SCHEME_FFIANYPTRP(argv[i]))
02085       scheme_wrong_type(who, "cpointer", i, argc, argv);
02086     switch (j) {
02087     case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
02088             doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
02089             break;
02090     case 1: src  = SCHEME_FFIANYPTR_VAL(argv[i]);
02091             soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
02092             break;
02093     }
02094     i++;
02095     if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
02096       if (!scheme_get_int_val(argv[i], &v))
02097         scheme_wrong_type(who, C_LONG_TYPE_STR, i, argc, argv);
02098       if (mult) v *= mult;
02099       switch (j) {
02100       case 0: doff += v; break;
02101       case 1: soff += v; break;
02102       }
02103       i++;
02104     }
02105   }
02106 
02107   /* verify that there are no unused leftovers */
02108   if (!(i==argc1))
02109     scheme_arg_mismatch(who, "unexpected extra argument: ", argv[i]);
02110 
02111   switch (mode) {
02112   case 0: memset (W_OFFSET(dest, doff), ch, count); break;
02113   case 1: memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
02114   case 2: memcpy (W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
02115   }
02116 
02117   return scheme_void;
02118 }
02119 
02120 #define MYNAME "memset"
02121 static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
02122 {
02123   return do_memop(MYNAME, 0, argc, argv);
02124 }
02125 #undef MYNAME
02126 #define MYNAME "memmove"
02127 static Scheme_Object *foreign_memmove(int argc, Scheme_Object *argv[])
02128 {
02129   return do_memop(MYNAME, 1, argc, argv);
02130 }
02131 #undef MYNAME
02132 #define MYNAME "memcpy"
02133 static Scheme_Object *foreign_memcpy(int argc, Scheme_Object *argv[])
02134 {
02135   return do_memop(MYNAME, 2, argc, argv);
02136 }
02137 #undef MYNAME
02138 
02139 static Scheme_Object *abs_sym;
02140 
02141 /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */
02142 /* n defaults to 0 which is the only value that should be used with ffi_objs */
02143 /* if n is given, an 'abs flag can precede it to make n be a byte offset */
02144 /* rather than some multiple of sizeof(type). */
02145 /* WARNING: there are *NO* checks at all, this is raw C level code. */
02146 #define MYNAME "ptr-ref"
02147 static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
02148 {
02149   int size=0; void *ptr; Scheme_Object *base;
02150   long delta;
02151 
02152   if (!SCHEME_FFIANYPTRP(argv[0]))
02153     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02154   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
02155   delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
02156   if ((ptr == NULL) && (delta == 0))
02157     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
02158   if (NULL == (base = get_ctype_base(argv[1])))
02159     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
02160   size = ctype_sizeof(base);
02161 
02162   if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
02163     if (SCHEME_FFIOBJP(argv[0])) {
02164       /* The ffiobj pointer is the function pointer. */
02165       ptr = argv[0];
02166       delta = (long)&(((ffi_obj_struct*)0x0)->obj);
02167     }
02168   }
02169 
02170   if (size < 0) {
02171     /* should not happen */
02172     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
02173   } else if (size == 0) {
02174     scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
02175   }
02176 
02177   if (argc > 3) {
02178     if (!SAME_OBJ(argv[2],abs_sym))
02179       scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
02180     if (!SCHEME_INTP(argv[3]))
02181       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
02182     delta += SCHEME_INT_VAL(argv[3]);
02183   } else if (argc > 2) {
02184     if (!SCHEME_INTP(argv[2]))
02185       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
02186     if (!size)
02187       scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
02188     delta += (size * SCHEME_INT_VAL(argv[2]));
02189   }
02190   return C2SCHEME(argv[1], ptr, delta, 0);
02191 }
02192 #undef MYNAME
02193 
02194 /* (ptr-set! cpointer type [['abs] n] value) -> void */
02195 /* n defaults to 0 which is the only value that should be used with ffi_objs */
02196 /* if n is given, an 'abs flag can precede it to make n be a byte offset */
02197 /* rather than some multiple of sizeof(type). */
02198 /* WARNING: there are *NO* checks at all, this is raw C level code. */
02199 #define MYNAME "ptr-set!"
02200 static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
02201 {
02202   int size=0; void *ptr;
02203   long delta;
02204   Scheme_Object *val = argv[argc-1], *base;
02205   if (!SCHEME_FFIANYPTRP(argv[0]))
02206     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02207   ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
02208   delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
02209   if ((ptr == NULL) && (delta == 0))
02210     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
02211   if (NULL == (base = get_ctype_base(argv[1])))
02212     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
02213   size = ctype_sizeof(base);
02214 
02215   if (size < 0) {
02216     /* should not happen */
02217     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
02218   } else if (size == 0) {
02219     scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
02220   }
02221 
02222   if (argc > 4) {
02223     if (!SAME_OBJ(argv[2],abs_sym))
02224       scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
02225     if (!SCHEME_INTP(argv[3]))
02226       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
02227     delta += SCHEME_INT_VAL(argv[3]);
02228   } else if (argc > 3) {
02229     if (!SCHEME_INTP(argv[2]))
02230       scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
02231     if (!size)
02232       scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
02233     delta += (size * SCHEME_INT_VAL(argv[2]));
02234   }
02235   SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
02236   return scheme_void;
02237 }
02238 #undef MYNAME
02239 
02240 /* (ptr-equal? cpointer cpointer) -> boolean */
02241 #define MYNAME "ptr-equal?"
02242 static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
02243 {
02244   if (!SCHEME_FFIANYPTRP(argv[0]))
02245     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02246   if (!SCHEME_FFIANYPTRP(argv[1]))
02247     scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
02248   return (SAME_OBJ(argv[0],argv[1]) ||
02249           (SCHEME_FFIANYPTR_OFFSETVAL(argv[0])
02250            == SCHEME_FFIANYPTR_OFFSETVAL(argv[1])))
02251          ? scheme_true : scheme_false;
02252 }
02253 #undef MYNAME
02254 
02255 /* (make-sized-byte-string cpointer len) */
02256 #define MYNAME "make-sized-byte-string"
02257 static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[])
02258 {
02259   /* Warning: no copying is done so it is possible to share string contents. */
02260   /* Warning: if source ptr has a offset, resulting string object uses shifted
02261    * pointer.
02262    * (Should use real byte-strings with new version.) */
02263   long len;
02264   if (!SCHEME_FFIANYPTRP(argv[0]))
02265     scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02266   if (!scheme_get_int_val(argv[1],&len))
02267     scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
02268   if (SCHEME_FALSEP(argv[0])) return scheme_false;
02269   else return
02270          scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
02271                                        len, 0);
02272 }
02273 #undef MYNAME
02274 
02275 /* *** Calling Scheme code while the GC is working leads to subtle bugs, so
02276    *** this is implemented now in Scheme using will executors. */
02277 
02278 /* internal: apply Scheme finalizer */
02279 void do_scm_finalizer(void *p, void *finalizer)
02280 {
02281   Scheme_Object *f = (Scheme_Object*)finalizer;
02282   if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(void*)(&p));
02283 }
02284 void do_ptr_finalizer(void *p, void *finalizer)
02285 {
02286   Scheme_Object *f = (Scheme_Object*)finalizer;
02287   Scheme_Object *ptr;
02288   if (p == NULL) return;
02289   ptr = scheme_make_cptr(p,NULL);
02290   if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(&ptr));
02291   /* don't leave dangling references! */
02292   SCHEME_CPTR_VAL(ptr) = NULL;
02293   ptr = NULL;
02294 }
02295 
02296 /* (register-finalizer ptrobj finalizer ['pointer]) -> old-finalizer */
02297 /* The finalizer is called by the primitive finalizer mechanism, make sure */
02298 /* no references to the object are recreated.  #f means erase existing */
02299 /* finalizer if any.*/
02300 /* If no 'pointer argument is given, this is can be used with any Scheme */
02301 /* object, and the finalizer will be called with it.  If an additional */
02302 /* 'pointer argument of 'pointer is given, the object must be a cpointer */
02303 /* object, the finalizer will be invoked when the pointer itself is */
02304 /* unreachable, and it will get a new cpointer object that points to it. */
02305 /* (Only needed in cases where pointer aliases might be created.) */
02306 /*
02307  * defsymbols[pointer]
02308  * cdefine[register-finalizer 2 3]{
02309  *   void *ptr, *old = NULL;
02310  *   int ptrsym = (argc == 3 && argv[2] == pointer_sym);
02311  *   if (ptrsym) {
02312  *     if (!SCHEME_FFIANYPTRP(argv[0]))
02313  *       scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
02314  *     ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
02315  *     if (ptr == NULL)
02316  *       scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
02317  *   } else {
02318  *     if (argc == 3)
02319  *       scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv);
02320  *     ptr = argv[0];
02321  *   }
02322  *   if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
02323  *     scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
02324  *   scheme_register_finalizer
02325  *     (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer),
02326  *      argv[1], NULL, &old);
02327  *   return (old == NULL) ? scheme_false : (Scheme_Object*)old;
02328  * }
02329  */
02330 
02331 /*****************************************************************************/
02332 /* Calling foreign function objects */
02333 
02334 #define MAX_QUICK_ARGS 16
02335 
02336 typedef void(*VoidFun)();
02337 
02338 Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
02339 /* data := {name, c-function, itypes, otype, cif} */
02340 {
02341   /* The name is not currently used */
02342   /* char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); */
02343   void          *c_func = (void*)(SCHEME_VEC_ELS(data)[1]);
02344   Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2];
02345   Scheme_Object *otype  = SCHEME_VEC_ELS(data)[3];
02346   Scheme_Object *base;
02347   ffi_cif       *cif    = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
02348   long          cfoff   = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
02349   int           nargs   = cif->nargs;
02350   /* When the foreign function is called, we need an array (ivals) of nargs
02351    * ForeignAny objects to store the actual C values that are created, and we
02352    * need another array (avalues) for the pointers to these values (this is
02353    * what libffi actually uses).  To make things more fun, ForeignAny is
02354    * problematic for the precise GC, since it is sometimes a pointer and
02355    * sometime not.  To deal with this, while converting argv objects into
02356    * ivals, scheme_to_c will save pointer values in avalues, so the GC can,
02357    * ignore ivals -- just before we reach the actual call, avalues is
02358    * overwritten, but from that point on it is all C code so there is no
02359    * problem.  Hopefully.
02360    * (Things get complicated if the C call can involve GC (usually due to a
02361    * Scheme callback), but then the programmer need to arrange for pointers
02362    * that cannot move.  Because of all this, the *only* array that should not
02363    * be ignored by the GC is avalues.)
02364    */
02365   GC_CAN_IGNORE ForeignAny *ivals, oval;
02366   void **avalues, *p, *newp, *tmp;
02367   GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
02368   void *stack_avalues[MAX_QUICK_ARGS];
02369   long stack_offsets[MAX_QUICK_ARGS];
02370   int i;
02371   long basetype, offset, *offsets;
02372   if (nargs <= MAX_QUICK_ARGS) {
02373     ivals   = stack_ivals;
02374     avalues = stack_avalues;
02375     offsets = stack_offsets;
02376   } else {
02377     ivals   = malloc(nargs * sizeof(ForeignAny));
02378     avalues = scheme_malloc(nargs * sizeof(void*));
02379     offsets = scheme_malloc(nargs * sizeof(long));
02380   }
02381   /* iterate on input values and types */
02382   for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
02383     /* convert argv[i] according to current itype */
02384     offset = 0;
02385     p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
02386                  &offset, 0);
02387     if ((p != NULL) || offset) {
02388       avalues[i] = p;
02389       ivals[i].x_fixnum = basetype; /* remember the base type */
02390     } else {
02391       avalues[i] = NULL;
02392     }
02393     offsets[i] = offset;
02394   }
02395   base = get_ctype_base(otype); /* verified below, so cannot be NULL */
02396   /* If this is a struct return value, then need to malloc in any case, even if
02397    * the size is smaller than ForeignAny, because this value will be
02398    * returned. */
02399   if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
02400     /* need to have p be a pointer that is invisible to the GC */
02401     p = malloc(CTYPE_PRIMTYPE(base)->size);
02402     newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
02403   } else {
02404     p = &oval;
02405     newp = NULL;
02406   }
02407   /* We finished with all possible mallocs, clear up the avalues and offsets
02408    * mess */
02409   for (i=0; i<nargs; i++) {
02410     if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
02411       avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
02412     else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
02413       /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
02414       ivals[i].x_pointer = avalues[i];
02415       avalues[i] = &(ivals[i]);
02416     }
02417     /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
02418     /* Add offset, if any: */
02419     if (offsets[i] != 0) {
02420       ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
02421     }
02422   }
02423   /* Finally, call the function */
02424   ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
02425   if (ivals != stack_ivals) free(ivals);
02426   ivals = NULL; /* no need now to hold on to this */
02427   for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
02428   avalues = NULL;
02429   switch (CTYPE_PRIMLABEL(base)) {
02430   case FOREIGN_struct:
02431     memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
02432     free(p);
02433     p = newp;
02434     break;
02435   default:
02436     /* not sure why this code is here, looks fine to remove this case */
02437     if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
02438       tmp = ((void**)p)[0];
02439       p = &tmp;
02440     }
02441     break;
02442   }
02443   return C2SCHEME(otype, p, 0, 1);
02444 }
02445 
02446 /* see below */
02447 void free_fficall_data(void *ignored, void *p)
02448 {
02449   free(((ffi_cif*)p)->arg_types);
02450   free(p);
02451 }
02452 
02453 /* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */
02454 /* the real work is done by ffi_do_call above */
02455 #define MYNAME "ffi-call"
02456 static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
02457 {
02458   static Scheme_Object *ffi_name_prefix = NULL;
02459   Scheme_Object *itypes = argv[1];
02460   Scheme_Object *otype  = argv[2];
02461   Scheme_Object *obj, *data, *p, *base;
02462   ffi_abi abi;
02463   long ooff;
02464   GC_CAN_IGNORE ffi_type *rtype, **atypes;
02465   GC_CAN_IGNORE ffi_cif *cif;
02466   int i, nargs;
02467   MZ_REGISTER_STATIC(ffi_name_prefix);
02468   if (!ffi_name_prefix)
02469     ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
02470   if (!SCHEME_FFIANYPTRP(argv[0]))
02471     scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
02472   obj = SCHEME_FFIANYPTR_VAL(argv[0]);
02473   ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
02474   if ((obj == NULL) && (ooff == 0))
02475     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
02476   nargs = scheme_proper_list_length(itypes);
02477   if (nargs < 0)
02478     scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
02479   if (NULL == (base = get_ctype_base(otype)))
02480     scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
02481   rtype = CTYPE_PRIMTYPE(base);
02482   abi = GET_ABI(MYNAME,3);
02483   atypes = malloc(nargs * sizeof(ffi_type*));
02484   for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
02485     if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
02486       scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
02487     if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
02488       scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
02489     atypes[i] = CTYPE_PRIMTYPE(base);
02490   }
02491   cif = malloc(sizeof(ffi_cif));
02492   if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
02493     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
02494   data = scheme_make_vector(6, NULL);
02495   p = scheme_append_byte_string
02496         (ffi_name_prefix,
02497          scheme_make_byte_string_without_copying
02498            (SCHEME_FFIOBJP(argv[0]) ?
02499              ((ffi_obj_struct*)(argv[0]))->name : "proc"));
02500   SCHEME_VEC_ELS(data)[0] = p;
02501   SCHEME_VEC_ELS(data)[1] = obj;
02502   SCHEME_VEC_ELS(data)[2] = itypes;
02503   SCHEME_VEC_ELS(data)[3] = otype;
02504   SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
02505   SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
02506   scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
02507   return scheme_make_closed_prim_w_arity
02508            (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
02509             nargs, nargs);
02510 }
02511 #undef MYNAME
02512 
02513 /*****************************************************************************/
02514 /* Scheme callbacks */
02515 
02516 void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
02517 {
02518   ffi_callback_struct *data;
02519   Scheme_Object *argv_stack[MAX_QUICK_ARGS];
02520   int argc = cif->nargs, i;
02521   Scheme_Object **argv, *p, *v;
02522 #ifdef MZ_PRECISE_GC
02523   {
02524     void *tmp;
02525     tmp  = *((void**)userdata);
02526     data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp));
02527     if (data == NULL) scheme_signal_error("callback lost");
02528   }
02529 #else
02530   data = (ffi_callback_struct*)userdata;
02531 #endif
02532   if (argc <= MAX_QUICK_ARGS)
02533     argv = argv_stack;
02534   else
02535     argv = scheme_malloc(argc * sizeof(Scheme_Object*));
02536   if (data->call_in_scheduler)
02537     scheme_start_in_scheduler();
02538   for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
02539     v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
02540     argv[i] = v;
02541   }
02542   p = _scheme_apply(data->proc, argc, argv);
02543   SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
02544   if (data->call_in_scheduler)
02545     scheme_end_in_scheduler();
02546 }
02547 
02548 /* see ffi-callback below */
02549 typedef struct closure_and_cif_struct {
02550   ffi_closure          closure;
02551   ffi_cif              cif;
02552 #ifdef MZ_PRECISE_GC
02553   struct immobile_box *data;
02554 #else
02555   void                *data;
02556 #endif
02557 } closure_and_cif;
02558 /* free the above */
02559 void free_cl_cif_args(void *ignored, void *p)
02560 {
02561   /*
02562   scheme_warning("Releasing cl+cif+args %V %V (%d)",
02563                  ignored,
02564                  (((closure_and_cif*)p)->data),
02565                  SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
02566   */
02567 #ifdef MZ_PRECISE_GC
02568   GC_free_immobile_box((void**)(((closure_and_cif*)p)->data));
02569 #endif
02570   scheme_free_code(p);
02571 }
02572 
02573 /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
02574 /* the treatment of in-types and out-types is similar to that in ffi-call */
02575 /* the real work is done by ffi_do_callback above */
02576 #define MYNAME "ffi-callback"
02577 static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
02578 {
02579   ffi_callback_struct *data;
02580   Scheme_Object *itypes = argv[1];
02581   Scheme_Object *otype = argv[2];
02582   Scheme_Object *p, *base;
02583   ffi_abi abi;
02584   int nargs, i;
02585   /* ffi_closure objects are problematic when used with a moving GC.  The
02586    * problem is that memory that is GC-visible can move at any time.  The
02587    * solution is to use an immobile-box, which an immobile pointer (in a simple
02588    * malloced block), which points to the ffi_callback_struct that contains the
02589    * relevant Scheme call details.  Another minor complexity is that an
02590    * immobile box serves as a reference for the GC, which means that nothing
02591    * will ever get collected: and the solution for this is to stick a weak-box
02592    * in the chain.  Users need to be aware of GC issues, and need to keep a
02593    * reference to the callback object to avoid releasing the whole thing --
02594    * when that reference is lost, the ffi_callback_struct will be GCed, and a
02595    * finalizer will free() the malloced memory.  Everything on the malloced
02596    * part is allocated in one block, to make it easy to free.  The final layout
02597    * of the various objects is:
02598    *
02599    * <<======malloc======>> : <<===========scheme_malloc===============>>
02600    *                        :
02601    *    ffi_closure <------------------------\
02602    *      |  |              :                |
02603    *      |  |              :                |
02604    *      |  \--> immobile ----> weak        |
02605    *      |         box     :    box         |
02606    *      |                 :     |          |
02607    *      |                 :     |          |
02608    *      |                 :     \--> ffi_callback_struct
02609    *      |                 :               |  |
02610    *      V                 :               |  \-----> Scheme Closure
02611    *     cif ---> atypes    :               |
02612    *                        :               \--------> input/output types
02613    */
02614   GC_CAN_IGNORE ffi_type *rtype, **atypes;
02615   GC_CAN_IGNORE ffi_cif *cif;
02616   GC_CAN_IGNORE ffi_closure *cl;
02617   GC_CAN_IGNORE closure_and_cif *cl_cif_args;
02618   if (!SCHEME_PROCP(argv[0]))
02619     scheme_wrong_type(MYNAME, "procedure", 0, argc, argv);
02620   nargs = scheme_proper_list_length(itypes);
02621   if (nargs < 0)
02622     scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
02623   if (NULL == (base = get_ctype_base(otype)))
02624     scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
02625   rtype = CTYPE_PRIMTYPE(base);
02626   abi = GET_ABI(MYNAME,3);
02627   /* malloc space for everything needed, so a single free gets rid of this */
02628   cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
02629   cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
02630   cif = &(cl_cif_args->cif);
02631   atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));
02632   for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
02633     if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
02634       scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
02635     if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
02636       scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
02637     atypes[i] = CTYPE_PRIMTYPE(base);
02638   }
02639   if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
02640     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
02641   data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct));
02642   data->so.type = ffi_callback_tag;
02643   data->callback = (cl_cif_args);
02644   data->proc = (argv[0]);
02645   data->itypes = (argv[1]);
02646   data->otype = (argv[2]);
02647   data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
02648 # ifdef MZ_PRECISE_GC
02649   {
02650     /* put data in immobile, weak box */
02651     void **tmp;
02652     tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
02653     cl_cif_args->data = (struct immobile_box*)tmp;
02654   }
02655 # else /* MZ_PRECISE_GC undefined */
02656   cl_cif_args->data = (void*)data;
02657 # endif /* MZ_PRECISE_GC */
02658   if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data))
02659       != FFI_OK)
02660     scheme_signal_error
02661       ("internal error: ffi_prep_closure did not return FFI_OK");
02662   scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
02663   return (Scheme_Object*)data;
02664 }
02665 #undef MYNAME
02666 
02667 /*****************************************************************************/
02668 
02669 void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
02670 {
02671   char *str;
02672   if (!SCHEME_CTYPEP(ctype))
02673     scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
02674   if (CTYPE_PRIMP(ctype)) {
02675     scheme_print_bytes(pp, "#<ctype:", 0, 8);
02676     ctype = CTYPE_BASETYPE(ctype);
02677     if (SCHEME_SYMBOLP(ctype)) {
02678       str = SCHEME_SYM_VAL(ctype);
02679       scheme_print_bytes(pp, str, 0, strlen(str));
02680     } else {
02681       scheme_print_bytes(pp, "cstruct", 0, 7);
02682     }
02683     scheme_print_bytes(pp, ">", 0, 1);
02684   } else {
02685     scheme_print_bytes(pp, "#<ctype>", 0, 8);
02686   }
02687 }
02688 
02689 /*****************************************************************************/
02690 /* Initialization */
02691 
02692 /* types need to be initialized before places can spawn
02693  * types become entries in the GC mark and fixup tables
02694  * this function should initialize read-only globals that can be
02695  * shared without locking */
02696 void scheme_init_foreign_globals()
02697 {
02698   ffi_lib_tag = scheme_make_type("<ffi-lib>");
02699   ffi_obj_tag = scheme_make_type("<ffi-obj>");
02700   ctype_tag = scheme_make_type("<ctype>");
02701   ffi_callback_tag = scheme_make_type("<ffi-callback>");
02702 # ifdef MZ_PRECISE_GC
02703   GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0);
02704   GC_register_traversers(ffi_obj_tag, ffi_obj_SIZE, ffi_obj_MARK, ffi_obj_FIXUP, 1, 0);
02705   GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0);
02706   GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
02707 # endif /* MZ_PRECISE_GC */
02708   scheme_set_type_printer(ctype_tag, ctype_printer);
02709   MZ_REGISTER_STATIC(opened_libs);
02710   opened_libs = scheme_make_hash_table(SCHEME_hash_string);
02711   MZ_REGISTER_STATIC(default_sym);
02712   default_sym = scheme_intern_symbol("default");
02713   MZ_REGISTER_STATIC(stdcall_sym);
02714   stdcall_sym = scheme_intern_symbol("stdcall");
02715   MZ_REGISTER_STATIC(sysv_sym);
02716   sysv_sym = scheme_intern_symbol("sysv");
02717   MZ_REGISTER_STATIC(nonatomic_sym);
02718   nonatomic_sym = scheme_intern_symbol("nonatomic");
02719   MZ_REGISTER_STATIC(atomic_sym);
02720   atomic_sym = scheme_intern_symbol("atomic");
02721   MZ_REGISTER_STATIC(stubborn_sym);
02722   stubborn_sym = scheme_intern_symbol("stubborn");
02723   MZ_REGISTER_STATIC(uncollectable_sym);
02724   uncollectable_sym = scheme_intern_symbol("uncollectable");
02725   MZ_REGISTER_STATIC(eternal_sym);
02726   eternal_sym = scheme_intern_symbol("eternal");
02727   MZ_REGISTER_STATIC(interior_sym);
02728   interior_sym = scheme_intern_symbol("interior");
02729   MZ_REGISTER_STATIC(atomic_interior_sym);
02730   atomic_interior_sym = scheme_intern_symbol("atomic-interior");
02731   MZ_REGISTER_STATIC(raw_sym);
02732   raw_sym = scheme_intern_symbol("raw");
02733   MZ_REGISTER_STATIC(fail_ok_sym);
02734   fail_ok_sym = scheme_intern_symbol("fail-ok");
02735   MZ_REGISTER_STATIC(abs_sym);
02736   abs_sym = scheme_intern_symbol("abs");
02737 }
02738 
02739 void scheme_init_foreign(Scheme_Env *env)
02740 {
02741   Scheme_Env *menv;
02742   ctype_struct *t;
02743   Scheme_Object *s;
02744   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
02745   scheme_add_global("ffi-lib?",
02746     scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
02747   scheme_add_global("ffi-lib",
02748     scheme_make_prim_w_arity(foreign_ffi_lib, "ffi-lib", 1, 2), menv);
02749   scheme_add_global("ffi-lib-name",
02750     scheme_make_prim_w_arity(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv);
02751   scheme_add_global("ffi-obj?",
02752     scheme_make_prim_w_arity(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv);
02753   scheme_add_global("ffi-obj",
02754     scheme_make_prim_w_arity(foreign_ffi_obj, "ffi-obj", 2, 2), menv);
02755   scheme_add_global("ffi-obj-lib",
02756     scheme_make_prim_w_arity(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv);
02757   scheme_add_global("ffi-obj-name",
02758     scheme_make_prim_w_arity(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv);
02759   scheme_add_global("ctype?",
02760     scheme_make_prim_w_arity(foreign_ctype_p, "ctype?", 1, 1), menv);
02761   scheme_add_global("ctype-basetype",
02762     scheme_make_prim_w_arity(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv);
02763   scheme_add_global("ctype-scheme->c",
02764     scheme_make_prim_w_arity(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv);
02765   scheme_add_global("ctype-c->scheme",
02766     scheme_make_prim_w_arity(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv);
02767   scheme_add_global("make-ctype",
02768     scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
02769   scheme_add_global("make-cstruct-type",
02770     scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv);
02771   scheme_add_global("ffi-callback?",
02772     scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
02773   scheme_add_global("cpointer?",
02774     scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv);
02775   scheme_add_global("cpointer-tag",
02776     scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
02777   scheme_add_global("set-cpointer-tag!",
02778     scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
02779   scheme_add_global("ctype-sizeof",
02780     scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
02781   scheme_add_global("ctype-alignof",
02782     scheme_make_prim_w_arity(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv);
02783   scheme_add_global("compiler-sizeof",
02784     scheme_make_prim_w_arity(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
02785   scheme_add_global("malloc",
02786     scheme_make_prim_w_arity(foreign_malloc, "malloc", 1, 5), menv);
02787   scheme_add_global("end-stubborn-change",
02788     scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
02789   scheme_add_global("free",
02790     scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
02791   scheme_add_global("malloc-immobile-cell",
02792     scheme_make_prim_w_arity(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv);
02793   scheme_add_global("free-immobile-cell",
02794     scheme_make_prim_w_arity(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv);
02795   scheme_add_global("ptr-add",
02796     scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
02797   scheme_add_global("ptr-add!",
02798     scheme_make_prim_w_arity(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv);
02799   scheme_add_global("offset-ptr?",
02800     scheme_make_prim_w_arity(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv);
02801   scheme_add_global("ptr-offset",
02802     scheme_make_prim_w_arity(foreign_ptr_offset, "ptr-offset", 1, 1), menv);
02803   scheme_add_global("set-ptr-offset!",
02804     scheme_make_prim_w_arity(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv);
02805   scheme_add_global("memset",
02806     scheme_make_prim_w_arity(foreign_memset, "memset", 3, 5), menv);
02807   scheme_add_global("memmove",
02808     scheme_make_prim_w_arity(foreign_memmove, "memmove", 3, 6), menv);
02809   scheme_add_global("memcpy",
02810     scheme_make_prim_w_arity(foreign_memcpy, "memcpy", 3, 6), menv);
02811   scheme_add_global("ptr-ref",
02812     scheme_make_prim_w_arity(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
02813   scheme_add_global("ptr-set!",
02814     scheme_make_prim_w_arity(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
02815   scheme_add_global("ptr-equal?",
02816     scheme_make_prim_w_arity(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
02817   scheme_add_global("make-sized-byte-string",
02818     scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
02819   scheme_add_global("ffi-call",
02820     scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
02821   scheme_add_global("ffi-callback",
02822     scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
02823   s = scheme_intern_symbol("void");
02824   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02825   t->so.type = ctype_tag;
02826   t->basetype = (s);
02827   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
02828   t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
02829   scheme_add_global("_void", (Scheme_Object*)t, menv);
02830   s = scheme_intern_symbol("int8");
02831   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02832   t->so.type = ctype_tag;
02833   t->basetype = (s);
02834   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
02835   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
02836   scheme_add_global("_int8", (Scheme_Object*)t, menv);
02837   s = scheme_intern_symbol("uint8");
02838   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02839   t->so.type = ctype_tag;
02840   t->basetype = (s);
02841   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
02842   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
02843   scheme_add_global("_uint8", (Scheme_Object*)t, menv);
02844   s = scheme_intern_symbol("int16");
02845   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02846   t->so.type = ctype_tag;
02847   t->basetype = (s);
02848   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
02849   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
02850   scheme_add_global("_int16", (Scheme_Object*)t, menv);
02851   s = scheme_intern_symbol("uint16");
02852   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02853   t->so.type = ctype_tag;
02854   t->basetype = (s);
02855   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
02856   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
02857   scheme_add_global("_uint16", (Scheme_Object*)t, menv);
02858   s = scheme_intern_symbol("int32");
02859   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02860   t->so.type = ctype_tag;
02861   t->basetype = (s);
02862   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
02863   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
02864   scheme_add_global("_int32", (Scheme_Object*)t, menv);
02865   s = scheme_intern_symbol("uint32");
02866   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02867   t->so.type = ctype_tag;
02868   t->basetype = (s);
02869   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
02870   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
02871   scheme_add_global("_uint32", (Scheme_Object*)t, menv);
02872   s = scheme_intern_symbol("int64");
02873   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02874   t->so.type = ctype_tag;
02875   t->basetype = (s);
02876   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
02877   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
02878   scheme_add_global("_int64", (Scheme_Object*)t, menv);
02879   s = scheme_intern_symbol("uint64");
02880   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02881   t->so.type = ctype_tag;
02882   t->basetype = (s);
02883   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
02884   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
02885   scheme_add_global("_uint64", (Scheme_Object*)t, menv);
02886   s = scheme_intern_symbol("fixint");
02887   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02888   t->so.type = ctype_tag;
02889   t->basetype = (s);
02890   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
02891   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
02892   scheme_add_global("_fixint", (Scheme_Object*)t, menv);
02893   s = scheme_intern_symbol("ufixint");
02894   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02895   t->so.type = ctype_tag;
02896   t->basetype = (s);
02897   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
02898   t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
02899   scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
02900   s = scheme_intern_symbol("fixnum");
02901   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02902   t->so.type = ctype_tag;
02903   t->basetype = (s);
02904   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
02905   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
02906   scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
02907   s = scheme_intern_symbol("ufixnum");
02908   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02909   t->so.type = ctype_tag;
02910   t->basetype = (s);
02911   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
02912   t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
02913   scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
02914   s = scheme_intern_symbol("float");
02915   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02916   t->so.type = ctype_tag;
02917   t->basetype = (s);
02918   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
02919   t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
02920   scheme_add_global("_float", (Scheme_Object*)t, menv);
02921   s = scheme_intern_symbol("double");
02922   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02923   t->so.type = ctype_tag;
02924   t->basetype = (s);
02925   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
02926   t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
02927   scheme_add_global("_double", (Scheme_Object*)t, menv);
02928   s = scheme_intern_symbol("double*");
02929   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02930   t->so.type = ctype_tag;
02931   t->basetype = (s);
02932   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
02933   t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
02934   scheme_add_global("_double*", (Scheme_Object*)t, menv);
02935   s = scheme_intern_symbol("bool");
02936   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02937   t->so.type = ctype_tag;
02938   t->basetype = (s);
02939   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
02940   t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
02941   scheme_add_global("_bool", (Scheme_Object*)t, menv);
02942   s = scheme_intern_symbol("string/ucs-4");
02943   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02944   t->so.type = ctype_tag;
02945   t->basetype = (s);
02946   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02947   t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
02948   scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
02949   s = scheme_intern_symbol("string/utf-16");
02950   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02951   t->so.type = ctype_tag;
02952   t->basetype = (s);
02953   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02954   t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
02955   scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
02956   s = scheme_intern_symbol("bytes");
02957   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02958   t->so.type = ctype_tag;
02959   t->basetype = (s);
02960   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02961   t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
02962   scheme_add_global("_bytes", (Scheme_Object*)t, menv);
02963   s = scheme_intern_symbol("path");
02964   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02965   t->so.type = ctype_tag;
02966   t->basetype = (s);
02967   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02968   t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
02969   scheme_add_global("_path", (Scheme_Object*)t, menv);
02970   s = scheme_intern_symbol("symbol");
02971   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02972   t->so.type = ctype_tag;
02973   t->basetype = (s);
02974   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02975   t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
02976   scheme_add_global("_symbol", (Scheme_Object*)t, menv);
02977   s = scheme_intern_symbol("pointer");
02978   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02979   t->so.type = ctype_tag;
02980   t->basetype = (s);
02981   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02982   t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
02983   scheme_add_global("_pointer", (Scheme_Object*)t, menv);
02984   s = scheme_intern_symbol("scheme");
02985   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02986   t->so.type = ctype_tag;
02987   t->basetype = (s);
02988   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02989   t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
02990   scheme_add_global("_scheme", (Scheme_Object*)t, menv);
02991   s = scheme_intern_symbol("fpointer");
02992   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
02993   t->so.type = ctype_tag;
02994   t->basetype = (s);
02995   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
02996   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
02997   scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
02998   scheme_finish_primitive_module(menv);
02999   scheme_protect_primitive_provide(menv, NULL);
03000 }
03001 
03002 /*****************************************************************************/