#!/bin/sh #| -*- C -*- exec racket "$0" > `echo "$0" | sed 's/rktc$/c/'` "$0" |# #lang scribble/text @(require "rktc-utils.ss") @header{foreign.rktc} #include "schpriv.h" #include @@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{ # include # if SIZEOF_CHAR == 1 typedef signed char Tsint8; typedef unsigned char Tuint8; # else # error "configuration error, please contact PLT (int8)" # endif # if SIZEOF_SHORT == 2 typedef signed short Tsint16; typedef unsigned short Tuint16; # elif SIZEOF_INT == 2 typedef signed int Tsint16; typedef unsigned int Tuint16; # else # error "configuration error, please contact PLT (int16)" # endif # if SIZEOF_INT == 4 typedef signed int Tsint32; typedef unsigned int Tuint32; # elif SIZEOF_LONG == 4 typedef signed long Tsint32; typedef unsigned long Tuint32; # else # error "configuration error, please contact PLT (int32)" # endif # if SIZEOF_LONG == 8 typedef signed long Tsint64; typedef unsigned long Tuint64; # elif SIZEOF_LONG_LONG == 8 typedef signed long long Tsint64; typedef unsigned long long Tuint64; # else # error "configuration error, please contact PLT (int64)" # endif }{ # include # ifndef __CYGWIN32__ # include typedef _int8 Tsint8; typedef unsigned _int8 Tuint8; typedef _int16 Tsint16; typedef unsigned _int16 Tuint16; typedef _int32 Tsint32; typedef unsigned _int32 Tuint32; typedef _int64 Tsint64; typedef unsigned _int64 Tuint64; # endif } #include "ffi.h" #ifndef MZ_PRECISE_GC # define XFORM_OK_PLUS + # define GC_CAN_IGNORE /* empty */ #endif #define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta)) /* same as the macro in file.c */ #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x)) static void save_errno_values(int kind); /*****************************************************************************/ /* Defining EnumProcessModules for openning `self' as an ffi-lib */ /* We'd like to use EnumProcessModules to find all loaded DLLs, but it's only available in NT 4.0 and later. The alternative, Module32{First,Next}, is available *except* for NT 4.0! So we try EnumProcessModules first. */ @@IFDEF{WINDOWS_DYNAMIC_LOAD}{ #ifdef MZ_PRECISE_GC START_XFORM_SKIP; #endif int epm_tried = 0; typedef BOOL (WINAPI *EnumProcessModules_t)(HANDLE hProcess, HMODULE* lphModule, DWORD cb, LPDWORD lpcbNeeded); EnumProcessModules_t _EnumProcessModules; #include BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule, DWORD cb, LPDWORD lpcbNeeded) { if (!epm_tried) { HMODULE hm; hm = LoadLibrary("psapi.dll"); if (hm) { _EnumProcessModules = (EnumProcessModules_t)GetProcAddress(hm, "EnumProcessModules"); } epm_tried = 1; } if (_EnumProcessModules) return _EnumProcessModules(hProcess, lphModule, cb, lpcbNeeded); else { HANDLE snapshot; MODULEENTRY32 mod; int i, ok; snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); if (snapshot == INVALID_HANDLE_VALUE) return FALSE; for (i = 0; 1; i++) { mod.dwSize = sizeof(mod); if (!i) ok = Module32First(snapshot, &mod); else ok = Module32Next(snapshot, &mod); if (!ok) break; if (cb >= sizeof(HMODULE)) { lphModule[i] = mod.hModule; cb -= sizeof(HMODULE); } } CloseHandle(snapshot); *lpcbNeeded = i * sizeof(HMODULE); return GetLastError() == ERROR_NO_MORE_FILES; } } #ifdef MZ_PRECISE_GC END_XFORM_SKIP; #endif } /*****************************************************************************/ /* Library objects */ @cdefstruct[ffi-lib [handle "void*"] [name "Scheme_Object*"] [objects "Scheme_Hash_Table*"]] THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs); /* (ffi-lib filename no-error?) -> ffi-lib */ @cdefine[ffi-lib 1 2]{ char *name; Scheme_Object *path, *hashname; void *handle; int null_ok = 0; ffi_lib_struct *lib; if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0]))) scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv); /* leave the filename as given, the system will look for it */ /* (`#f' means open the executable) */ path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]); name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path); hashname = (Scheme_Object*)((name==NULL) ? "" : name); lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname); if (!lib) { Scheme_Hash_Table *ht; @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ if (name==NULL) { /* openning the executable is marked by a NULL handle */ handle = NULL; null_ok = 1; } else handle = LoadLibrary(name); }{ handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL); } if (handle == NULL && !null_ok) { if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false; else { @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ long err; err = GetLastError(); scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, MYNAME": couldn't open %V (%E)", argv[0], err); }{ scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, MYNAME": couldn't open %V (%s)", argv[0], dlerror()); } } } ht = scheme_make_hash_table(SCHEME_hash_string); @cmake["lib" ffi-lib "handle" "argv[0]" "ht"] scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib); /* no dlclose finalizer - since the hash table always keeps a reference */ /* maybe add some explicit unload at some point */ } return (Scheme_Object*)lib; } /* (ffi-lib-name ffi-lib) -> string */ @cdefine[ffi-lib-name 1]{ if (!SCHEME_FFILIBP(argv[0])) scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv); return ((ffi_lib_struct*)argv[0])->name; } /*****************************************************************************/ /* Pull pointers (mostly functions) out of ffi-lib objects */ @cdefstruct[ffi-obj [obj "void*"] [name "char*"] [lib "ffi_lib_struct*"]] /* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */ @cdefine[ffi-obj 2]{ ffi_obj_struct *obj; void *dlobj; ffi_lib_struct *lib = NULL; char *dlname; if (SCHEME_FFILIBP(argv[1])) lib = (ffi_lib_struct*)argv[1]; else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1])) lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1])); else scheme_wrong_type(MYNAME, "ffi-lib", 1, argc, argv); if (!SCHEME_BYTE_STRINGP(argv[0])) scheme_wrong_type(MYNAME, "bytes", 0, argc, argv); dlname = SCHEME_BYTE_STR_VAL(argv[0]); obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname); if (!obj) { @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ if (lib->handle) { dlobj = GetProcAddress(lib->handle, dlname); } else { /* this is for the executable-open case, which was marked by a NULL * handle, deal with it by searching all current modules */ @DEFINE{NUM_QUICK_MODS 16} HMODULE *mods, me, quick_mods[NUM_QUICK_MODS]; DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i; me = GetCurrentProcess(); mods = quick_mods; if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) { if (actual_cnt > cnt) { cnt = actual_cnt; mods = (HMODULE *)scheme_malloc_atomic(cnt); if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt)) mods = NULL; } else cnt = actual_cnt; } else mods = NULL; if (mods) { cnt /= sizeof(HMODULE); for (i = 0; i < cnt; i++) { dlobj = GetProcAddress(mods[i], dlname); if (dlobj) break; } } else dlobj = NULL; } if (!dlobj) { long err; err = GetLastError(); scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, MYNAME": couldn't get \"%s\" from %V (%E)", dlname, lib->name, err); } }{ dlobj = dlsym(lib->handle, dlname); if (!dlobj) { const char *err; err = dlerror(); if (err != NULL) scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, MYNAME": couldn't get \"%s\" from %V (%s)", dlname, lib->name, err); } } @cmake["obj" ffi-obj "dlobj" "dlname" "lib"] scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj); } return (obj == NULL) ? scheme_false : (Scheme_Object*)obj; } /* (ffi-obj-lib ffi-obj) -> ffi-lib */ @cdefine[ffi-obj-lib 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib); } /* (ffi-obj-name ffi-obj) -> string */ @cdefine[ffi-obj-name 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name); } /*****************************************************************************/ /* Type helpers */ /* These are not defined in Racket because: * - SCHEME_UINT_VAL is not really a simple accessor like other SCHEME_X_VALs * - scheme_make_integer_from_unsigned behaves the same as the signed version */ #define SCHEME_UINT_VAL(obj) ((unsigned)(SCHEME_INT_VAL(obj))) #define scheme_make_integer_from_unsigned(i) \ ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1)) @@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ /* longs and ints are really the same */ #define scheme_get_realint_val(x,y) \ scheme_get_int_val(x,(long*)(y)) #define scheme_get_unsigned_realint_val(x,y) \ scheme_get_unsigned_int_val(x,(unsigned long*)(y)) #define scheme_make_realinteger_value \ scheme_make_integer_value #define scheme_make_realinteger_value_from_unsigned \ scheme_make_integer_value_from_unsigned }{ /* These will make sense in Racket when longs are longer than ints (needed * for libffi's int32 types). There is no need to deal with bignums because * mzscheme's fixnums are longs. */ inline int scheme_get_realint_val(Scheme_Object *o, int *v) { if (SCHEME_INTP(o)) { unsigned long lv = SCHEME_INT_VAL(o); int i = (int)lv; if (i != lv) return 0; *v = i; return 1; } else return 0; } inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) { if (SCHEME_INTP(o)) { unsigned long lv = SCHEME_INT_VAL(o); unsigned int i = (unsigned int)lv; if (i != lv) return 0; *v = i; return 1; } else return 0; } #define scheme_make_realinteger_value(ri) \ scheme_make_integer((long)(ri)) #define scheme_make_realinteger_value_from_unsigned(ri) \ scheme_make_integer((unsigned long)(ri)) } /* This is related to the section of scheme.h that defines mzlonglong. */ #ifndef INT64_AS_LONG_LONG #ifdef NO_LONG_LONG_TYPE #ifndef SIXTY_FOUR_BIT_INTEGERS #error foreign requires a 64-bit integer type type. #endif #endif #endif #define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o)) static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs) { if (SCHEME_FALSEP(ucs)) return NULL; return SCHEME_CHAR_STR_VAL(ucs); } static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) { long ulen; unsigned short *res; res = scheme_ucs4_to_utf16 (SCHEME_CHAR_STR_VAL(ucs), 0, 1+SCHEME_CHAR_STRLEN_VAL(ucs), NULL, -1, &ulen, 0); return res; } static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs) { if (SCHEME_FALSEP(ucs)) return NULL; return ucs4_string_to_utf16_pointer(ucs); } Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) { long ulen; mzchar *res; int end; if (!utf) return scheme_false; for (end=0; utf[end] != 0; end++) { /**/ } res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0); return scheme_make_sized_char_string(res, ulen, 0); } /*****************************************************************************/ /* Types */ @(begin ;; Types are defined with the `defctype' function. This looks like: ;; (defctype 'type-name ;; 'prop1 val1 ;; 'prop2 val2 ;; ...) ;; The current properties are: ;; stype: scheme binding for this type ;; cname: like stype but used for C identifiers ;; ftype: type name used by libffi (as ffi_type_X) (defaults to cname) ;; ctype: C type, or #f if none (defaults to ftype, with proper massaging) ;; macro: if specified as "X", use "SCHEME_XP" and "SCHEME_X_VAL" as the ;; defaults for the next two properties ;; pred: name of predicate macro ;; (or a function of the value and an ForeignAny obj pointer name, which ;; produces an expression that tests the value and sets the ForeignAny obj ;; accordingly.) ;; s->c: name of value extraction macro ;; (or #f which means that the predicate already sets the value, or a ;; function with the same arguments as above) ;; c->s: name of value construction macro/function ;; (or a function of the value that generates the expression) ;; offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset ;; value for s->c, otherwise leave 0 as the offset (define types null) (require (for-syntax scheme/base)) (define (get-prop type prop) (cadr (assq prop (cdr (assq type types))))) (define type-counter (let ([c 0]) (lambda ([flag #f]) (case flag [(#f) (set! c (add1 c)) c] [(last) (begin0 (add1 c) (set! c #f))] [else (error "internal error")])))) (define (describe-type stype cname ftype ctype pred s->c c->s offset) @list{ #define FOREIGN_@cname (@(type-counter)) /* Type Name: @|stype|@(and (not (equal? cname stype)) @list{ (@cname)}) * LibFfi type: ffi_type_@ftype * C type: @(or ctype "-none-") * Predicate: @(cond [(not pred) "-none-"] [(procedure? pred) (pred "" "aux")] [else @list{@|pred|()}]) * Scheme->C: @(cond [(not s->c) (if pred "-none- (set by the predicate)" "-none-")] [(procedure? s->c) (s->c "" "aux")] [else @list{@|s->c|()}]) * S->C offset: @(or offset 0) * C->Scheme: @(cond [(not c->s) "-none-"] [(procedure? c->s) (c->s "")] [else @list{@|c->s|()}]) */}) (define (make-ctype type args) (define (prop p . default) (let loop ([args args]) (cond [(null? args) (and (pair? default) (car default))] [(eq? p (car args)) (if (and (pair? (cadr args)) (eq? (caadr args) 'from)) (get-prop (cadadr args) p) (cadr args))] [else (loop (cddr args))]))) (let* ([stype (symbol->string type)] [cname (scheme-id->c-name stype)] [ftype (prop 'ftype cname)] [ctype (prop 'ctype (regexp-replace #rx"^sint" (regexp-replace #rx"^(u?int(?:[0-9]+))$" ftype "\\1_t") "int"))] [ftype (regexp-replace #rx"^(int|char|long)" ftype "s\\1")] [macro (prop 'macro)] [pred (prop 'pred (and macro @list{SCHEME_@|macro|P}))] [s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))] [c->s (prop 'c->s)] [offset (prop 'offset #f)]) (output (describe-type stype cname ftype ctype pred s->c c->s offset)) `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) (define (defctype name . args) (set! types (append types (list (make-ctype name args))))) (define-syntax (map-types stx) (syntax-case stx () [(_ body ...) (let () (define (id sym) (datum->syntax stx sym stx)) (define-values (exprs semi?) (syntax-case stx () [(_ #:semicolons? s? body ...) (values #'(body ...) #'s?)] [(_ body ...) (values #'(body ...) #'#t)])) (with-syntax ([(body ...) exprs] [semi? semi?] [stype (id 'stype)] [cname (id 'cname)] [ctype (id 'ctype)] [ftype (id 'ftype)] [macro (id 'macro)] [pred (id 'pred)] [s->c (id 's->c)] [c->s (id 'c->s)] [offset (id 'offset)] [ptr? (id 'ptr?)]) #'(maplines #:semicolons? 'semi? (lambda (t) (define data (cdr t)) (define (get sym) (cadr (assq sym data))) (let* ([stype (get 'stype)] [cname (get 'cname)] [ftype (get 'ftype)] [ctype (get 'ctype)] [macro (get 'macro)] [pred (get 'pred)] [s->c (get 's->c)] [c->s (get 'c->s)] [offset (get 'offset)] [ptr? (or (equal? "pointer" ftype) (equal? "gcpointer" ftype))]) body ...)) types)))])) (define (defctype* name/+ftype ctype pred s->c c->s) (let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)] [ftype (and (pair? name/+ftype) (cadr name/+ftype))]) (apply defctype name `(ctype ,ctype ,@(if ftype `(ftype ,ftype) `()) pred ,(if (string? pred) @list{SCHEME_@|pred|P} pred) s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL} s->c) c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s))))) ) /*********************************************************************** * The following are the only primitive types. * The tricky part is figuring out what width-ed types correspond to * what internal types. Matthew says: * Racket expects to be compiled such that sizeof(int) == 4, * sizeof(long) == sizeof(void*), sizeof(short) >= 2, * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8. * So, on a 64-bit OS, Racket expects only `long' to change. **********************************************************************/ /* returns # when used as output type, not for input types. */ @(defctype 'void 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) @; libffi primitive types @; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ @(defctype* 'int8 "Tsint8" "INT" "INT" "integer") @(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") @(defctype* 'int16 "Tsint16" "INT" "INT" "integer") @(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") /* Treats integers properly: */ @(defctype* 'int32 "Tsint32" (lambda (x aux) @list{scheme_get_realint_val(@x,&@aux)}) #f "realinteger_value") /* Treats integers properly: */ @(defctype* 'uint32 "Tuint32" (lambda (x aux) @list{scheme_get_unsigned_realint_val(@x,&@aux)}) #f "realinteger_value_from_unsigned") @; mzlonglong is always assumed to be 64 bits, or the above will throw an error @(defctype* 'int64 "Tsint64" (lambda (x aux) @list{scheme_get_long_long_val(@x,&@aux)}) #f "integer_value_from_long_long") @(defctype* 'uint64 "Tuint64" (lambda (x aux) @list{scheme_get_unsigned_long_long_val(@x,&@aux)}) #f "integer_value_from_unsigned_long_long") /* This is like int32, but always assumes fixnum: */ @(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer") /* This is like uint32, but always assumes fixnum: */ @(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned") /* This is what mzscheme defines as long: */ @@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ #define ffi_type_smzlong ffi_type_sint32 #define ffi_type_umzlong ffi_type_uint32 }{ #define ffi_type_smzlong ffi_type_sint64 #define ffi_type_umzlong ffi_type_uint64 } @;{ implemented in Scheme /* This is what mzscheme defines as long: */ (defctype* '(long "smzlong") "long" (lambda (x aux) list{scheme_get_int_val(@x,&@aux)}) #f "integer_value") @line{/* This is what mzscheme defines as ulong: */} (defctype* '(ulong "umzlong") "unsigned long" (lambda (x aux) @list{scheme_get_unsigned_int_val(@x,&@aux)}) #f "integer_value_from_unsigned") ;}@; @; /* This is what mzscheme defines as long, assuming fixnums: */ @(defctype* '(fixnum "smzlong") "long" "INT" "INT" "integer") /* This is what mzscheme defines as ulong, assuming fixnums: */ @(defctype* '(ufixnum "umzlong") "unsigned long" "INT" "UINT" "integer_from_unsigned") @(defctype* 'float "float" "FLT" "FLT" "float") @(defctype* 'double "double" "DBL" "DBL" "double") @; @; Not useful? not implemented in any case. @; (defctype* 'longdouble "long double" ...???...) /* A double that will coerce numbers to doubles: */ @(defctype* '(double* "double") "double" ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping "REAL" '("scheme_real_to_double") "double") /* Booleans -- implemented as an int which is 1 or 0: */ @(defctype 'bool 'ftype "int" 'pred (lambda (x aux) "1") 's->c "SCHEME_TRUEP" 'c->s (lambda (x) @list{(@|x|?scheme_true:scheme_false)})) /* Strings -- no copying is done (when possible). * #f is not NULL only for byte-strings, for other strings it is * meaningless to use NULL. */ @(defctype 'string/ucs-4 'ftype "pointer" 'ctype "mzchar*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_ucs4_pointer" 'c->s "scheme_make_char_string_without_copying") @(defctype 'string/utf-16 'ftype "pointer" 'ctype "unsigned short*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_utf16_pointer" 'c->s "utf16_pointer_to_ucs4_string") /* Byte strings -- not copying C strings, #f is NULL. * (note: these are not like char* which is just a pointer) */ @(defctype 'bytes 'ftype "pointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) 's->c (lambda (x aux) @list{SCHEME_FALSEP(@x)?NULL:SCHEME_BYTE_STR_VAL(@x)}) 'c->s (lambda (x) @list{(@|x|==NULL)?scheme_false:@; scheme_make_byte_string_without_copying(@x)})) @(defctype 'path 'ftype "pointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) 's->c (lambda (x aux) @list{SCHEME_FALSEP(@x)?NULL:SCHEME_PATH_VAL(TO_PATH(@x))}) 'c->s (lambda (x) @list{(@|x|==NULL)?scheme_false:@; scheme_make_path_without_copying(@x)})) @(defctype 'symbol 'ftype "pointer" 'ctype "char*" 'pred "SCHEME_SYMBOLP" 's->c "SCHEME_SYM_VAL" 'c->s "scheme_intern_symbol") /* This is for any C pointer: #f is NULL, cpointer values as well as * ffi-obj and string values pass their pointer. When used as a return * value, either a cpointer object or #f is returned. */ @(defctype 'pointer 'ctype "void*" 'macro "FFIANYPTR" 'offset "FFIANYPTR" 'c->s "scheme_make_foreign_external_cpointer") @(defctype 'gcpointer 'ftype "gcpointer" 'ctype "void*" 'macro "FFIANYPTR" 'offset "FFIANYPTR" 'c->s "scheme_make_foreign_cpointer") @; This is probably not needed @; /* Used for ffi-callback objects: */ @; @(defctype 'callback @; 'ftype "pointer" @; 'ctype "void*" @; 'macro "FFICALLBACK" @; 's->c (lambda (x aux) @list{((ffi_callback_struct*)(@x))->callback}) @; 'c->s (lambda (x) x)) @; /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like Racket's. */ @(defctype 'scheme 'ftype "gcpointer" 'ctype "Scheme_Object*" 'pred (lambda (x aux) "1") 's->c (lambda (x aux) x) 'c->s (lambda (x) x)) /* Special type, not actually used for anything except to mark values * that are treated like pointers but not referenced. Used for * creating function types. */ @(defctype 'fpointer 'ftype "pointer" 'ctype "void*") typedef union _ForeignAny { @(map-types (when ctype @list{@ctype x_@cname})) } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ @; last makes sure this is the last one value that gets used #define FOREIGN_struct (@(type-counter 'last)) /*****************************************************************************/ /* Type objects */ /* This struct is used for both user types and primitive types (including * struct types). If it is a user type then basetype will be another ctype, * otherwise, * - if it's a primitive type, then basetype will be a symbol naming that type * - if it's a struct, then basetype will be the list of ctypes that * made this struct * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an * integer (a label value) for non-struct type. (Note that the * integer is not really needed, since it is possible to identify the * type by the basetype field.) */ @cdefstruct[ctype [basetype "Scheme_Object*"] [scheme_to_c "Scheme_Object*"] [c_to_scheme "Scheme_Object*"]] static ffi_type ffi_type_gcpointer; #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) #define CTYPE_PRIMP(x) (!CTYPE_USERP(x)) #define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c)) #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme)) #define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c) #define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme) /* Returns #f for primitive types. */ @cdefine[ctype-basetype 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return CTYPE_BASETYPE(argv[0]); } @cdefine[ctype-scheme->c 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : ((ctype_struct*)(argv[0]))->scheme_to_c; } @cdefine[ctype-c->scheme 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : ((ctype_struct*)(argv[0]))->c_to_scheme; } /* Returns a primitive type, or NULL if not a type */ static Scheme_Object *get_ctype_base(Scheme_Object *type) { if (!SCHEME_CTYPEP(type)) return NULL; while (CTYPE_USERP(type)) { type = CTYPE_BASETYPE(type); } return type; } /* Returns the size, 0 for void, -1 if no such type */ static int ctype_sizeof(Scheme_Object *type) { type = get_ctype_base(type); if (type == NULL) return -1; switch (CTYPE_PRIMLABEL(type)) { @(map-types @list{case FOREIGN_@|cname|: @; return @(if ctype @list{sizeof(@ctype)} "0")}) /* for structs */ default: return CTYPE_PRIMTYPE(type)->size; } } /* (make-ctype basetype scheme->c c->scheme) -> ctype */ /* The scheme->c can throw type errors to check for valid arguments */ /* a #f means no conversion function, if both are #f -- then just return the */ /* basetype. */ @cdefine[make-ctype 3]{ ctype_struct *type; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2]))) scheme_wrong_type(MYNAME, "procedure-or-false", 2, argc, argv); else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2])) return argv[0]; else { @cmake["type" ctype "argv[0]" "argv[1]" "argv[2]"] return (Scheme_Object*)type; } @hush } /* see below */ void free_libffi_type(void *ignored, void *p) { free(((ffi_type*)p)->elements); free(p); } /*****************************************************************************/ /* ABI spec */ @defsymbols[default stdcall sysv] ffi_abi sym_to_abi(char *who, Scheme_Object *sym) { if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) return FFI_DEFAULT_ABI; else if (SAME_OBJ(sym, sysv_sym)) { #ifdef WINDOWS_DYNAMIC_LOAD return FFI_SYSV; #else scheme_signal_error("%s: ABI not implemented: %V", who, sym); #endif } else if (SAME_OBJ(sym, stdcall_sym)) { #ifdef WINDOWS_DYNAMIC_LOAD return FFI_STDCALL; #else scheme_signal_error("%s: ABI not implemented: %V", who, sym); #endif } else { scheme_signal_error("%s: unknown ABI: %V", who, sym); } return 0; /* hush the compiler */ } /* helper macro */ #define GET_ABI(name,n) \ ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI) /*****************************************************************************/ /* cstruct types */ /* (make-cstruct-type types [abi]) -> ctype */ /* This creates a new primitive type that is a struct. This type can be used * with cpointer objects, except that the contents is used rather than the * pointer value. Marshaling to lists or whatever should be done in Scheme. */ @cdefine[make-cstruct-type 1 2]{ Scheme_Object *p, *base; /* since ffi_type objects can be used in callbacks, they are allocated using * malloc so they don't move, and they are freed when the Scheme object is * GCed. */ GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy; ctype_struct *type; ffi_cif cif; int i, nargs; ffi_abi abi; nargs = scheme_proper_list_length(argv[0]); if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv); abi = GET_ABI(MYNAME,1); /* allocate the type elements */ elements = malloc((nargs+1) * sizeof(ffi_type*)); elements[nargs] = NULL; for (i=0, p=argv[0]; isize = 0; libffi_type->alignment = 0; libffi_type->type = FFI_TYPE_STRUCT; libffi_type->elements = elements; /* use ffi_prep_cif to set the size and alignment information */ dummy = &libffi_type; if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); @cmake["type" ctype "argv[0]" "(Scheme_Object*)libffi_type" "(Scheme_Object*)FOREIGN_struct"] scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); return (Scheme_Object*)type; } /*****************************************************************************/ /* Callback type */ @cdefstruct[ffi-callback [callback "void*"] [proc "Scheme_Object*"] [itypes "Scheme_Object*"] [otype "Scheme_Object*"] [call_in_scheduler "char"]] /*****************************************************************************/ /* Pointer objects */ /* use cpointer (with a NULL tag when creating), #f for NULL */ #define SCHEME_FFIANYPTRP(x) \ (SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \ SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x)) #define SCHEME_FFIANYPTR_VAL(x) \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ (SCHEME_FALSEP(x) ? NULL : \ (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \ NULL))))) #define SCHEME_FFIANYPTR_OFFSET(x) \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) #define SCHEME_FFIANYPTR_OFFSETVAL(x) \ W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) #define SCHEME_CPOINTER_W_OFFSET_P(x) \ SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) @cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } @cdefine[cpointer-tag 1]{ Scheme_Object *tag = NULL; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]); return (tag == NULL) ? scheme_false : tag; } @cdefine[set-cpointer-tag! 2]{ if (!SCHEME_CPTRP(argv[0])) scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv); SCHEME_CPTR_TYPE(argv[0]) = argv[1]; return scheme_void; } /*****************************************************************************/ /* Scheme<-->C conversions */ /* On big endian machines we need to know whether we're pulling a value from an * argument location where it always takes a whole word or straight from a * memory location -- deal with it via a C2SCHEME macro wrapper that is used * for both the function definition and calls */ #ifdef SCHEME_BIG_ENDIAN #define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { @(map-types @list{case FOREIGN_@|cname|: return @; @(if ctype (let ([x (list "REF_CTYPE("ctype")")]) (if (procedure? c->s) (c->s x) (list c->s"("x")"))) "scheme_void")}) case FOREIGN_struct: return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); } @hush } #undef REF_CTYPE /* On big endian machines we need to know whether we're pulling a value from an * argument location where it always takes a whole word or straight from a * memory location -- deal with it as above, via a SCHEME2C macro wrapper that * is used for both the function definition and calls, but the actual code in * the function is different: in the relevant cases zero an int and offset the * ptr */ /* Usually writes the C object to dst and returns NULL. When basetype_p is not * NULL, then any pointer value (any pointer or a struct) is returned, and the * basetype_p is set to the corrsponding number tag. If basetype_p is NULL, * then a struct value will be *copied* into dst. */ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, Scheme_Object *val, long *basetype_p, long *_offset, int ret_loc) { if (!SCHEME_CTYPEP(type)) scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type); while (CTYPE_USERP(type)) { if (!SCHEME_FALSEP(CTYPE_USER_S2C(type))) val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val)); type = CTYPE_BASETYPE(type); } if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { /* No need for the SET_CTYPE trick for pointers. */ if (SCHEME_FFICALLBACKP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback; else if (SCHEME_CPTRP(val)) ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val); else if (SCHEME_FFIOBJP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj; else if (SCHEME_FALSEP(val)) ((void**)W_OFFSET(dst,delta))[0] = NULL; else /* ((void**)W_OFFSET(dst,delta))[0] = val; */ scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { @(map-types #:semicolons? #f (define (wrong-type obj type) @list{scheme_wrong_type("Scheme->C","@type",0,1,&(@obj))}) @list{ case FOREIGN_@|cname|: @(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})] [f (lambda (p) (if (procedure? p) @p["val" x] @list{@|p|(val)}))]) (cond [(not x) @list{if (!ret_loc) @wrong-type["type" "non-void-C-type"]; break; }] [(not s->c) @list{if (!(@(if ptr? "ret_loc" (pred "val" x)))) @; @wrong-type["val" stype]; @(if ptr? "break" "return NULL");}] [else @list{ @@IFDEF{SCHEME_BIG_ENDIAN}{ if (sizeof(@ctype)c]); @and[offset @list{ toff = SCHEME_@|offset|_OFFSET(val); if (_offset) *_offset = toff;@; @"\n" }]@; @(if ptr? @list{if (basetype_p == NULL || @; @(if offset @list{(tmp == NULL && toff == 0)} @list{tmp == NULL})) { @x = @(if offset @list{(_offset ? tmp : @; (@ctype)W_OFFSET(tmp, toff))} "tmp"); return NULL; } else { *basetype_p = FOREIGN_@cname; return @(if offset @list{_offset ? tmp : @; (@ctype)W_OFFSET(tmp, toff)} "tmp"); }} @list{@x = tmp@";" return NULL@";"}) } else { @wrong-type["val" stype]; @hush }}]))}) case FOREIGN_struct: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val); { void* p = SCHEME_FFIANYPTR_VAL(val); long poff = SCHEME_FFIANYPTR_OFFSET(val); if (basetype_p == NULL) { if (p == NULL && poff == 0) scheme_signal_error("FFI pointer value was NULL"); memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff), CTYPE_PRIMTYPE(type)->size); return NULL; } else { *basetype_p = FOREIGN_struct; if (_offset) { *_offset = poff; return p; } else { return W_OFFSET(p, poff); } } } default: scheme_signal_error("corrupt foreign type: %V", type); } return NULL; /* hush the compiler */ } #undef SET_CTYPE /*****************************************************************************/ /* C type information */ /* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */ @cdefine[ctype-sizeof 1]{ int size; size = ctype_sizeof(argv[0]); if (size >= 0) return scheme_make_integer(size); else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); return NULL; /* hush the compiler */ } /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */ @cdefine[ctype-alignof 1]{ Scheme_Object *type; type = get_ctype_base(argv[0]); if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment); return NULL; /* hush the compiler */ } /* (compiler-sizeof symbols) -> int, where symbols name some C type. * The symbols are in 'int 'char 'void 'short 'long '*, order does not matter, * when a single symbol is used, a list is not needed. * (This is about actual C types, not C type objects.) */ @cdefine[compiler-sizeof 1]{ int res=0; int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */ int intsize = 0; /* "short" => decrement, "long" => increment */ int stars = 0; /* number of "*"s */ Scheme_Object *l = argv[0], *p; while (!SAME_OBJ(l, scheme_null)) { if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); } else { p = l; l = scheme_null; } if (!SCHEME_SYMBOLP(p)) { scheme_wrong_type(MYNAME, "list of symbols", 0, argc, argv); } else if (!strcmp(SCHEME_SYM_VAL(p),"int")) { if (basetype==0) basetype=1; else scheme_signal_error(MYNAME": extraneous type: %V", p); } else if (!strcmp(SCHEME_SYM_VAL(p),"char")) { if (basetype==0) basetype=2; else scheme_signal_error(MYNAME": extraneous type: %V", p); } else if (!strcmp(SCHEME_SYM_VAL(p),"void")) { if (basetype==0) basetype=3; else scheme_signal_error(MYNAME": extraneous type: %V", p); } else if (!strcmp(SCHEME_SYM_VAL(p),"float")) { if (basetype==0) basetype=4; else scheme_signal_error(MYNAME": extraneous type: %V", p); } else if (!strcmp(SCHEME_SYM_VAL(p),"double")) { if (basetype==0 || basetype==4) basetype=5; else scheme_signal_error(MYNAME": extraneous type: %V", p); } else if (!strcmp(SCHEME_SYM_VAL(p),"short")) { if (intsize>0) scheme_signal_error(MYNAME": cannot use both 'short and 'long"); else intsize--; } else if (!strcmp(SCHEME_SYM_VAL(p),"long")) { if (intsize<0) scheme_signal_error(MYNAME": cannot use both 'short and 'long"); else intsize++; } else if (!strcmp(SCHEME_SYM_VAL(p),"*")) { stars++; } else { scheme_wrong_type(MYNAME, "list of C type symbols", 0, argc, argv); } } if (stars > 1) scheme_signal_error(MYNAME": cannot handle more than one '*"); if (intsize < -1) scheme_signal_error(MYNAME": cannot handle more than one 'short"); if (intsize > 2) scheme_signal_error(MYNAME": cannot handle more than two 'long"); if (basetype == 0) basetype = 1; /* int is the default type */ /* don't assume anything, so it can be used to verify compiler assumptions */ /* (only forbid stuff that the compiler doesn't allow) */ @@DEFINE{RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))} switch (basetype) { case 1: /* int */ switch (intsize) { case 0: RETSIZE(int); break; case 1: RETSIZE(long int); break; @@@IFDEF{INT64_AS_LONG_LONG}{ case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */ }{ case 2: RETSIZE(long long int); break; } case -1: RETSIZE(short int); break; } break; case 2: /* char */ if (intsize==0) RETSIZE(char); else scheme_signal_error(MYNAME": cannot qualify 'char"); break; case 3: /* void */ if (intsize==0 && stars>0) RETSIZE(int); /* avoid sizeof(void) */ else if (stars==0) scheme_signal_error(MYNAME": cannot use 'void without a '*"); else scheme_signal_error(MYNAME": cannot qualify 'void"); break; case 4: /* float */ if (intsize==0) RETSIZE(float); else scheme_signal_error(MYNAME": bad qualifiers for 'float"); break; case 5: /* double */ if (intsize==0) RETSIZE(double); else if (intsize==1) RETSIZE(long double); else scheme_signal_error(MYNAME": bad qualifiers for 'double"); break; default: scheme_signal_error(MYNAME": internal error (unexpected type %d)", basetype); } @UNDEF{RETSIZE} return scheme_make_integer(res); } /*****************************************************************************/ /* Pointer type user functions */ @defsymbols[nonatomic atomic stubborn uncollectable eternal interior atomic-interior raw fail-ok] /* (malloc num type cpointer mode) -> pointer */ /* The arguments for this function are: * - num: bytes to allocate, or the number of instances of type when given, * - type: malloc the size of this type (or num instances of it), * - cpointer: a source pointer to copy contents from, * - mode: a symbol for different allocation functions to use - one of * 'nonatomic, 'atomic, 'stubborn, 'uncollectable, 'eternal, 'raw (the last * one is for using the real malloc) * - if an additional 'fail-ok flag is given, then scheme_malloc_fail_ok is * used with the chosen malloc function * The arguments can be specified in any order at all since they are all * different types, the only requirement is for a size, either a number of * bytes or a type. If no mode is specified, then scheme_malloc will be used * when the type is any pointer, otherwise scheme_malloc_atomic is used. */ @cdefine[malloc 1 5]{ int i, size=0, num=0, failok=0; void *from = NULL, *res = NULL; long foff = 0; Scheme_Object *mode = NULL, *a, *base = NULL; void *(*mf)(size_t); for (i=0; i 2) { if (SCHEME_CTYPEP(argv[2])) { long size; size = ctype_sizeof(argv[2]); if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv); noff = noff * size; } else scheme_wrong_type(who, "C-type", 2, argc, argv); } if (is_bang) { ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff; return scheme_void; } else { if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1)) return scheme_make_offset_external_cptr (SCHEME_FFIANYPTR_VAL(argv[0]), SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); else return scheme_make_offset_cptr (SCHEME_FFIANYPTR_VAL(argv[0]), SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff, (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL); } } /* (ptr-add cptr offset-k [type]) */ @cdefine[ptr-add 2 3]{return do_ptr_add(MYNAME, 0, argc, argv);} /* (ptr-add! cptr offset-k [type]) */ @cdefine[ptr-add! 2 3]{return do_ptr_add(MYNAME, 1, argc, argv);} /* (offset-ptr? x) */ /* Returns #t if the argument is a cpointer with an offset */ @cdefine[offset-ptr? 1 1]{ return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false; } /* (ptr-offset ptr) */ /* Returns the offset of a cpointer (0 if it's not an offset pointer) */ @cdefine[ptr-offset 1 1]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0])); } /* (set-ptr-offset! ptr offset [type]) */ /* Sets the offset of an offset-cpointer (possibly multiplied by the size of * the given ctype) */ @cdefine[set-ptr-offset! 2 3]{ long noff; if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0])) scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv); if (!scheme_get_int_val(argv[1], &noff)) { scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv); } if (argc > 2) { if (SCHEME_CTYPEP(argv[2])) { long size; if (NULL == get_ctype_base(argv[2])) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); size = ctype_sizeof(argv[2]); if (size <= 0) scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv); noff = noff * size; } else scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); } ((Scheme_Offset_Cptr*)(argv[0]))->offset = noff; return scheme_void; } /* (mem{move,cpy} dest-ptr [dest-offset] src-ptr [src-offset] count [ctype]) * Copies count * sizeof(ctype) bytes * from src-ptr + src-offset * sizeof(ctype) * to dest-ptr + dest-offset * sizeof(ctype). * --or-- * (memset dest-ptr [dest-offset] byte count [ctype]) * Sets count * sizeof(ctype) bytes to byte * at dest-ptr + dest-offset * sizeof(ctype) */ static Scheme_Object *do_memop(const char *who, int mode, int argc, Scheme_Object **argv) /* mode 0=>memset, 1=>memmove, 2=>memcpy */ { void *src = NULL, *dest = NULL; long soff = 0, doff = 0, count, v, mult = 0; int i, j, ch = 0, argc1 = argc; /* arg parsing: last optional ctype, then count, then fill byte for memset, * then the first and second pointer+offset pair. */ /* get the optional last ctype multiplier */ if (SCHEME_CTYPEP(argv[argc1-1])) { argc1--; mult = ctype_sizeof(argv[argc1]); if (mult <= 0) scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv); } /* get the count argument */ argc1--; if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0)) scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, argc1, argc, argv); if (mult) count *= mult; /* get the fill byte for memset */ if (!mode) { argc1--; ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1; if ((ch < 0) || (ch > 255)) scheme_wrong_type(who, "byte", argc1, argc, argv); } /* get the two pointers + offsets */ i = 0; for (j=0; j<2; j++) { if (!mode && j==1) break; /* memset needs only a dest argument */ if (!(icpointer 1]{ if (!SCHEME_VECTORP(argv[0])) scheme_wrong_type(MYNAME, "vector", 0, argc, argv); return scheme_make_offset_cptr(argv[0], (long)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL); } @cdefine[flvector->cpointer 1]{ if (!SCHEME_FLVECTORP(argv[0])) scheme_wrong_type(MYNAME, "flvector", 0, argc, argv); return scheme_make_offset_cptr(argv[0], (long)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL); } @cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);} @cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);} @cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);} @defsymbols[abs] /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset */ /* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; long delta; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); size = ctype_sizeof(base); if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { if (SCHEME_FFIOBJP(argv[0])) { /* The ffiobj pointer is the function pointer. */ ptr = argv[0]; delta = (long)&(((ffi_obj_struct*)0x0)->obj); } } if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); } if (argc > 3) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); if (!SCHEME_INTP(argv[3])) scheme_wrong_type(MYNAME, "integer", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); if (!size) scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } return C2SCHEME(argv[1], ptr, delta, 0); } /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset */ /* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-set! 3 5]{ int size=0; void *ptr; long delta; Scheme_Object *val = argv[argc-1], *base; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); size = ctype_sizeof(base); if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); } if (argc > 4) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "'abs", 2, argc, argv); if (!SCHEME_INTP(argv[3])) scheme_wrong_type(MYNAME, "integer", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); if (!size) scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0); return scheme_void; } /* (ptr-equal? cpointer cpointer) -> boolean */ @cdefine[ptr-equal? 2 2]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); if (!SCHEME_FFIANYPTRP(argv[1])) scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv); return (SAME_OBJ(argv[0],argv[1]) || (SCHEME_FFIANYPTR_OFFSETVAL(argv[0]) == SCHEME_FFIANYPTR_OFFSETVAL(argv[1]))) ? scheme_true : scheme_false; } /* (make-sized-byte-string cpointer len) */ @cdefine[make-sized-byte-string 2 2]{ /* Warning: no copying is done so it is possible to share string contents. */ /* Warning: if source ptr has a offset, resulting string object uses shifted * pointer. * (Should use real byte-strings with new version.) */ long len; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); if (!scheme_get_int_val(argv[1],&len)) scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv); if (SCHEME_FALSEP(argv[0])) return scheme_false; else return scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]), len, 0); } /* *** Calling Scheme code while the GC is working leads to subtle bugs, so *** this is implemented now in Scheme using will executors. */ /* internal: apply Scheme finalizer */ void do_scm_finalizer(void *p, void *finalizer) { Scheme_Object *f = (Scheme_Object*)finalizer; if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(void*)(&p)); } void do_ptr_finalizer(void *p, void *finalizer) { Scheme_Object *f = (Scheme_Object*)finalizer; Scheme_Object *ptr; if (p == NULL) return; ptr = scheme_make_cptr(p,NULL); if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(&ptr)); /* don't leave dangling references! */ SCHEME_CPTR_VAL(ptr) = NULL; ptr = NULL; } /* (register-finalizer ptrobj finalizer ['pointer]) -> old-finalizer */ /* The finalizer is called by the primitive finalizer mechanism, make sure */ /* no references to the object are recreated. #f means erase existing */ /* finalizer if any.*/ /* If no 'pointer argument is given, this is can be used with any Scheme */ /* object, and the finalizer will be called with it. If an additional */ /* 'pointer argument of 'pointer is given, the object must be a cpointer */ /* object, the finalizer will be invoked when the pointer itself is */ /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ /* @add-prefix[" * "]{ defsymbols[pointer] cdefine[register-finalizer 2 3]{ void *ptr, *old = NULL; int ptrsym = (argc == 3 && argv[2] == pointer_sym); if (ptrsym) { if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); if (ptr == NULL) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); } else { if (argc == 3) scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); ptr = argv[0]; } if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); scheme_register_finalizer (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), argv[1], NULL, &old); return (old == NULL) ? scheme_false : (Scheme_Object*)old; }} */ /*****************************************************************************/ /* Calling foreign function objects */ #define MAX_QUICK_ARGS 16 typedef void(*VoidFun)(); Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* data := {name, c-function, itypes, otype, cif} */ { /* The name is not currently used */ /* char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); */ void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]); Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2]; Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); int nargs = cif->nargs; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we * need another array (avalues) for the pointers to these values (this is * what libffi actually uses). To make things more fun, ForeignAny is * problematic for the precise GC, since it is sometimes a pointer and * sometime not. To deal with this, while converting argv objects into * ivals, scheme_to_c will save pointer values in avalues, so the GC can, * ignore ivals -- just before we reach the actual call, avalues is * overwritten, but from that point on it is all C code so there is no * problem. Hopefully. * (Things get complicated if the C call can involve GC (usually due to a * Scheme callback), but then the programmer need to arrange for pointers * that cannot move. Because of all this, the *only* array that should not * be ignored by the GC is avalues.) */ GC_CAN_IGNORE ForeignAny *ivals, oval; void **avalues, *p, *newp, *tmp; GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS]; void *stack_avalues[MAX_QUICK_ARGS]; long stack_offsets[MAX_QUICK_ARGS]; int i; long basetype, offset, *offsets; if (nargs <= MAX_QUICK_ARGS) { ivals = stack_ivals; avalues = stack_avalues; offsets = stack_offsets; } else { ivals = malloc(nargs * sizeof(ForeignAny)); avalues = scheme_malloc(nargs * sizeof(void*)); offsets = scheme_malloc_atomic(nargs * sizeof(long)); } /* iterate on input values and types */ for (i=0; isize); newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size); } else { p = &oval; newp = NULL; } /* We finished with all possible mallocs, clear up the avalues and offsets * mess */ for (i=0; isize); free(p); p = newp; break; default: /* not sure why this code is here, looks fine to remove this case */ if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) { tmp = ((void**)p)[0]; p = &tmp; } break; } return C2SCHEME(otype, p, 0, 1); } /* see below */ void free_fficall_data(void *ignored, void *p) { free(((ffi_cif*)p)->arg_types); free(p); } /* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ @cdefine[ffi-call 3 5]{ static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; ffi_abi abi; long ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; int i, nargs, save_errno; MZ_REGISTER_STATIC(ffi_name_prefix); if (!ffi_name_prefix) ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); obj = SCHEME_FFIANYPTR_VAL(argv[0]); ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]); if ((obj == NULL) && (ooff == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 1, argc, argv); if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); if (argc > 4) { save_errno = -1; if (SCHEME_FALSEP(argv[4])) save_errno = 0; else if (SCHEME_SYMBOLP(argv[4]) && !SCHEME_SYM_WEIRDP(argv[4])) { if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) save_errno = 1; else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) save_errno = 2; } if (save_errno == -1) { scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); } } else save_errno = 0; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; iname : "proc")); SCHEME_VEC_ELS(data)[0] = p; SCHEME_VEC_ELS(data)[1] = obj; SCHEME_VEC_ELS(data)[2] = itypes; SCHEME_VEC_ELS(data)[3] = otype; SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif; SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff); SCHEME_VEC_ELS(data)[6] = scheme_make_integer(save_errno); scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL); return scheme_make_closed_prim_w_arity (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p), nargs, nargs); } /*****************************************************************************/ /* Scheme callbacks */ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) { ffi_callback_struct *data; Scheme_Object *argv_stack[MAX_QUICK_ARGS]; int argc = cif->nargs, i; Scheme_Object **argv, *p, *v; #ifdef MZ_PRECISE_GC { void *tmp; tmp = *((void**)userdata); data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp)); if (data == NULL) scheme_signal_error("callback lost"); } #else data = (ffi_callback_struct*)userdata; #endif if (argc <= MAX_QUICK_ARGS) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); if (data->call_in_scheduler) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); if (data->call_in_scheduler) scheme_end_in_scheduler(); } /* see ffi-callback below */ typedef struct closure_and_cif_struct { ffi_closure closure; ffi_cif cif; #ifdef MZ_PRECISE_GC struct immobile_box *data; #else void *data; #endif } closure_and_cif; /* free the above */ void free_cl_cif_args(void *ignored, void *p) { /* scheme_warning("Releasing cl+cif+args %V %V (%d)", ignored, (((closure_and_cif*)p)->data), SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); */ #ifdef MZ_PRECISE_GC GC_free_immobile_box((void**)(((closure_and_cif*)p)->data)); #endif scheme_free_code(p); } /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @cdefine[ffi-callback 3 5]{ ffi_callback_struct *data; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *p, *base; ffi_abi abi; int nargs, i; /* ffi_closure objects are problematic when used with a moving GC. The * problem is that memory that is GC-visible can move at any time. The * solution is to use an immobile-box, which an immobile pointer (in a simple * malloced block), which points to the ffi_callback_struct that contains the * relevant Scheme call details. Another minor complexity is that an * immobile box serves as a reference for the GC, which means that nothing * will ever get collected: and the solution for this is to stick a weak-box * in the chain. Users need to be aware of GC issues, and need to keep a * reference to the callback object to avoid releasing the whole thing -- * when that reference is lost, the ffi_callback_struct will be GCed, and a * finalizer will free() the malloced memory. Everything on the malloced * part is allocated in one block, to make it easy to free. The final layout * of the various objects is: * * <<======malloc======>> : <<===========scheme_malloc===============>> * : * ffi_closure <------------------------\ * | | : | * | | : | * | \--> immobile ----> weak | * | box : box | * | : | | * | : | | * | : \--> ffi_callback_struct * | : | | * V : | \-----> Scheme Closure * cif ---> atypes : | * : \--------> input/output types */ GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; GC_CAN_IGNORE ffi_closure *cl; GC_CAN_IGNORE closure_and_cif *cl_cif_args; if (!SCHEME_PROCP(argv[0])) scheme_wrong_type(MYNAME, "procedure", 0, argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 1, argc, argv); if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); /* malloc space for everything needed, so a single free gets rid of this */ cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ cif = &(cl_cif_args->cif); atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); for (i=0, p=itypes; i 4) && SCHEME_TRUEP(argv[4]))"] @@@IFDEF{MZ_PRECISE_GC}{ { /* put data in immobile, weak box */ void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0)); cl_cif_args->data = (struct immobile_box*)tmp; } }{ cl_cif_args->data = (void*)data; } if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } /*****************************************************************************/ static void save_errno_values(int kind) { Scheme_Thread *p = scheme_current_thread; if (kind == 2) { long v = 0; @@IFDEF{WINDOWS_DYNAMIC_LOAD}{ v = GetLastError(); } p->saved_errno = v; return; } p->saved_errno = errno; } @cdefine[saved-errno 0]{ Scheme_Thread *p = scheme_current_thread; return scheme_make_integer_value(p->saved_errno); } @cdefine[lookup-errno 1]{ Scheme_Object *v = argv[0]; @(let* ([errnos '(EINTR EEXIST EAGAIN)] [syms (let loop ([errnos errnos]) (if (null? (cdr errnos)) (format "or '~a" (car errnos)) (format "'~a, ~a" (car errnos) (loop (cdr errnos)))))]) @list{ if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) { @(add-newlines (for/list ([e errnos]) @string-append{ if (!strcmp("@symbol->string[e]", SCHEME_SYM_VAL(v))) return scheme_make_integer(@symbol->string[e]); })) } scheme_wrong_type(MYNAME, "@syms",0, argc, argv); return NULL; }) } /*****************************************************************************/ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp) { char *str; if (!SCHEME_CTYPEP(ctype)) scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype); if (CTYPE_PRIMP(ctype)) { scheme_print_bytes(pp, "#", 0, 1); } else { scheme_print_bytes(pp, "#", 0, 8); } } /*****************************************************************************/ /* Initialization */ /* types need to be initialized before places can spawn * types become entries in the GC mark and fixup tables * this function should initialize read-only globals that can be * shared without locking */ void scheme_init_foreign_globals() { @(maplines (lambda (x) @list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}) (reverse (cstructs))) @@IFDEF{MZ_PRECISE_GC}{ @(maplines (lambda (x) @list{GC_register_traversers(@(cadr x)_tag, @(cadr x)_SIZE, @; @(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)}) (reverse (cstructs))) } scheme_set_type_printer(ctype_tag, ctype_printer); @(maplines (lambda (sym) @list{MZ_REGISTER_STATIC(@(cadr sym)); @(cadr sym) = scheme_intern_symbol("@(car sym)")}) (reverse (symbols))) } void scheme_init_foreign_places() { MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); } void scheme_init_foreign(Scheme_Env *env) { Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); @(maplines (lambda (x) (define-values (sname cfun min max) (apply values x)) @list{scheme_add_global("@sname", scheme_make_prim_w_arity(@cfun, "@sname", @min, @max), menv)}) (reverse (cfunctions))) @(map-types ;; no need for these, at least for now: ;; MZ_REGISTER_STATIC(@|cname|_sym); ;; @|cname|_sym = scheme_intern_symbol("@stype"); @list{s = scheme_intern_symbol("@stype"); @cmake["t" ctype "s" @list{(Scheme_Object*)(void*)(&ffi_type_@ftype)} @list{(Scheme_Object*)FOREIGN_@cname}] scheme_add_global("_@stype", (Scheme_Object*)t, menv)}) scheme_finish_primitive_module(menv); scheme_protect_primitive_provide(menv, NULL); } /*****************************************************************************/