#!/bin/sh
#|
exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
|#
---begin
<<{:<<>>:}>>
/********************************************
 ** Do not edit this file!
 ** This file is generated from {:current-file:},
 ** to make changes, edit that file and
 ** run it to generate an updated version
 ** of this file.
 ********************************************/

{:(load "ssc-utils.ss"):}

#include "schpriv.h"

#ifndef WINDOWS_DYNAMIC_LOAD

# include <dlfcn.h>

# 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

#else

# include <windows.h>
# ifndef __CYGWIN32__
#  include <wtypes.h>
   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

#endif

#include "ffi.h"

#ifndef MZ_PRECISE_GC
# define XFORM_OK_PLUS +
# define GC_CAN_IGNORE /* empty */
#endif

/* same as the macro in file.c */
#define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))

/*****************************************************************************/
/* 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 <tlhelp32.h>

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
#endif

/*****************************************************************************/
/* Library objects */

{:(cdefstruct ffi-lib
    (handle  "void*")
    (name    "Scheme_Object*")
    (objects "Scheme_Hash_Table*")):}

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);
#else
    handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL);
#endif
    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);
#else
        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                         MYNAME": couldn't open %V (%s)", argv[0], dlerror());
#endif
      }
    }
    ht = scheme_make_hash_table(SCHEME_hash_string);
    {:(cmake-object "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);
    }
#else
    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);
    }
#endif
    {:(cmake-object "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 MzScheme 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

#else /* SIXTY_FOUR_BIT_INTEGERS defined */

/* These will make sense in MzScheme 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)) { *v = (int)(SCHEME_INT_VAL(o)); return 1; }
  else return 0;
}
inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
{
  if (SCHEME_INTP(o)) {
    int i = (int)(SCHEME_INT_VAL(o));
    if (i < 0) 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))

#endif /* SIXTY_FOUR_BIT_INTEGERS */

/* 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

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;
}

Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
  long ulen;
  mzchar *res;
  int end;
  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 */

{:
;; 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)

(define types '())

(define (get-prop type prop)
  (cadr (assq prop (cdr (assq type types)))))

(define *type-counter* 0)

(define (describe-type stype cname ftype ctype pred s->c c->s)
  (set! *type-counter* (add1 *type-counter*))
  (~ "#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 "<Scheme>" "aux")]
                             [else (list pred"(<Scheme>)")]) \\
     " * Scheme->C:   "(cond
                        [(not s->c)
                         (if pred "-none- (set by the predicate)" "-none-")]
                        [(procedure? s->c) (s->c "<Scheme>" "aux")]
                        [else (list s->c"(<Scheme>)")]) \\
     " * C->Scheme:   "(cond [(not c->s) "-none-"]
                             [(procedure? c->s) (c->s "<C>")]
                             [else (list c->s"(<C>)")]) \\
     " */" \\))

(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)])
    (describe-type stype cname ftype ctype pred s->c c->s)
    `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
      (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s))))

(define (defctype name . args)
  (set! types (append! types (list (make-ctype name args)))))

(define-syntax (for-each-type stx)
  (syntax-case stx ()
    [(_ body ...)
     (let ([id (lambda (sym) (datum->syntax-object (syntax _) sym))])
       (with-syntax ([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)]
                     [ptr?  (id 'ptr?)])
         #'(for-each
            (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)]
                     [ptr?  (equal? "pointer" 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:" \\
   " *   MzScheme 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, MzScheme expects only `long' to change." \\
   " **********************************************************************/"\\
   )

(~ "/* returns #<void> 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" \\
   "#else" \\
   "#define ffi_type_smzlong ffi_type_sint64" \\
   "#define ffi_type_umzlong ffi_type_uint64" \\
   "#endif" \\)

#| 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")
(~ "/* 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_CHAR_STRINGP"
  's->c  "SCHEME_CHAR_STR_VAL"
  'c->s  "scheme_make_char_string_without_copying")

(defctype 'string/utf-16
  'ftype "pointer"
  'ctype "unsigned short*"
  'pred  "SCHEME_CHAR_STRINGP"
  's->c  "ucs4_string_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"
  '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 MzScheme's. */")
(defctype 'scheme
  'ftype "pointer"
  '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 #f)

:}
typedef union _ForeignAny {
  {:(for-each-type (when ctype (~ ctype" x_"cname";"))):}
} ForeignAny;

{: (set! *type-counter* (add1 *type-counter*))
   (~ "/* This is a tag that is used to identify user-made struct types. */" \\
      "#define FOREIGN_struct ("*type-counter*")")
   (set! *type-counter* #f) ; make sure this is the last one defined
:}

/*****************************************************************************/
/* Type objects */

/* This struct is used for both user types and primitive types (including
 * struct types).  If it is a primitive type then basetype will be NULL, and
 * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
 * integer (a label value) for non-struct type. */
{:(cdefstruct ctype
    (basetype    "Scheme_Object*")
    (scheme_to_c "Scheme_Object*")
    (c_to_scheme "Scheme_Object*")):}

#define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x)     (NULL == (CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x)     (!(CTYPE_PRIMP(x)))
#define CTYPE_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):}
{
  Scheme_Object *base;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
  base = CTYPE_BASETYPE(argv[0]);
  if (NULL == base) return scheme_false;
  else              return base;
}

{:(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)) {
  {:(for-each-type
      (~ "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-object "type" ctype "argv[0]" "argv[1]" "argv[2]"):}
    return (Scheme_Object*)type;
  }
  return NULL; /* shush the compiler */
}

/* see below */
void free_libffi_type(void *ignored, void *p)
{
  free(((ffi_type*)p)->elements);
  free(p);
}

/* (make-cstruct-type types) -> 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):}
{
  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;
  nargs = scheme_proper_list_length(argv[0]);
  if (nargs < 0)
    scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
  /* allocate the type elements */
  elements = malloc((nargs+1) * sizeof(ffi_type*));
  elements[nargs] = NULL;
  for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 0, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
    elements[i] = CTYPE_PRIMTYPE(base);
  }
  /* allocate the new libffi type object */
  libffi_type = malloc(sizeof(ffi_type));
  libffi_type->size      = 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, FFI_DEFAULT_ABI, 1, &ffi_type_void, dummy) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  {:(cmake-object "type" ctype "NULL"
                  "(Scheme_Object*)libffi_type"
                  "(Scheme_Object*)FOREIGN_struct"):}
  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
  return (Scheme_Object*)type;
}

/*****************************************************************************/
/* 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))
#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) : \
         NULL)))

#define scheme_make_foreign_cpointer(x) \
  ((x==NULL)?scheme_false:scheme_make_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;
}

/*****************************************************************************/
/* Callback type */

{:(cdefstruct ffi-callback
    (callback "void*")
    (proc     "Scheme_Object*")
    (itypes   "Scheme_Object*")
    (otype    "Scheme_Object*")):}

/*****************************************************************************/
/* 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)<sizeof(int)) && args_loc) \
  ? ((ctype)(((int*)W_OFFSET(src,delta))[0])) : (((ctype *)W_OFFSET(src,delta))[0]))
#else
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))

static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
{
  Scheme_Object *res, *base;
  if (!SCHEME_CTYPEP(type))
    scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
  base = CTYPE_BASETYPE(type);
  if (base != NULL) {
    res = C2SCHEME(base, src, delta, args_loc);
    if (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) {
    /* No need for the REF_CTYPE trick for pointers */
    return (Scheme_Object*)W_OFFSET(src, delta);
  } else switch (CTYPE_PRIMLABEL(type)) {
    {:(for-each-type
        (~ "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);
  }
  return NULL; /* shush the compiler */
}
#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 */
#ifdef SCHEME_BIG_ENDIAN
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
#else
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
#endif

/* 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,
                      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 /* ((void**)W_OFFSET(dst,delta))[0] = val; */
         scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
  } else switch (CTYPE_PRIMLABEL(type)) {
    {:(for-each-type
        (define (wrong-type obj type)
          (list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));"))
        (~ "case FOREIGN_"cname":")
        (if ctype
          (let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")]
                 [f (lambda (p)
                      (if (procedure? p) (p "val" x) (list p"(val)")))])
            (if s->c
              (begin
                (display "#ifdef SCHEME_BIG_ENDIAN\n")
                (~ "  if (sizeof("ctype")<sizeof(int) && ret_loc) {" \\
                   "    ((int*)W_OFFSET(dst,delta))[0] = 0;" \\
                   "    delta += (sizeof(int)-sizeof("ctype"));"
                   \\
                   "  }")
                (display "#endif\n")
                (~ "  if ("(f pred)") {" \\
                   "    "ctype" tmp;" \\
                   "    tmp = ("ctype")("(f s->c)");")
                (if ptr?
                  (~ "    if (basetype_p == NULL || tmp == NULL) {" \\
                     "      "x" = tmp; return NULL;" \\
                     "    } else {" \\
                     "      *basetype_p = FOREIGN_"cname"; return tmp;" \\
                     "    }")
                  (~ "    "x" = tmp; return NULL;"))
                (~ "  } else {" \\
                   "    "(wrong-type "val" stype) \\
                   "    return NULL; /* shush the compiler */" \\
                   "  }"))
              (if ptr?
                (error 'scheme->c "unhandled pointer type: ~s" ctype)
                (~ "  if (!("(pred "val" x)")) "(wrong-type "val" stype) \\
                   "  return NULL;"))))
          (~ "  "(wrong-type "type" "non-void-C-type")))):}
    case FOREIGN_struct:
      if (!SCHEME_FFIANYPTRP(val))
        scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
      if (basetype_p == NULL) {
        void* p = SCHEME_FFIANYPTR_VAL(val);
        if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
        memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
        return NULL;
      } else {
        *basetype_p = FOREIGN_struct;
        return SCHEME_FFIANYPTR_VAL(val);
      }
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  return NULL; /* shush 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; /* shush 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; /* shush 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 */
#else
    case 2:  RETSIZE(long long int); break;
#endif
    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) RETSIZE(void);
    else scheme_signal_error(MYNAME": cannot qualify 'char");
    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 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;
  Scheme_Object *mode = NULL, *a, *base = NULL;
  void *(*mf)(size_t);
  for (i=0; i<argc; i++) {
    a = argv[i];
    if (SCHEME_INTP(a)) {
      if (num != 0)
        scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
      num = SCHEME_INT_VAL(a);
      if (num <= 0)
        scheme_wrong_type(MYNAME, "positive-integer", 0, argc, argv);
    } else if (SCHEME_CTYPEP(a)) {
      if (size != 0)
        scheme_signal_error(MYNAME": specifying a second type: %V", a);
      if (NULL == (base = get_ctype_base(a)))
        scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
      size = ctype_sizeof(a);
      if (size <= 0)
        scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
    } else if (SAME_OBJ(a, fail_ok_sym)) {
      failok = 1;
    } else if (SCHEME_SYMBOLP(a)) {
      if (mode != NULL)
        scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
      mode = a;
    } else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
      if (from != NULL)
        scheme_signal_error(MYNAME": specifying a second source pointer: %V",
                            a);
      from = SCHEME_FFIANYPTR_VAL(a);
    } else {
      scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
    }
  }
  if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
  size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
  if (mode == NULL)
    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
      ? scheme_malloc : scheme_malloc_atomic;
  else if (SAME_OBJ(mode, nonatomic_sym))     mf = scheme_malloc;
  else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
  else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
  else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
  else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
  else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
  else {
    scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
    return NULL; /* shush the compiler */
  }
  if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
  if ((from != NULL) && (res != NULL)) memcpy(res, from, size);
  return scheme_make_foreign_cpointer(res);
}

/* (end-stubborn-change ptr) */
{:(cdefine end-stubborn-change 1):}
{
  void *ptr;
  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);
  scheme_end_stubborn_change(ptr);
  return scheme_void;
}

/* (free ptr) */
/* This is useful for raw-malloced objects, including objects from C libraries
 * that the library is mallocing itself. */
{:(cdefine free 1):}
{
  void *ptr;
  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);
  free(ptr);
  return scheme_void;
}

{:(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 = 0;

  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);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
  else size = ctype_sizeof(base);
  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
    if (argc > 2)
      scheme_signal_error
        (MYNAME": referencing fpointer with extra arguments");
    else
      ptr = argv[0];
  } else 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);
  } else 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);
    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 = 0;
  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]);
  if (ptr == NULL)
    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);
  else size = ctype_sizeof(base);
  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
    if (argc > 3) {
      scheme_signal_error
        (MYNAME": setting fpointer value with extra arguments");
    } else if (SCHEME_CPTRP(argv[0])) {
      ptr = SCHEME_CPTR_VAL(argv[0]);
    } else if SCHEME_FFIOBJP(argv[0]) {
      ptr = ((ffi_obj_struct*)(argv[0]))->obj;
    } else {
      scheme_signal_error
        (MYNAME": bad lvalue (NULL or string)");
    }
  } else 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);
  } else if (argc > 4) {
    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 > 3) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
    delta = (size * SCHEME_INT_VAL(argv[2]));
  }
  SCHEME2C(argv[1], ptr, delta, val, 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_VAL(argv[0]) == SCHEME_FFIANYPTR_VAL(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. */
/* (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_VAL(argv[0]), len, 0);
}

/* 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.) */
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so */
/* *** this is implemented now in Scheme using will executors. */
/*
{:#;(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

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]);
  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];
  int i;
  long basetype;
  if (nargs <= MAX_QUICK_ARGS) {
    ivals   = stack_ivals;
    avalues = stack_avalues;
  } else {
    ivals   = malloc(nargs * sizeof(ForeignAny));
    avalues = scheme_malloc(nargs * sizeof(void*));
  }
  /* iterate on input values and types */
  for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
    /* convert argv[i] according to current itype */
    p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
    if (p != NULL) {
      avalues[i] = p;
      ivals[i].x_fixnum = basetype; /* remember the base type */
    } else {
      avalues[i] = NULL;
    }
  }
  base = get_ctype_base(otype); /* verified below, so cannot be NULL */
  /* If this is a struct return value, then need to malloc in any case, even if
   * the size is smaller than ForeignAny, because this value will be
   * returned. */
  if (CTYPE_PRIMLABEL(base) == FOREIGN_struct) {
    /* need to have p be a pointer that is invisible to the GC */
    p = malloc(CTYPE_PRIMTYPE(base)->size);
    newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
  } else {
    p = &oval;
    newp = NULL;
  }
  /* We finished with all possible mallocs, clear up the avalues mess */
  for (i=0; i<nargs; i++) {
    if (avalues[i] == NULL)     /* if this was a non-pointer... */
      avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
    else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
      /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
      ivals[i].x_pointer = avalues[i];
      avalues[i] = &(ivals[i]);
    }
    /* Otherwise it was a struct pointer, and avalues[i] is already fine */
  }
  /* Finally, call the function */
  ffi_call(cif, c_func, p, avalues);
  if (ivals != stack_ivals) free(ivals);
  ivals = NULL; /* no need now to hold on to this */
  for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
  avalues = NULL;
  switch (CTYPE_PRIMLABEL(base)) {
  case FOREIGN_fpointer: /* need to allocate a pointer */
    p = scheme_make_foreign_cpointer(oval.x_pointer);
    break;
  case FOREIGN_struct:
    memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
    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) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
{:(cdefine ffi-call 3 3):}
{
  static Scheme_Object *ffi_name_prefix = NULL;
  Scheme_Object *itypes = argv[1];
  Scheme_Object *otype  = argv[2];
  Scheme_Object *obj, *data, *p, *base;
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  int i, nargs;
  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]);
  if (obj == NULL)
    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);
  atypes = malloc(nargs * sizeof(ffi_type*));
  for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
    atypes[i] = CTYPE_PRIMTYPE(base);
  }
  cif = malloc(sizeof(ffi_cif));
  if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  data = scheme_make_vector(5, NULL);
  p = scheme_append_byte_string
        (ffi_name_prefix,
         scheme_make_byte_string_without_copying
           (SCHEME_FFIOBJP(argv[0]) ?
             ((ffi_obj_struct*)(argv[0]))->name : "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_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*));
  for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
    v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
    argv[i] = v;
  }
  p = _scheme_apply(data->proc, argc, argv);
  SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
}

/* 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("Releaseing 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
  free(p);
}

/* (ffi-callback scheme-proc in-types out-type) -> 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 3):}
{
  ffi_callback_struct *data;
  Scheme_Object *itypes = argv[1];
  Scheme_Object *otype = argv[2];
  Scheme_Object *p, *base;
  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);
  /* malloc space for everything needed, so a single free gets rid of this */
  cl_cif_args = malloc(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<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
    atypes[i] = CTYPE_PRIMTYPE(base);
  }
  if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  {:(cmake-object "data" ffi-callback
                  "cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):}
#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;
  }
#else
  cl_cif_args->data = (void*)data;
#endif
  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;
}

/*****************************************************************************/
/* Initialization */

void scheme_init_foreign(Scheme_Env *env)
{
  Scheme_Env *menv;
  ctype_struct *t;
  menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
  {:(for-each (lambda (x)
                (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");"))
              (reverse cstructs)):}
#ifdef MZ_PRECISE_GC
  {:(for-each (lambda (x)
                (~ "GC_register_traversers("(cadr x)"_tag, "(cadr x)"_SIZE, "
                   (cadr x)"_MARK, " (cadr x)"_FIXUP, 1, 0);"))
              (reverse cstructs)):}
#endif
  MZ_REGISTER_STATIC(opened_libs);
  opened_libs = scheme_make_hash_table(SCHEME_hash_string);
  {:(for-each
     (lambda (sym)
       (~ "MZ_REGISTER_STATIC("(cadr sym)");" \\
          (cadr sym)" = scheme_intern_symbol(\""(car sym)"\");"))
     (reverse symbols)):}
  {:(for-each
      (lambda (x)
        (~ "scheme_add_global(\""(car x)"\"," \\
           "  scheme_make_prim_w_arity("
                (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);"))
      (reverse! cfunctions))
    (for-each-type
      (cmake-object "t" ctype "NULL"
        (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);
}

/*****************************************************************************/
