xref: /dports/lang/racket-minimal/racket-8.3/src/bc/foreign/foreign.c

/********************************************
 ** Do not edit this file!
 ** This file is generated from foreign.rktc,
 ** to make changes, edit that file and
 ** run it to generate an updated version
 ** of this file.
 ********************************************/

#include "schpriv.h"
#include "schmach.h"
#include "schrktio.h"

#ifndef DONT_USE_FOREIGN

#include <errno.h>

#ifdef MZ_USE_FFIPOLL
# define MZ_USE_FFIPOLL_COND 1
#else /* MZ_USE_FFIPOLL undefined */
# define MZ_USE_FFIPOLL_COND 0
#endif /* MZ_USE_FFIPOLL */

#ifndef SIZEOF_BOOL
# define SIZEOF_BOOL 0
#endif /* SIZEOF_BOOL */
#if SIZEOF_BOOL != 0
# include <stdbool.h>
#endif /* SIZEOF_BOOL != 0 */

#ifndef WINDOWS_DYNAMIC_LOAD
# include <dlfcn.h>
#else /* WINDOWS_DYNAMIC_LOAD defined */
# include <windows.h>
#endif /* WINDOWS_DYNAMIC_LOAD */

#if !defined(WINDOWS_DYNAMIC_LOAD) || defined(__MINGW32__)
   typedef   signed char Tsint8;
   typedef unsigned char Tuint8;

# 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 /* !defined(WINDOWS_DYNAMIC_LOAD) || defined(__MINGW32__)  */

# 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 /* !defined(WINDOWS_DYNAMIC_LOAD) || defined(__MINGW32__) */

#include "ffi.h"

typedef void *(*Scheme_Malloc_Proc)(size_t);
static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode);

static Scheme_Object *nonatomic_sym;
static Scheme_Object *atomic_sym;
static Scheme_Object *stubborn_sym;
static Scheme_Object *uncollectable_sym;
static Scheme_Object *eternal_sym;
static Scheme_Object *interior_sym;
static Scheme_Object *atomic_interior_sym;
static Scheme_Object *raw_sym;
static Scheme_Object *tagged_sym;
static Scheme_Object *fail_ok_sym;

#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);

/* This make hides pointerness from cdefstruct so that it
   doesn't generate a mark/fixup action: */
#define NON_GCBALE_PTR(t) t*

static void overflow_error(const char *who, const char *op, intptr_t a, intptr_t b)
{
  scheme_contract_error(who, "arithmetic overflow",
                        "operation", 0, op,
                        "first argument", 1, scheme_make_integer(a),
                        "first argument", 1, scheme_make_integer(b),
                        NULL);
}

static intptr_t mult_check_overflow(const char *who, intptr_t a, intptr_t b)
{
  Scheme_Object *c;
  c = scheme_bin_mult(scheme_make_integer(a), scheme_make_integer(b));
  if (!SCHEME_INTP(c))
    overflow_error(who, "multiply", a, b);
  return SCHEME_INT_VAL(c);
}

static intptr_t add_check_overflow(const char *who, intptr_t a, intptr_t b)
{
  Scheme_Object *c;
  c = scheme_bin_plus(scheme_make_integer(a), scheme_make_integer(b));
  if (!SCHEME_INTP(c))
    overflow_error(who, "add", a, b);
  return SCHEME_INT_VAL(c);
}

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

/* ffi-lib structure definition */
static Scheme_Type ffi_lib_tag;
typedef struct ffi_lib_struct {
  Scheme_Object so;
  NON_GCBALE_PTR(rktio_dll_t) handle;
  Scheme_Object* name;
  int is_global;
  int refcount;
} ffi_lib_struct;
#define SCHEME_FFILIBP(x) (SCHEME_TYPE(x)==ffi_lib_tag)
#define MYNAME "ffi-lib?"
static Scheme_Object *foreign_ffi_lib_p(int argc, Scheme_Object *argv[])
{
  return SCHEME_FFILIBP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_lib */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_lib_SIZE(void *p) {
  return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
int ffi_lib_MARK(void *p) {
  ffi_lib_struct *s = (ffi_lib_struct *)p;
  gcMARK(s->name);
  return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
int ffi_lib_FIXUP(void *p) {
  ffi_lib_struct *s = (ffi_lib_struct *)p;
  gcFIXUP(s->name);
  return gcBYTES_TO_WORDS(sizeof(ffi_lib_struct));
}
END_XFORM_SKIP;
#endif

THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);

/* (ffi-lib filename no-error? global?) -> ffi-lib */
#define MYNAME "ffi-lib"
static Scheme_Object *foreign_ffi_lib(int argc, Scheme_Object *argv[])
{
  char *name;
  Scheme_Object *path, *hashname;
  rktio_dll_t *handle;
  int as_global = 0;
  ffi_lib_struct *lib;
  if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
    scheme_wrong_contract(MYNAME, "(or/c string? #f)", 0, argc, argv);
  as_global = ((argc > 2) && SCHEME_TRUEP(argv[2]));
  /* 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) {
    handle = rktio_dll_open(scheme_rktio, name, as_global);
    if (!handle) {
      char *msg;
      msg = rktio_dll_get_error(scheme_rktio);
      if (argc > 1 && SCHEME_TRUEP(argv[1])) {
        if (msg) free(msg);
        return scheme_false;
      } else {
        if (msg) {
          msg = scheme_strdup_and_free(msg);
          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                           MYNAME": couldn't open %V (%s)", argv[0], msg);
        } else
          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                           MYNAME": couldn't open %V (%R)", argv[0]);
      }
    }
    lib = (ffi_lib_struct*)scheme_malloc_tagged(sizeof(ffi_lib_struct));
    lib->so.type = ffi_lib_tag;
    lib->handle = (handle);
    lib->name = (argv[0]);
    lib->is_global = (!name);
    lib->refcount = (1);
    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 */
  } else
    lib->refcount++;
  return (Scheme_Object*)lib;
}
#undef MYNAME

/* (ffi-lib-name ffi-lib) -> string */
#define MYNAME "ffi-lib-name"
static Scheme_Object *foreign_ffi_lib_name(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_FFILIBP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-lib?", 0, argc, argv);
  return ((ffi_lib_struct*)argv[0])->name;
}
#undef MYNAME

/* (ffi-lib-unload ffi-lib) -> (void) */
#define MYNAME "ffi-lib-unload"
static Scheme_Object *foreign_ffi_lib_unload(int argc, Scheme_Object *argv[])
{
  ffi_lib_struct *lib;

  if (!SCHEME_FFILIBP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-lib?", 0, argc, argv);

  lib = (ffi_lib_struct *)argv[0];
  if (!lib->handle)
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     MYNAME": couldn't close already-closed lib %V",
                     lib->name);

  --lib->refcount;
  if (lib->refcount)
    return scheme_void;

  if (rktio_dll_close(scheme_rktio, lib->handle)) {
    Scheme_Object *hashname;

    lib->handle = NULL;

    if (SCHEME_FALSEP(lib->name))
      hashname = (Scheme_Object *)"";
    else {
      hashname = TO_PATH(lib->name);
      hashname = (Scheme_Object *)SCHEME_PATH_VAL(hashname);
    }
    scheme_hash_set(opened_libs, hashname, NULL);
  } else {
    char *msg;
    msg = rktio_dll_get_error(scheme_rktio);
    if (msg) {
      msg = scheme_strdup_and_free(msg);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't close %V (%s)", lib->name, msg);
    } else
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't close %V (%R)", lib->name);
  }

  return scheme_void;
}
#undef MYNAME

/*****************************************************************************/
/* Pull pointers (mostly functions) out of ffi-lib objects */

/* ffi-obj structure definition */
static Scheme_Type ffi_obj_tag;
typedef struct ffi_obj_struct {
  Scheme_Object so;
  NON_GCBALE_PTR(void) obj;
  char* name;
  NON_GCBALE_PTR(ffi_lib_struct) lib;
} ffi_obj_struct;
#define SCHEME_FFIOBJP(x) (SCHEME_TYPE(x)==ffi_obj_tag)
#define MYNAME "ffi-obj?"
static Scheme_Object *foreign_ffi_obj_p(int argc, Scheme_Object *argv[])
{
  return SCHEME_FFIOBJP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_obj */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_obj_SIZE(void *p) {
  return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
int ffi_obj_MARK(void *p) {
  ffi_obj_struct *s = (ffi_obj_struct *)p;
  gcMARK(s->name);
  return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
int ffi_obj_FIXUP(void *p) {
  ffi_obj_struct *s = (ffi_obj_struct *)p;
  gcFIXUP(s->name);
  return gcBYTES_TO_WORDS(sizeof(ffi_obj_struct));
}
END_XFORM_SKIP;
#endif

/* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */
#define MYNAME "ffi-obj"
static Scheme_Object *foreign_ffi_obj(int argc, Scheme_Object *argv[])
{
  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_contract(MYNAME, "ffi-lib?", 1, argc, argv);
  if (!SCHEME_BYTE_STRINGP(argv[0]))
    scheme_wrong_contract(MYNAME, "bytes?", 0, argc, argv);
  dlname = SCHEME_BYTE_STR_VAL(argv[0]);

  if (!lib->handle) {
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     MYNAME": couldn't get \"%s\" from already-closed %V",
                     dlname, lib->name);
  }

  dlobj = rktio_dll_find_object(scheme_rktio, lib->handle, dlname);
  if (!dlobj) {
    char *msg;
    msg = rktio_dll_get_error(scheme_rktio);
    if (msg) {
      msg = scheme_strdup_and_free(msg);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't get \"%s\" from %V (%s)",
                       dlname, lib->name, msg);
    } else
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't get \"%s\" from %V (%R)",
                       dlname, lib->name);
  }

  if (dlobj) {
    obj = (ffi_obj_struct*)scheme_malloc_tagged(sizeof(ffi_obj_struct));
    obj->so.type = ffi_obj_tag;
    obj->obj = (dlobj);
    obj->name = (dlname);
    obj->lib = (lib);
    return (Scheme_Object *)obj;
  } else
    return scheme_false;
}
#undef MYNAME

/* (ffi-obj-lib ffi-obj) -> ffi-lib */
#define MYNAME "ffi-obj-lib"
static Scheme_Object *foreign_ffi_obj_lib(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
  return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
}
#undef MYNAME

/* (ffi-obj-name ffi-obj) -> string */
#define MYNAME "ffi-obj-name"
static Scheme_Object *foreign_ffi_obj_name(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
  return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
}
#undef MYNAME

/*****************************************************************************/
/* 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 *)((((uintptr_t)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,(intptr_t*)(y))
#define scheme_get_unsigned_realint_val(x,y) \
  scheme_get_unsigned_int_val(x,(uintptr_t*)(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 Racket when longs are longer than ints (needed
 * for libffi's int32 types).  There is no need to deal with bignums because
 * racket's fixnums are longs. */
XFORM_NONGCING int scheme_get_realint_val(Scheme_Object *o, int *v)
{
  if (SCHEME_INTP(o)) {
    uintptr_t lv = SCHEME_INT_VAL(o);
    int i = (int)lv;
    if (i != lv)
      return 0;
    *v = i;
    return 1;
  } else return 0;
}
XFORM_NONGCING int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
{
  if (SCHEME_INTP(o)) {
    uintptr_t 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((intptr_t)(ri))
#define scheme_make_realinteger_value_from_unsigned(ri) \
  scheme_make_integer((uintptr_t)(ri))

#endif /* SIXTY_FOUR_BIT_INTEGERS */

XFORM_NONGCING MZ_INLINE static int get_byte_val(Scheme_Object *o, Tsint8 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= -128) && (v <= 127)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_ubyte_val(Scheme_Object *o, Tuint8 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= 0) && (v <= 255)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_short_val(Scheme_Object *o, Tsint16 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= -32768) && (v <= 32767)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

XFORM_NONGCING MZ_INLINE static int get_ushort_val(Scheme_Object *o, Tuint16 *_v)
{
  if (SCHEME_INTP(o)) {
    intptr_t v = SCHEME_INT_VAL(o);
    if ((v >= 0) && (v <= 65536)) {
      *_v = v;
      return 1;
    }
  }
  return 0;
}

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

XFORM_NONGCING 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)
{
  intptr_t ulen;
  unsigned short *res;
  res = scheme_ucs4_to_utf16
          (SCHEME_CHAR_STR_VAL(ucs), 0, SCHEME_CHAR_STRLEN_VAL(ucs),
           NULL, -1, &ulen, 1);
  res[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);
}

static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
  intptr_t ulen, end;
  mzchar *res;
  if (!utf) return scheme_false;
  for (end=0; utf[end] != 0; end++) { /**/ }
  res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 1);
  res[ulen] = 0;
  return scheme_make_sized_char_string(res, ulen, 0);
}

/*****************************************************************************/
/* Types */

#define MZ_TYPE_CAST(t, e) (t)(e)
#define MZ_NO_TYPE_CAST(t, e) (e)

/***********************************************************************
 * 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(intptr_t) == 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' and `intptr_t' to change.
 **********************************************************************/

/* returns #<void> when used as output type, not for input types. */
#define FOREIGN_void (1)
/* Type Name:   void
 * LibFfi type: ffi_type_void
 * C type:      -none-
 * Predicate:   -none-
 * Racket->C:   -none-
 * S->C offset: 0
 * C->Racket:   scheme_void
 */

#define FOREIGN_int8 (2)
/* Type Name:   int8
 * LibFfi type: ffi_type_sint8
 * C type:      Tsint8
 * Predicate:   get_byte_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

#define FOREIGN_uint8 (3)
/* Type Name:   uint8
 * LibFfi type: ffi_type_uint8
 * C type:      Tuint8
 * Predicate:   get_ubyte_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

#define FOREIGN_int16 (4)
/* Type Name:   int16
 * LibFfi type: ffi_type_sint16
 * C type:      Tsint16
 * Predicate:   get_short_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

#define FOREIGN_uint16 (5)
/* Type Name:   uint16
 * LibFfi type: ffi_type_uint16
 * C type:      Tuint16
 * Predicate:   get_ushort_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

/* Treats integers properly: */
#define FOREIGN_int32 (6)
/* Type Name:   int32
 * LibFfi type: ffi_type_sint32
 * C type:      Tsint32
 * Predicate:   scheme_get_realint_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_realinteger_value(<C>)
 */

/* Treats integers properly: */
#define FOREIGN_uint32 (7)
/* Type Name:   uint32
 * LibFfi type: ffi_type_uint32
 * C type:      Tuint32
 * Predicate:   scheme_get_unsigned_realint_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_realinteger_value_from_unsigned(<C>)
 */

#define FOREIGN_int64 (8)
/* Type Name:   int64
 * LibFfi type: ffi_type_sint64
 * C type:      Tsint64
 * Predicate:   scheme_get_long_long_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer_value_from_long_long(<C>)
 */

#define FOREIGN_uint64 (9)
/* Type Name:   uint64
 * LibFfi type: ffi_type_uint64
 * C type:      Tuint64
 * Predicate:   scheme_get_unsigned_long_long_val(<Scheme>,&aux)
 * Racket->C:   -none- (set by the predicate)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer_value_from_unsigned_long_long(<C>)
 */

/* This is like int32, but always assumes fixnum: */
#define FOREIGN_fixint (10)
/* Type Name:   fixint
 * LibFfi type: ffi_type_sint32
 * C type:      Tsint32
 * Predicate:   SCHEME_INTP(<Scheme>)
 * Racket->C:   SCHEME_INT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

/* This is like uint32, but always assumes fixnum: */
#define FOREIGN_ufixint (11)
/* Type Name:   ufixint
 * LibFfi type: ffi_type_uint32
 * C type:      Tuint32
 * Predicate:   SCHEME_INTP(<Scheme>)
 * Racket->C:   SCHEME_UINT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer_from_unsigned(<C>)
 */

#ifndef SIXTY_FOUR_BIT_LONGS
#define ffi_type_smzlong ffi_type_sint32
#define ffi_type_umzlong ffi_type_uint32
#else /* SIXTY_FOUR_BIT_LONGS defined */
#define ffi_type_smzlong ffi_type_sint64
#define ffi_type_umzlong ffi_type_uint64
#endif /* SIXTY_FOUR_BIT_LONGS */

#ifndef SIXTY_FOUR_BIT_INTEGERS
#define ffi_type_smzintptr ffi_type_sint32
#define ffi_type_umzintptr ffi_type_uint32
#else /* SIXTY_FOUR_BIT_INTEGERS defined */
#define ffi_type_smzintptr ffi_type_sint64
#define ffi_type_umzintptr ffi_type_uint64
#endif /* SIXTY_FOUR_BIT_INTEGERS */

/* This is what mzscheme defines as intptr, assuming fixnums: */
#define FOREIGN_fixnum (12)
/* Type Name:   fixnum
 * LibFfi type: ffi_type_smzintptr
 * C type:      intptr_t
 * Predicate:   SCHEME_INTP(<Scheme>)
 * Racket->C:   SCHEME_INT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer(<C>)
 */

/* This is what mzscheme defines as uintptr, assuming fixnums: */
#define FOREIGN_ufixnum (13)
/* Type Name:   ufixnum
 * LibFfi type: ffi_type_umzintptr
 * C type:      uintptr_t
 * Predicate:   SCHEME_INTP(<Scheme>)
 * Racket->C:   SCHEME_UINT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_integer_from_unsigned(<C>)
 */

#define FOREIGN_float (14)
/* Type Name:   float
 * LibFfi type: ffi_type_float
 * C type:      float
 * Predicate:   SCHEME_FLOATP(<Scheme>)
 * Racket->C:   SCHEME_FLOAT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_double(<C>)
 */

#define FOREIGN_double (15)
/* Type Name:   double
 * LibFfi type: ffi_type_double
 * C type:      double
 * Predicate:   SCHEME_FLOATP(<Scheme>)
 * Racket->C:   SCHEME_FLOAT_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_double(<C>)
 */

#ifdef _MSC_VER
struct struct_align_slongdouble {
  char c;
  long_double x;
};
const ffi_type ffi_type_slongdouble = {
  sizeof(long_double),
  offsetof(struct struct_align_slongdouble, x),
  FFI_TYPE_STRUCT, NULL
};
#else /* _MSC_VER undefined */
#define ffi_type_slongdouble ffi_type_longdouble
#endif /* _MSC_VER */
#ifdef MZ_LONG_DOUBLE
#define SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)
#else /* MZ_LONG_DOUBLE undefined */
#define SCHEME_MAYBE_LONG_DBL_VAL(x) unsupported_long_double_val()
static mz_long_double unsupported_long_double_val() {
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
  return 0.0;
}
#endif /* MZ_LONG_DOUBLE */
#ifdef MZ_LONG_DOUBLE
#define scheme_make_maybe_long_double(x) scheme_make_long_double(x)
#else /* MZ_LONG_DOUBLE undefined */
#define scheme_make_maybe_long_double(x) unsupported_make_long_double()
static Scheme_Object *unsupported_make_long_double() {
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
  return NULL;
}
#endif /* MZ_LONG_DOUBLE */

#define FOREIGN_longdouble (16)
/* Type Name:   longdouble
 * LibFfi type: ffi_type_slongdouble
 * C type:      mz_long_double
 * Predicate:   SCHEME_LONG_DBLP(<Scheme>)
 * Racket->C:   SCHEME_MAYBE_LONG_DBL_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_maybe_long_double(<C>)
 */


/* A double that will coerce numbers to doubles: */
#define FOREIGN_doubleS (17)
/* Type Name:   double* (doubleS)
 * LibFfi type: ffi_type_double
 * C type:      double
 * Predicate:   SCHEME_REALP(<Scheme>)
 * Racket->C:   scheme_real_to_double(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_double(<C>)
 */

/* Booleans -- implemented as an int which is 1 or 0: */
#define FOREIGN_bool (18)
/* Type Name:   bool
 * LibFfi type: ffi_type_sint
 * C type:      int
 * Predicate:   1
 * Racket->C:   SCHEME_TRUEP(<Scheme>)
 * S->C offset: 0
 * C->Racket:   (<C>?scheme_true:scheme_false)
 */

#if SIZEOF_BOOL == 0
typedef signed char stdbool;
# define ffi_type_stdbool ffi_type_sint8
#else /* SIZEOF_BOOL == 0  */
typedef bool stdbool;
#if SIZEOF_BOOL == 1
# define ffi_type_stdbool ffi_type_sint8
#else /* SIZEOF_BOOL == 1  */
#if SIZEOF_BOOL == 2
# define ffi_type_stdbool ffi_type_sint16
#else /* SIZEOF_BOOL == 2  */
#if SIZEOF_BOOL == 4
# define ffi_type_stdbool ffi_type_sint32
#else /* SIZEOF_BOOL == 4  */
#if SIZEOF_BOOL == 8
# define ffi_type_stdbool ffi_type_sint64
#else /* SIZEOF_BOOL == 8  */
/* ??? Pick something */
# define ffi_type_stdbool ffi_type_int
#endif /* SIZEOF_BOOL == 8 */
#endif /* SIZEOF_BOOL == 4 */
#endif /* SIZEOF_BOOL == 2 */
#endif /* SIZEOF_BOOL == 1 */
#endif /* SIZEOF_BOOL == 0 */

/* Booleans -- implemented as an int which is 1 or 0: */
#define FOREIGN_stdbool (19)
/* Type Name:   stdbool
 * LibFfi type: ffi_type_stdbool
 * C type:      stdbool
 * Predicate:   1
 * Racket->C:   SCHEME_TRUEP(<Scheme>)
 * S->C offset: 0
 * C->Racket:   (<C>?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. */

#define FOREIGN_string_ucs_4 (20)
/* Type Name:   string/ucs-4 (string_ucs_4)
 * LibFfi type: ffi_type_gcpointer
 * C type:      mzchar*
 * Predicate:   SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
 * Racket->C:   ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_make_char_string_without_copying(<C>)
 */

#define FOREIGN_string_utf_16 (21)
/* Type Name:   string/utf-16 (string_utf_16)
 * LibFfi type: ffi_type_gcpointer
 * C type:      unsigned short*
 * Predicate:   SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
 * Racket->C:   ucs4_string_or_null_to_utf16_pointer(<Scheme>)
 * S->C offset: 0
 * C->Racket:   utf16_pointer_to_ucs4_string(<C>)
 */

/* Byte strings -- not copying C strings, #f is NULL.
 * (note: these are not like char* which is just a pointer) */

#define FOREIGN_bytes (22)
/* Type Name:   bytes
 * LibFfi type: ffi_type_gcpointer
 * C type:      char*
 * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
 * Racket->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
 */

#define FOREIGN_path (23)
/* Type Name:   path
 * LibFfi type: ffi_type_gcpointer
 * C type:      char*
 * Predicate:   SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
 * Racket->C:   SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
 * S->C offset: 0
 * C->Racket:   (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
 */

#define FOREIGN_symbol (24)
/* Type Name:   symbol
 * LibFfi type: ffi_type_pointer
 * C type:      char*
 * Predicate:   SCHEME_SYMBOLP(<Scheme>)
 * Racket->C:   SCHEME_SYM_VAL(<Scheme>)
 * S->C offset: 0
 * C->Racket:   scheme_intern_symbol(<C>)
 */

/* 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. */
#define FOREIGN_pointer (25)
/* Type Name:   pointer
 * LibFfi type: ffi_type_pointer
 * C type:      void*
 * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
 * Racket->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
 * S->C offset: FFIANYPTR
 * C->Racket:   scheme_make_foreign_external_cpointer(<C>)
 */

#define FOREIGN_gcpointer (26)
/* Type Name:   gcpointer
 * LibFfi type: ffi_type_gcpointer
 * C type:      void*
 * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
 * Racket->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
 * S->C offset: FFIANYPTR
 * C->Racket:   scheme_make_foreign_cpointer(<C>)
 */

/* This is used for passing and Scheme_Object* value as is.  Useful for
 * functions that know about Scheme_Object*s, like Racket's. */
#define FOREIGN_scheme (27)
/* Type Name:   scheme
 * LibFfi type: ffi_type_gcpointer
 * C type:      Scheme_Object*
 * Predicate:   1
 * Racket->C:   <Scheme>
 * S->C offset: 0
 * C->Racket:   <C>
 */

/* Special type, not actually used for anything except to mark values
 * that are treated like pointers but not referenced.  Used for
 * creating function types. */
#define FOREIGN_fpointer (28)
/* Type Name:   fpointer
 * LibFfi type: ffi_type_pointer
 * C type:      void*
 * Predicate:   -none-
 * Racket->C:   -none-
 * S->C offset: 0
 * C->Racket:   -none-
 */

typedef union _ForeignAny {
  Tsint8 x_int8;
  Tuint8 x_uint8;
  Tsint16 x_int16;
  Tuint16 x_uint16;
  Tsint32 x_int32;
  Tuint32 x_uint32;
  Tsint64 x_int64;
  Tuint64 x_uint64;
  Tsint32 x_fixint;
  Tuint32 x_ufixint;
  intptr_t x_fixnum;
  uintptr_t x_ufixnum;
  float x_float;
  double x_double;
  mz_long_double x_longdouble;
  double x_doubleS;
  int x_bool;
  stdbool x_stdbool;
  mzchar* x_string_ucs_4;
  unsigned short* x_string_utf_16;
  char* x_bytes;
  char* x_path;
  char* x_symbol;
  void* x_pointer;
  void* x_gcpointer;
  Scheme_Object* x_scheme;
  void* x_fpointer;
} ForeignAny;

/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (29)
#define FOREIGN_array (30)
#define FOREIGN_union (31)

XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
  if (SCHEME_FFIOBJP(o)) return 0;
  return (!SCHEME_CPTRP(o)
          || !(SCHEME_CPTR_FLAGS(o) & 0x1));
}

/*****************************************************************************/
/* 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 or union, then basetype will be the list of ctypes that
 *   made this struct, prefixed with a symbol if the allocation mode is not 'atomic
 * 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.)
 */
/* ctype structure definition */
#define ctype_tag scheme_ctype_type
typedef struct ctype_struct {
  Scheme_Object so;
  Scheme_Object* basetype;
  Scheme_Object* scheme_to_c;
  Scheme_Object* c_to_scheme;
} ctype_struct;
#define SCHEME_CTYPEP(x) (SCHEME_TYPE(x)==ctype_tag)
#define MYNAME "ctype?"
static Scheme_Object *foreign_ctype_p(int argc, Scheme_Object *argv[])
{
  return SCHEME_CTYPEP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ctype */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ctype_SIZE(void *p) {
  return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
int ctype_MARK(void *p) {
  ctype_struct *s = (ctype_struct *)p;
  gcMARK(s->basetype);
  gcMARK(s->scheme_to_c);
  gcMARK(s->c_to_scheme);
  return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
int ctype_FIXUP(void *p) {
  ctype_struct *s = (ctype_struct *)p;
  gcFIXUP(s->basetype);
  gcFIXUP(s->scheme_to_c);
  gcFIXUP(s->c_to_scheme);
  return gcBYTES_TO_WORDS(sizeof(ctype_struct));
}
END_XFORM_SKIP;
#endif

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) ((intptr_t)(((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)

#define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x))

/* Returns #f for primitive types. */
#define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{
  Scheme_Object *r;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  r = CTYPE_BASETYPE(argv[0]);
  if (SCHEME_PAIRP(r) && SCHEME_SYMBOLP(SCHEME_CAR(r))) {
    /* strip allocation mode for struct/union */
    r = SCHEME_CDR(r);
  }
  return r;
}
#undef MYNAME

#define MYNAME "ctype-scheme->c"
static Scheme_Object *foreign_ctype_scheme_to_c(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->scheme_to_c;
}
#undef MYNAME

#define MYNAME "ctype-c->scheme"
static Scheme_Object *foreign_ctype_c_to_scheme(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->c_to_scheme;
}
#undef MYNAME

/* Returns a primitive type, or NULL if not a type */
XFORM_NONGCING 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 */
XFORM_NONGCING static intptr_t ctype_sizeof(Scheme_Object *type)
{
  type = get_ctype_base(type);
  if (type == NULL) return -1;
  switch (CTYPE_PRIMLABEL(type)) {
  case FOREIGN_void: return 0;
  case FOREIGN_int8: return sizeof(Tsint8);
  case FOREIGN_uint8: return sizeof(Tuint8);
  case FOREIGN_int16: return sizeof(Tsint16);
  case FOREIGN_uint16: return sizeof(Tuint16);
  case FOREIGN_int32: return sizeof(Tsint32);
  case FOREIGN_uint32: return sizeof(Tuint32);
  case FOREIGN_int64: return sizeof(Tsint64);
  case FOREIGN_uint64: return sizeof(Tuint64);
  case FOREIGN_fixint: return sizeof(Tsint32);
  case FOREIGN_ufixint: return sizeof(Tuint32);
  case FOREIGN_fixnum: return sizeof(intptr_t);
  case FOREIGN_ufixnum: return sizeof(uintptr_t);
  case FOREIGN_float: return sizeof(float);
  case FOREIGN_double: return sizeof(double);
  case FOREIGN_longdouble: return sizeof(mz_long_double);
  case FOREIGN_doubleS: return sizeof(double);
  case FOREIGN_bool: return sizeof(int);
  case FOREIGN_stdbool: return sizeof(stdbool);
  case FOREIGN_string_ucs_4: return sizeof(mzchar*);
  case FOREIGN_string_utf_16: return sizeof(unsigned short*);
  case FOREIGN_bytes: return sizeof(char*);
  case FOREIGN_path: return sizeof(char*);
  case FOREIGN_symbol: return sizeof(char*);
  case FOREIGN_pointer: return sizeof(void*);
  case FOREIGN_gcpointer: return sizeof(void*);
  case FOREIGN_scheme: return sizeof(Scheme_Object*);
  case FOREIGN_fpointer: return sizeof(void*);
  /* for structs and arrays */
  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. */
#define MYNAME "make-ctype"
static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object *argv[])
{
  ctype_struct *type;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
    scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 1, argc, argv);
  else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
    scheme_wrong_contract(MYNAME, "(or/c procedure? #f)", 2, argc, argv);
  else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
    return argv[0];
  else {
    type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
    type->so.type = ctype_tag;
    type->basetype = (argv[0]);
    type->scheme_to_c = (argv[1]);
    type->c_to_scheme = (argv[2]);
    return (Scheme_Object*)type;
  }
  return NULL; /* hush the compiler */
}
#undef MYNAME

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

static void free_libffi_type_two_layers(void *ignored, void *p)
{
  int i;

  for (i = 0; ((ffi_type*)p)->elements[i]; i++) {
    free(((ffi_type*)p)->elements[i]);
  }
  free_libffi_type(ignored, p);
}

/*****************************************************************************/
/* ABI spec */

static Scheme_Object *default_sym;
static Scheme_Object *stdcall_sym;
static Scheme_Object *sysv_sym;

static ffi_abi sym_to_abi(const 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)) {
#if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64)
    return FFI_SYSV;
#else
    scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
  } else if (SAME_OBJ(sym, stdcall_sym)) {
#if defined(WINDOWS_DYNAMIC_LOAD) && !defined(_WIN64)
    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 */

static void wrong_void(const char *who, Scheme_Object *list_element, int specifically_void,
                       int which, int argc, Scheme_Object **argv)
{
  intptr_t len;
  char *s;

  if (argc > 1)
    s = scheme_make_arg_lines_string("  ", which, argc, argv, &len);
  else
    s = NULL;

  if (list_element) {
    scheme_contract_error(who,
                          (specifically_void
                           ? "C type within list is based on _void"
                           : "C type within list has a zero size"),
                          "C type", 1, list_element,
                          "list", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
  } else
    scheme_contract_error(who,
                          (specifically_void
                           ? "given C type is based on _void"
                           : "given C type has a zero size"),
                          "given C type", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
}

/* (make-cstruct-type types [abi alignment malloc-mode]) -> 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 Racket. */
#define MYNAME "make-cstruct-type"
static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
{
  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, with_alignment;
  ffi_abi abi;
  Scheme_Object *fields = argv[0];
  nargs = scheme_proper_list_length(fields);
  if (nargs <= 0) scheme_wrong_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
  abi = GET_ABI(MYNAME,1);
  if (argc > 2) {
    if (!SCHEME_FALSEP(argv[2])) {
      if (!SAME_OBJ(argv[2], scheme_make_integer(1))
          && !SAME_OBJ(argv[2], scheme_make_integer(2))
          && !SAME_OBJ(argv[2], scheme_make_integer(4))
          && !SAME_OBJ(argv[2], scheme_make_integer(8))
          && !SAME_OBJ(argv[2], scheme_make_integer(16)))
        scheme_wrong_contract(MYNAME, "(or/c 1 2 4 8 16 #f)", 2, argc, argv);
      with_alignment = SCHEME_INT_VAL(argv[2]);
    } else
      with_alignment = 0;
    if (argc > 3) {
      if (!SAME_OBJ(argv[3], atomic_sym)) {
        (void)mode_to_allocator(MYNAME, argv[3]);
        fields = scheme_make_pair(argv[3], fields);
      }
    }
  } else
    with_alignment = 0;

    /* 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_contract(MYNAME, "(non-empty-listof ctype?)", 0, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      wrong_void(MYNAME, SCHEME_CAR(p), 1, 0, argc, argv);
    elements[i] = CTYPE_PRIMTYPE(base);
    if (with_alignment) {
      /* copy the type to set an alignment: */
      libffi_type = malloc(sizeof(ffi_type));
      memcpy(libffi_type, elements[i], sizeof(ffi_type));
      elements[i] = libffi_type;
      if (with_alignment < elements[i]->alignment)
        elements[i]->alignment = with_alignment;
    }
  }

  /* 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, abi, 1, &ffi_type_void, dummy) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  type->so.type = ctype_tag;
  type->basetype = (fields);
  type->scheme_to_c = ((Scheme_Object*)libffi_type);
  type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
  if (with_alignment)
    scheme_register_finalizer(type, free_libffi_type_two_layers, libffi_type, NULL, NULL);
  else
    scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
  return (Scheme_Object*)type;
}
#undef MYNAME

/*****************************************************************************/
/* array types */

static void wrong_intptr(const char *who, int which, int argc, Scheme_Object **argv)
{
  if (!SCHEME_INTP(argv[which]) && !SCHEME_BIGNUMP(argv[which])) {
    scheme_wrong_contract(who, "exact-integer?", which, argc, argv);
  } else {
    intptr_t len;
    char *s;

    if (argc > 1)
      s = scheme_make_arg_lines_string("  ", which, argc, argv, &len);
    else
      s = NULL;

    scheme_contract_error(who,
                          "given integer does not fit into the _intptr type",
                          "given integer", 1, argv[which],
                          s ? "other arguments" : NULL, 0, s,
                          NULL);
  }
}

#if defined(__aarch64__)
# define SMALL_ARRAY_THRESHOLD 64
#else
# define SMALL_ARRAY_THRESHOLD 32
#endif

/* (make-array-type type len) -> ctype */
/* This creates a new primitive type that is an array. An array is the
 * same as a cpointer as an argument, but it behave differently within
 * a struct or for allocation. Marshaling to lists or whatever should
 * be done in Racket. */
#define MYNAME "make-array-type"
static Scheme_Object *foreign_make_array_type(int argc, Scheme_Object *argv[])
{
  Scheme_Object *base, *basetype;
  GC_CAN_IGNORE ffi_type *libffi_type, **elements;
  ctype_struct *type;
  intptr_t len, size;

  if (NULL == (base = get_ctype_base(argv[0])))
    scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1], &len) || (len < 0)) {
    if ((SCHEME_INTP(argv[1]) && SCHEME_INT_VAL(argv[1]) > 0)
        || (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1])))
      wrong_intptr(MYNAME, 1, argc, argv);
    else
      scheme_wrong_contract(MYNAME, "exact-nonnegative-integer?", 1, argc, argv);
  }

  /* libffi doesn't seem to support array types, but we try to make
     libffi work anyway by making a structure type that is used when
     an array appears as a struct field. If the array size is 4 or
     less, or if the total size is SMALL_ARRAY_THRESHOLD bytes or
     less, then we make a full `elements' array, because the x86_64
     ABI always shifts to memory mode after 32 bytes and the AArch64
     ABI shifts after 64 bytes. */

  /* Allocate the new libffi type object, which is only provided to
     libffi as a type for a structure field.  When a FOREIGN_array
     type is used for a function argument or result, it is replaced
     with FOREIGN_pointer.  We put FFI_TYPE_STRUCT in
     libffi_type->type and make an elements array that contains
     a single instance of the element type... which seems to work
     ok so far.  */
  libffi_type = malloc(sizeof(ffi_type));
  size = mult_check_overflow(MYNAME, CTYPE_PRIMTYPE(base)->size, len);
  libffi_type->size      = size;
  libffi_type->alignment = CTYPE_PRIMTYPE(base)->alignment;
  libffi_type->type      = FFI_TYPE_STRUCT;

  if ((libffi_type->size <= SMALL_ARRAY_THRESHOLD) || (len <= 4)) {
    int i;
    elements = malloc((len + 1) * sizeof(ffi_type*));
    for (i = 0; i < len; i++) {
      elements[i] = CTYPE_PRIMTYPE(base);
    }
    elements[len] = NULL;
  } else {
    elements = malloc(2 * sizeof(ffi_type*));
    elements[0] = CTYPE_PRIMTYPE(base);
    elements[1] = NULL;
  }
  libffi_type->elements  = elements;

  basetype = scheme_make_vector(2, argv[0]);
  SCHEME_VEC_ELS(basetype)[1] = argv[1];

  type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  type->so.type = ctype_tag;
  type->basetype = (basetype);
  type->scheme_to_c = ((Scheme_Object*)libffi_type);
  type->c_to_scheme = ((Scheme_Object*)FOREIGN_array);

  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);

  return (Scheme_Object*)type;
}
#undef MYNAME

/*****************************************************************************/
/* union types */

static int all_float_types(GC_CAN_IGNORE ffi_type *libffi_type);

/* (make-union-type type ...+) -> ctype */
/* This creates a new primitive type that is a union. All unions
 * behave like structs. Marshaling to lists or whatever should
 * be done in Racket. */
#define MYNAME "make-union-type"
static Scheme_Object *foreign_make_union_type(int argc, Scheme_Object *argv[])
{
  Scheme_Object *base, *basetype;
  GC_CAN_IGNORE ffi_type *libffi_type, **elements = NULL;
  ctype_struct *type;
  int i, align = 1, a, sz = 0, count = 0, float_kinds = 0, float_kind;
  int some_non_floats = 0;

  /* libffi doesn't support union types, so we try to make a
     reasonable approximation. The calling convention of a union type
     mostly likely depends on of the maximum size of all alternatives
     and whether it's floating-point or not. Synthesize a struct that
     is big enough and composed of only floats if the union
     alternative are only floats or integers otherwise. This is not
     guaranteed to be right, but it has a chance at working. */

  /* find max required alignment and size: */
  for (i = 0; i < argc; i++) {
    if (NULL == (base = get_ctype_base(argv[i]))) {
      free(elements);
      scheme_wrong_contract(MYNAME, "ctype?", i, argc, argv);
    }
    a = CTYPE_PRIMTYPE(base)->alignment;
    if (a > align) align = a;
    a = CTYPE_PRIMTYPE(base)->size;
    if (sz < a) sz = a;

    float_kind = all_float_types(CTYPE_PRIMTYPE(base));
    if (i == 0) float_kinds = float_kind;
    if (!float_kind || (float_kind != float_kinds))
      some_non_floats = 1;
  }

  if (!sz)
    scheme_signal_error("empty union");

  /* round size up to alignment: */
  if ((sz % align) != 0) {
    sz += (align - (sz % align));
  }

  /* Synthesize element list */
  while (!elements) {
    if (count)
      elements = malloc((count+1) * sizeof(ffi_type*));
    count = 0;

    if (some_non_floats) {
      /* build a struct out of integers */
      int remain_sz = sz;
      while (remain_sz >= sizeof(intptr_t)) {
        if (elements)
          elements[count] = &ffi_type_smzintptr;
        remain_sz -= sizeof(intptr_t);
        count++;
      }
      while (remain_sz >= sizeof(int)) {
        if (elements)
          elements[count] = &ffi_type_sint32;
        remain_sz -= sizeof(int);
        count++;
      }
      while (remain_sz >= sizeof(short)) {
        if (elements)
          elements[count] = &ffi_type_sint16;
        remain_sz -= sizeof(short);
        count++;
      }
      while (remain_sz) {
        if (elements)
          elements[count] = &ffi_type_sint8;
        remain_sz -= 1;
        count++;
      }
      /* remain_sz should be 0 at this point */
    } else {
      /* build a struct out of doubles and floats */
      int remain_sz = sz;
      while (remain_sz >= sizeof(double)) {
        if (elements)
          elements[count] = &ffi_type_double;
        remain_sz -= sizeof(double);
        count++;
      }
      while (remain_sz >= sizeof(float)) {
        if (elements)
          elements[count] = &ffi_type_float;
        remain_sz -= sizeof(float);
        count++;
      }
      /* remain_sz should be 0 at this point */
    }
  }

  elements[count] = NULL;

  /* Allocate the new libffi type object. */
  libffi_type = malloc(sizeof(ffi_type));
  libffi_type->size      = sz;
  libffi_type->alignment = align;
  libffi_type->type      = FFI_TYPE_STRUCT;
  libffi_type->elements  = elements;

  basetype = scheme_box(scheme_build_list(argc, argv));

  type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  type->so.type = ctype_tag;
  type->basetype = (basetype);
  type->scheme_to_c = ((Scheme_Object*)libffi_type);
  type->c_to_scheme = ((Scheme_Object*)FOREIGN_union);

  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);

  return (Scheme_Object*)type;
}
#undef MYNAME

static Scheme_Object *all_float_types_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  int r;
  r = all_float_types((ffi_type *)p->ku.k.i1);
  return scheme_make_integer(r);
}

#if defined(__arm__) || defined(__thumb__) || defined(__aarch64__)
/* Arm: uniform floats must be the same type */
# define FLOAT_KIND_DOUBLE 1
# define FLOAT_KIND_FLOAT  2
# define FLOAT_KIND_EXT    3
#else
/* Other: different kinds of floats are treated the same */
# define FLOAT_KIND_DOUBLE 1
# define FLOAT_KIND_FLOAT  1
# define FLOAT_KIND_EXT    1
#endif

static int all_float_types(GC_CAN_IGNORE ffi_type *libffi_type)
{
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      Scheme_Object *r;
      p->ku.k.i1 = (intptr_t)libffi_type;
      r = scheme_handle_stack_overflow(all_float_types_k);
      return SCHEME_INT_VAL(r);
    }
  }

  if (libffi_type == &ffi_type_double)
    return FLOAT_KIND_DOUBLE;
  if (libffi_type == &ffi_type_float)
    return FLOAT_KIND_FLOAT;
  if (libffi_type == &ffi_type_longdouble)
    return FLOAT_KIND_EXT;

  if (libffi_type->type == FFI_TYPE_STRUCT) {
    int i, kind = 0, k;
    for (i = 0; libffi_type->elements[i]; i++) {
      k = all_float_types(libffi_type->elements[i]);
      if (!k)
        return 0;
      if (!i)
        kind = k;
      else if (kind != k)
        return 0;
    }
    return kind;
  }

  return 0;
}

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

/* ffi-callback structure definition */
static Scheme_Type ffi_callback_tag;
typedef struct ffi_callback_struct {
  Scheme_Object so;
  NON_GCBALE_PTR(void) callback;
  Scheme_Object* proc;
  Scheme_Object* itypes;
  Scheme_Object* otype;
  Scheme_Object* sync;
} ffi_callback_struct;
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
#define MYNAME "ffi-callback?"
static Scheme_Object *foreign_ffi_callback_p(int argc, Scheme_Object *argv[])
{
  return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false;
}
#undef MYNAME
/* 3m stuff for ffi_callback */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
int ffi_callback_SIZE(void *p) {
  return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_MARK(void *p) {
  ffi_callback_struct *s = (ffi_callback_struct *)p;
  gcMARK(s->proc);
  gcMARK(s->itypes);
  gcMARK(s->otype);
  gcMARK(s->sync);
  return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_FIXUP(void *p) {
  ffi_callback_struct *s = (ffi_callback_struct *)p;
  gcFIXUP(s->proc);
  gcFIXUP(s->itypes);
  gcFIXUP(s->otype);
  gcFIXUP(s->sync);
  return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
END_XFORM_SKIP;
#endif   /* pointer to another ffi-callback for a curried callback */

/* The sync field:
 *   NULL => non-atomic mode
 *   #t => atomic mode, no sync proc
 *   proc => non-atomic mode, sync proc
 *   (box proc) => atomic mode, sync proc
*/

/*****************************************************************************/
/* 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) \
  (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x))

#define scheme_make_foreign_cpointer(x) \
  ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))

#define scheme_make_foreign_offset_cpointer(x, delta) \
  ((delta == 0) ? scheme_make_foreign_cpointer(x) : scheme_make_offset_cptr(x,delta,NULL))

#define scheme_make_foreign_external_cpointer(x) \
  ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))

#define scheme_make_foreign_offset_external_cpointer(x, delta) \
  ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))

static int check_cpointer_property(Scheme_Object *v)
{
  if (SCHEME_CHAPERONE_STRUCTP(v)
      && scheme_struct_type_property_ref(scheme_cpointer_property, v))
    return 1;
  else
    return 0;
}

static Scheme_Object *unwrap_cpointer_property_slow(Scheme_Object *orig_v)
{
  Scheme_Object *v = orig_v, *val;
  int must = 0;

  while (1) {
    if (SCHEME_CHAPERONE_STRUCTP(v)) {
      val = scheme_struct_type_property_ref(scheme_cpointer_property, v);
      if (val) {
        if (SCHEME_INTP(val))
          v = scheme_struct_ref(v, SCHEME_INT_VAL(val));
        else if (SCHEME_PROCP(val)) {
          Scheme_Object *a[1];
          a[0] = v;
          v = _scheme_apply(val, 1, a);
        } else
          v = val;
        must = 1;
      } else
        break;
    } else
      break;
  }

  if (must && !SCHEME_FFIANYPTRP(v)) {
    scheme_wrong_contract("prop:cpointer accessor", "cpointer?", 0, -1, &v);
    return NULL;
  }

  return v;
}

static Scheme_Object *unwrap_cpointer_property(Scheme_Object *v)
{
  if (SCHEME_FFIANYPTRP(v))
    return v;
  else
    return unwrap_cpointer_property_slow(v);
}

int scheme_is_cpointer(Scheme_Object *cp) {
  return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}

#define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
{
  return (scheme_is_cpointer(argv[0])
          ? scheme_true
          : scheme_false);
}
#undef MYNAME

#define MYNAME "cpointer-tag"
static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
{
  Scheme_Object *tag = NULL;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (SCHEME_CPTRP(cp)) tag = SCHEME_CPTR_TYPE(cp);
  return (tag == NULL) ? scheme_false : tag;
}
#undef MYNAME

Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr)
{
  Scheme_Object *a[1];
  a[0] = ptr;
  return foreign_cpointer_tag(1, a);
}

#define MYNAME "set-cpointer-tag!"
static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[])
{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_CPTRP(cp))
    scheme_wrong_contract(MYNAME, "proper-cpointer?", 0, argc, argv);
  SCHEME_CPTR_TYPE(cp) = argv[1];
  return scheme_void;
}
#undef MYNAME

void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val)
{
  Scheme_Object *a[2];
  a[0] = ptr;
  a[1] = val;
  (void)foreign_set_cpointer_tag_bang(2, a);
}

#define MYNAME "cpointer-gcable?"
static Scheme_Object *foreign_cpointer_gcable_p(int argc, Scheme_Object *argv[])
{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (SCHEME_CPTRP(cp)) {
    return ((SCHEME_CPTR_FLAGS(cp) & 0x1)
            ? scheme_false
            : scheme_true);
  } else if (SCHEME_FALSEP(cp)
             || SCHEME_FFIOBJP(cp)
             || SCHEME_FFICALLBACKP(cp))
    return scheme_false;
  else if (SCHEME_BYTE_STRINGP(cp))
    return scheme_true;
  else {
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
    return NULL;
  }
}
#undef MYNAME

void *scheme_extract_pointer(Scheme_Object *v) {
  return SCHEME_FFIANYPTR_OFFSETVAL(v);
}

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

static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type, void *src,
                               intptr_t delta, int args_loc, int gcsrc)
{
  Scheme_Object *res;
  if (!SCHEME_CTYPEP(type))
    scheme_wrong_contract("C->Racket", "ctype?", 0, 1, &type);
  if (CTYPE_USERP(type)) {
    res = C2SCHEME(already_ptr, CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
    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) {
    if (already_ptr) return already_ptr;
    return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
  } else switch (CTYPE_PRIMLABEL(type)) {
    case FOREIGN_void: return scheme_void;
    case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
    case FOREIGN_uint8: return scheme_make_integer(REF_CTYPE(Tuint8));
    case FOREIGN_int16: return scheme_make_integer(REF_CTYPE(Tsint16));
    case FOREIGN_uint16: return scheme_make_integer(REF_CTYPE(Tuint16));
    case FOREIGN_int32: return scheme_make_realinteger_value(REF_CTYPE(Tsint32));
    case FOREIGN_uint32: return scheme_make_realinteger_value_from_unsigned(REF_CTYPE(Tuint32));
    case FOREIGN_int64: return scheme_make_integer_value_from_long_long(REF_CTYPE(Tsint64));
    case FOREIGN_uint64: return scheme_make_integer_value_from_unsigned_long_long(REF_CTYPE(Tuint64));
    case FOREIGN_fixint: return scheme_make_integer(REF_CTYPE(Tsint32));
    case FOREIGN_ufixint: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint32));
    case FOREIGN_fixnum: return scheme_make_integer(REF_CTYPE(intptr_t));
    case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(uintptr_t));
    case FOREIGN_float: return scheme_make_double(REF_CTYPE(float));
    case FOREIGN_double: return scheme_make_double(REF_CTYPE(double));
    case FOREIGN_longdouble: return scheme_make_maybe_long_double(REF_CTYPE(mz_long_double));
    case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
    case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
    case FOREIGN_stdbool: return (REF_CTYPE(stdbool)?scheme_true:scheme_false);
    case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
    case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
    case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
    case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
    case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
    case FOREIGN_pointer: return scheme_make_foreign_external_cpointer(REF_CTYPE(void*));
    case FOREIGN_gcpointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
    case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
    case FOREIGN_fpointer: return (REF_CTYPE(void*));
    case FOREIGN_struct:
    case FOREIGN_array:
    case FOREIGN_union:
      if (gcsrc)
        return scheme_make_foreign_offset_cpointer(src, delta);
      else
        return scheme_make_foreign_offset_external_cpointer(src, delta);
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  return NULL; /* hush the compiler */
}
#undef REF_CTYPE

static void *wrong_value(const char *who, const char *type, Scheme_Object *val)
{
  scheme_contract_error(who,
                        "given value does not fit primitive C type",
                        "C type", 0, type,
                        "given value", 1, val,
                        NULL);
  return NULL;
}

/* 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 or array) is returned, and the
 * basetype_p is set to the corresponding number tag.  If basetype_p is NULL,
 * then a struct or array value will be *copied* into dst. */
static void* SCHEME2C(const char *who,
                      Scheme_Object *type, void *dst, intptr_t delta,
                      Scheme_Object *val, GC_CAN_IGNORE intptr_t *basetype_p, GC_CAN_IGNORE intptr_t *_offset,
                      int ret_loc)
{
  /* redundant check:
     if (!SCHEME_CTYPEP(type))
       scheme_wrong_contract(who, "ctype?", 0, 1, &type); */
  while (CTYPE_USERP(type)) {
    GC_CAN_IGNORE Scheme_Object *f = CTYPE_USER_S2C(type);
    if (!SCHEME_FALSEP(f)) {
      if (SAME_TYPE(SCHEME_TYPE(f), scheme_native_closure_type))
        val = _scheme_apply_native(f, 1, (Scheme_Object**)(&val));
      else
        val = _scheme_apply(f, 1, (Scheme_Object**)(&val));
    }
    type = CTYPE_BASETYPE(type);
  }
  if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
    val = unwrap_cpointer_property(val);
    /* 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; */
      return wrong_value(who, "_fpointer", val);
  } else switch (CTYPE_PRIMLABEL(type)) {
    case FOREIGN_void:
      if (!ret_loc) return wrong_value(who, "_void", val);;
      break;
    case FOREIGN_int8:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint8)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tsint8));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tsint8)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(get_byte_val(val,&(((Tsint8*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int8", val);;
      return NULL;
    case FOREIGN_uint8:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint8)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tuint8));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tuint8)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(get_ubyte_val(val,&(((Tuint8*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint8", val);;
      return NULL;
    case FOREIGN_int16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint16)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tsint16));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tsint16)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(get_short_val(val,&(((Tsint16*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int16", val);;
      return NULL;
    case FOREIGN_uint16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint16)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tuint16));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tuint16)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(get_ushort_val(val,&(((Tuint16*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint16", val);;
      return NULL;
    case FOREIGN_int32:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tsint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tsint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int32", val);;
      return NULL;
    case FOREIGN_uint32:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tuint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tuint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint32", val);;
      return NULL;
    case FOREIGN_int64:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint64)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tsint64));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tsint64)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int64", val);;
      return NULL;
    case FOREIGN_uint64:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint64)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tuint64));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tuint64)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint64", val);;
      return NULL;
    case FOREIGN_fixint:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tsint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tsint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_INTP(val)) {
        Tsint32 tmp;
        tmp = MZ_TYPE_CAST(Tsint32, SCHEME_INT_VAL(val));
        (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_fixint", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_ufixint:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Tuint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Tuint32)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_INTP(val)) {
        Tuint32 tmp;
        tmp = MZ_TYPE_CAST(Tuint32, SCHEME_UINT_VAL(val));
        (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_ufixint", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_fixnum:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(intptr_t)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(intptr_t));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(intptr_t)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_INTP(val)) {
        intptr_t tmp;
        tmp = MZ_TYPE_CAST(intptr_t, SCHEME_INT_VAL(val));
        (((intptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_fixnum", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_ufixnum:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(uintptr_t)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(uintptr_t));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(uintptr_t)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_INTP(val)) {
        uintptr_t tmp;
        tmp = MZ_TYPE_CAST(uintptr_t, SCHEME_UINT_VAL(val));
        (((uintptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_ufixnum", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_float:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(float)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(float));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(float)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FLOATP(val)) {
        float tmp;
        tmp = MZ_TYPE_CAST(float, SCHEME_FLOAT_VAL(val));
        (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_float", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_double:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(double));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FLOATP(val)) {
        double tmp;
        tmp = MZ_TYPE_CAST(double, SCHEME_FLOAT_VAL(val));
        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_double", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_longdouble:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(mz_long_double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(mz_long_double));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(mz_long_double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_LONG_DBLP(val)) {
        mz_long_double tmp;
        tmp = MZ_NO_TYPE_CAST(mz_long_double, SCHEME_MAYBE_LONG_DBL_VAL(val));
        (((mz_long_double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_longdouble", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_doubleS:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(double));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(double)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_REALP(val)) {
        double tmp;
        tmp = MZ_TYPE_CAST(double, scheme_real_to_double(val));
        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_double*", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_bool:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(int)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(int));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(int)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (1) {
        int tmp;
        tmp = MZ_TYPE_CAST(int, SCHEME_TRUEP(val));
        (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_bool", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_stdbool:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(stdbool)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(stdbool));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(stdbool)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (1) {
        stdbool tmp;
        tmp = MZ_TYPE_CAST(stdbool, SCHEME_TRUEP(val));
        (((stdbool*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        return wrong_value(who, "_stdbool", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_string_ucs_4:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(mzchar*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(mzchar*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(mzchar*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
        mzchar* tmp;
        tmp = MZ_TYPE_CAST(mzchar*, ucs4_string_or_null_to_ucs4_pointer(val));
        if (basetype_p == NULL || tmp == NULL || 0) {
          (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_string_ucs_4;
          return tmp;
        }
      } else {
        return wrong_value(who, "_string/ucs-4", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_string_utf_16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(unsigned short*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(unsigned short*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(unsigned short*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
        unsigned short* tmp;
        tmp = MZ_TYPE_CAST(unsigned short*, ucs4_string_or_null_to_utf16_pointer(val));
        if (basetype_p == NULL || tmp == NULL || 0) {
          (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_string_utf_16;
          return tmp;
        }
      } else {
        return wrong_value(who, "_string/utf-16", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_bytes:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
        char* tmp;
        tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
        if (basetype_p == NULL || tmp == NULL || 0) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_bytes;
          return tmp;
        }
      } else {
        return wrong_value(who, "_bytes", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_path:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
        char* tmp;
        tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
        if (basetype_p == NULL || tmp == NULL || 0) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_path;
          return tmp;
        }
      } else {
        return wrong_value(who, "_path", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_symbol:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(char*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (SCHEME_SYMBOLP(val)) {
        char* tmp;
        tmp = MZ_TYPE_CAST(char*, SCHEME_SYM_VAL(val));
        if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_symbol;
          return tmp;
        }
      } else {
        return wrong_value(who, "_symbol", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_pointer:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(void*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      val = unwrap_cpointer_property(val);
      if (SCHEME_FFIANYPTRP(val)) {
        void* tmp; intptr_t toff;
        tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
        toff = SCHEME_FFIANYPTR_OFFSET(val);
        if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) {
          if (_offset) *_offset = 0;
          (((void**)W_OFFSET(dst,delta))[0]) = (void*)W_OFFSET(tmp, toff);;
          return NULL;
        } else {
          *basetype_p = FOREIGN_pointer;
          toff = SCHEME_FFIANYPTR_OFFSET(val);
          if (_offset) *_offset = toff;
          return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
        }
      } else {
        return wrong_value(who, "_pointer", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_gcpointer:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(void*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      val = unwrap_cpointer_property(val);
      if (SCHEME_FFIANYPTRP(val)) {
        void* tmp; intptr_t toff;
        tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
        toff = SCHEME_FFIANYPTR_OFFSET(val);
        if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) {
          if (_offset) *_offset = 0;
          (((void**)W_OFFSET(dst,delta))[0]) = (void*)W_OFFSET(tmp, toff);;
          return NULL;
        } else {
          *basetype_p = FOREIGN_gcpointer;
          toff = SCHEME_FFIANYPTR_OFFSET(val);
          if (_offset) *_offset = toff;
          return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
        }
      } else {
        return wrong_value(who, "_gcpointer", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_scheme:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Scheme_Object*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(Scheme_Object*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(Scheme_Object*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */

      if (1) {
        Scheme_Object* tmp;
        tmp = MZ_TYPE_CAST(Scheme_Object*, val);
        if (basetype_p == NULL || tmp == NULL || 0) {
          (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_scheme;
          return tmp;
        }
      } else {
        return wrong_value(who, "_scheme", val);;
        return NULL; /* hush the compiler */
      }
    case FOREIGN_fpointer:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(intptr_t)-sizeof(void*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
#     ifdef FFI_CALLBACK_NEED_INT_CLEAR
      if (sizeof(void*)<sizeof(intptr_t) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
      }
#     endif /* FFI_CALLBACK_NEED_INT_CLEAR */
      if (!(ret_loc)) return wrong_value(who, "_fpointer", val);;
      break;
    case FOREIGN_struct:
    case FOREIGN_array:
    case FOREIGN_union:
      val = unwrap_cpointer_property(val);
      if (!SCHEME_FFIANYPTRP(val)) {
        switch (CTYPE_PRIMLABEL(type)) {
        case FOREIGN_struct:
          return wrong_value(who, "(_struct ....)", val);
          break;
        case FOREIGN_array:
          return wrong_value(who, "(_array ....)", val);
          break;
        default:
        case FOREIGN_union:
          return wrong_value(who, "(_union ....)", val);
          break;
        }
      }
      {
        void* p = SCHEME_FFIANYPTR_VAL(val);
        intptr_t 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 = CTYPE_PRIMLABEL(type);
          if (_offset && is_gcable_pointer(val)) {
            *_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 */
#define MYNAME "ctype-sizeof"
static Scheme_Object *foreign_ctype_sizeof(int argc, Scheme_Object *argv[])
{
  intptr_t size;
  size = ctype_sizeof(argv[0]);
  if (size >= 0) return scheme_make_integer(size);
  else scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  return NULL; /* hush the compiler */
}
#undef MYNAME

/* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
#define MYNAME "ctype-alignof"
static Scheme_Object *foreign_ctype_alignof(int argc, Scheme_Object *argv[])
{
  Scheme_Object *type;
  type = get_ctype_base(argv[0]);
  if (type == NULL) scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
  else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
  return NULL; /* hush the compiler */
}
#undef MYNAME

/* (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.) */
#define MYNAME "compiler-sizeof"
static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
{
  int res=0;
  int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double, 6=wchar_t */
  int intsize = 0;  /* "short" => decrement, "long" => increment */
  int stars = 0;    /* number of "*"s */
  int must_list = 0;
  Scheme_Object *l = argv[0], *p;
  while (!SAME_OBJ(l, scheme_null)) {
    if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); must_list = 1;}
    else if (must_list) { p = scheme_false; l = scheme_null; }
    else { p = l; l = scheme_null; }
    if (!SCHEME_SYMBOLP(p)) {
      scheme_wrong_contract(MYNAME, "(or/c symbol? (listof symbol?))", 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),"wchar")) {
      if (basetype==0) basetype=6;
      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_contract(MYNAME, "(or/c ctype-symbol? (listof ctype-symbol?))", 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 /* INT64_AS_LONG_LONG undefined */
    case 2:  RETSIZE(long long int); break;
#   endif /* INT64_AS_LONG_LONG */
    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(mz_long_double);
    else scheme_signal_error(MYNAME": bad qualifiers for 'double");
    break;
  case 6: /* wchar_t */
    if (intsize==0) RETSIZE(wchar_t);
    else scheme_signal_error(MYNAME": cannot qualify 'wchar");
    break;
  default:
    scheme_signal_error(MYNAME": internal error (unexpected type %d)",
                        basetype);
  }
# undef RETSIZE
  return scheme_make_integer(res);
}
#undef MYNAME

/*****************************************************************************/
/* Pointer type user functions */

static Scheme_Malloc_Proc mode_to_allocator(const char *who, Scheme_Object *mode)
{
  Scheme_Malloc_Proc mf;

  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, interior_sym))      mf = scheme_malloc_allow_interior;
  else if (SAME_OBJ(mode, atomic_interior_sym)) mf = scheme_malloc_atomic_allow_interior;
  else if (SAME_OBJ(mode, raw_sym))           mf = malloc;
  else if (SAME_OBJ(mode, tagged_sym))        mf = scheme_malloc_tagged;
  else {
    scheme_signal_error("%s: bad allocation mode: %V", who, mode);
    return NULL; /* hush the compiler */
  }

  return mf;
}

static Scheme_Malloc_Proc ctype_allocator(Scheme_Object *type)
{
  Scheme_Object *mode;

  mode = CTYPE_BASETYPE(type);
  if (!SCHEME_PAIRP(mode))
    mode = atomic_sym;
  else {
    mode = SCHEME_CAR(mode);
    if (!SCHEME_SYMBOLP(mode))
      mode = atomic_sym;
  }

  return mode_to_allocator("_struct", mode);
}

/* (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, 'tagged,
 *   or '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. */
#define MYNAME "malloc"
static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
{
  int i, failok=0;
  intptr_t size=0, num=-1;
  void *from = NULL, *res = NULL;
  intptr_t foff = 0;
  Scheme_Object *mode = NULL, *a, *base = NULL;
  Scheme_Malloc_Proc mf;
  for (i=0; i<argc; i++) {
    a = unwrap_cpointer_property(argv[i]);
    if (SCHEME_INTP(a)) {
      if (num != -1)
        scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
      num = SCHEME_INT_VAL(a);
      if (num < 0)
        scheme_wrong_contract(MYNAME, "(and/c exact-nonnegative-integer? fixnum?)", 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_contract(MYNAME, "ctype?", i, argc, argv);
      size = ctype_sizeof(a);
      if (size <= 0)
        wrong_void(MYNAME, NULL, 0, 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);
      foff = SCHEME_FFIANYPTR_OFFSET(a);
    } else {
      scheme_wrong_contract(MYNAME,
                            "(or/c (and/c exact-nonnegative-integer? fixnum?)\n"
                            "      ctype?\n"
                            "      (or/c 'nonatomic 'stubborn 'uncollectable\n"
                            "             'eternal 'interior 'atomic-interior\n"
                            "             'tagged 'raw)\n"
                            "      'fail-on\n"
                            "      (and/c cpointer? (not/c #f)))",
                            i, argc, argv);
    }
  }
  if (!num) return scheme_false;
  if ((num == -1) && (size == 0)) scheme_signal_error(MYNAME": no size given");
  size = mult_check_overflow(MYNAME, ((size==0) ? 1 : size), ((num==-1) ? 1 : num));
  if (mode == NULL)
    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
      ? scheme_malloc : scheme_malloc_atomic;
  else
    mf = mode_to_allocator(MYNAME, mode);
  res = scheme_malloc_fail_ok(mf,size);
  if (failok && (res == NULL)) scheme_signal_error("malloc: out of memory");

  /* We might want to use foff as the object base address if from is NULL,
   * therefore set a src point to use in memcpy to clarify this */
  {
    void *src = NULL;
    if (from != NULL)
      src = W_OFFSET(from, foff);
    else if (foff != 0)
      src = (void *)foff;
    if (src != NULL && res != NULL)
      memcpy(res, src, size);
  }

  if (SAME_OBJ(mode, raw_sym))
    return scheme_make_foreign_external_cpointer(res);
  else
    return scheme_make_foreign_cpointer(res);
}
#undef MYNAME

#define NON_NULL_CPOINTER "(and/c cpointer? (not/c (lambda (p) (pointer-equal? p #f))))"

/* (end-stubborn-change ptr) */
#define MYNAME "end-stubborn-change"
static Scheme_Object *foreign_end_stubborn_change(int argc, Scheme_Object *argv[])
{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  scheme_end_stubborn_change(W_OFFSET(ptr, poff));
  return scheme_void;
}
#undef MYNAME

/* (free ptr) */
/* This is useful for raw-malloced objects, including objects from C libraries
 * that the library is mallocing itself. */
#define MYNAME "free"
static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  free(W_OFFSET(ptr, poff));
  return scheme_void;
}
#undef MYNAME

/* (malloc-immobile-cell v) */
#define MYNAME "malloc-immobile-cell"
static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
{
  void *p;
  p = scheme_malloc_immobile_box(argv[0]);
  return scheme_make_foreign_external_cpointer(p); /* <- beware: macro duplicates `p' */
}
#undef MYNAME

/* (free-immobile-cell b) */
#define MYNAME "free-immobile-cell"
static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[])
{
  void *ptr;
  intptr_t poff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  poff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
  return scheme_void;
}
#undef MYNAME

/* (ptr-add cptr offset-k [type])
 *   Adds an offset to a pointer, returning an offset_cpointer value
 * (ptr-add! cptr offset-k [type])
 *   Modifies an existing offset_cpointer value by adjusting its offset field,
 *   returns void
 */
static Scheme_Object *do_ptr_add(const char *who, int is_bang,
                                 int argc, Scheme_Object **argv)
{
  intptr_t noff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (is_bang) {
    if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
      scheme_wrong_contract(who, "offset-ptr?", 0, argc, argv);
  } else {
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "cpointer?", 0, argc, argv);
  }
  if (!scheme_get_int_val(argv[1], &noff))
    wrong_intptr(who, 1, argc, argv);
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      intptr_t size;
      size = ctype_sizeof(argv[2]);
      if (size < 0)
        scheme_wrong_contract(who, "ctype?", 2, argc, argv);
      if (size <= 0) wrong_void(who, NULL, 0, 2, argc, argv);
      noff = mult_check_overflow(who, noff, size);
    } else
      scheme_wrong_contract(who, "ctype?", 2, argc, argv);
  }
  if (is_bang) {
    intptr_t delta;
    delta = add_check_overflow(who, ((Scheme_Offset_Cptr*)(cp))->offset, noff);
    ((Scheme_Offset_Cptr*)(cp))->offset = delta;
    return scheme_void;
  } else {
    intptr_t delta;
    delta = add_check_overflow(who, SCHEME_FFIANYPTR_OFFSET(cp), noff);
    if (SCHEME_CPTRP(cp) && (SCHEME_CPTR_FLAGS(cp) & 0x1))
      return scheme_make_offset_external_cptr
        (SCHEME_FFIANYPTR_VAL(cp),
         delta,
         (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
    else
      return scheme_make_offset_cptr
        (SCHEME_FFIANYPTR_VAL(cp),
         delta,
         (SCHEME_CPTRP(cp)) ? SCHEME_CPTR_TYPE(cp) : NULL);
  }
}

/* (ptr-add cptr offset-k [type]) */
#define MYNAME "ptr-add"
static Scheme_Object *foreign_ptr_add(int argc, Scheme_Object *argv[])
{
  return do_ptr_add(MYNAME, 0, argc, argv);
}
#undef MYNAME
/* (ptr-add! cptr offset-k [type]) */
#define MYNAME "ptr-add!"
static Scheme_Object *foreign_ptr_add_bang(int argc, Scheme_Object *argv[])
{
  return do_ptr_add(MYNAME, 1, argc, argv);
}
#undef MYNAME

/* (offset-ptr? x) */
/* Returns #t if the argument is a cpointer with an offset */
#define MYNAME "offset-ptr?"
static Scheme_Object *foreign_offset_ptr_p(int argc, Scheme_Object *argv[])
{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  return (SCHEME_CPOINTER_W_OFFSET_P(cp)) ? scheme_true : scheme_false;
}
#undef MYNAME

/* (ptr-offset ptr) */
/* Returns the offset of a cpointer (0 if it's not an offset pointer) */
#define MYNAME "ptr-offset"
static Scheme_Object *foreign_ptr_offset(int argc, Scheme_Object *argv[])
{
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(cp));
}
#undef MYNAME

/* (set-ptr-offset! ptr offset [type]) */
/* Sets the offset of an offset-cpointer (possibly multiplied by the size of
 * the given ctype) */
#define MYNAME "set-ptr-offset!"
static Scheme_Object *foreign_set_ptr_offset_bang(int argc, Scheme_Object *argv[])
{
  intptr_t noff;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_CPOINTER_W_OFFSET_P(cp))
    scheme_wrong_contract(MYNAME, "offset-ptr?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1], &noff))
    wrong_intptr(MYNAME, 1, argc, argv);
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      intptr_t size;
      if (NULL == get_ctype_base(argv[2]))
        scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
      size = ctype_sizeof(argv[2]);
      if (size <= 0)
        wrong_void(MYNAME, NULL, 0, 2, argc, argv);
      noff = mult_check_overflow(MYNAME, noff, size);
    } else
      scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv);
  }
  ((Scheme_Offset_Cptr*)(cp))->offset = noff;
  return scheme_void;
}
#undef MYNAME

/* (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;
  intptr_t soff = 0, doff = 0, count, v, mult = 0;
  int i, j, ch = 0, argc1 = argc;
  Scheme_Object *cp;

  /* 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_contract(who, "ctype?", argc1, argc, argv);
    if (mult <= 0)
      wrong_void(who, NULL, 0, argc1, argc, argv);
  }

  /* get the count argument */
  argc1--;
  if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
    wrong_intptr(who, 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_contract(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 (!(i<argc1))
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%s: missing a pointer argument for %s",
                       who, (j == 0 ? "destination" : "source"));
    cp = unwrap_cpointer_property(argv[i]);
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "cpointer?", i, argc, argv);
    switch (j) {
    case 0: dest = SCHEME_FFIANYPTR_VAL(cp);
            doff = SCHEME_FFIANYPTR_OFFSET(cp);
            break;
    case 1: src  = SCHEME_FFIANYPTR_VAL(cp);
            soff = SCHEME_FFIANYPTR_OFFSET(cp);
            break;
    }
    i++;
    if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
      if (!scheme_get_int_val(argv[i], &v))
        wrong_intptr(who, i, argc, argv);
      if (mult) v *= mult;
      switch (j) {
      case 0: doff += v; break;
      case 1: soff += v; break;
      }
      i++;
    }
  }

  /* verify that there are no unused leftovers */
  if (!(i==argc1))
    scheme_arg_mismatch(who, "unexpected extra argument: ", argv[i]);

  switch (mode) {
  case 0: memset (W_OFFSET(dest, doff), ch, count); break;
  case 1: memmove(W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
  case 2: memcpy (W_OFFSET(dest, doff), W_OFFSET(src, soff), count); break;
  }

  return scheme_void;
}

#define MYNAME "vector->cpointer"
static Scheme_Object *foreign_vector_to_cpointer(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_VECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "vector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL);
}
#undef MYNAME

#define MYNAME "flvector->cpointer"
static Scheme_Object *foreign_flvector_to_cpointer(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_FLVECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "flvector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
}
#undef MYNAME

#define MYNAME "extflvector->cpointer"
static Scheme_Object *foreign_extflvector_to_cpointer(int argc, Scheme_Object *argv[])
{
# ifdef MZ_LONG_DOUBLE
  if (!SCHEME_EXTFLVECTORP(argv[0]))
    scheme_wrong_contract(MYNAME, "extflvector?", 0, argc, argv);
  return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_EXTFLVEC_ELS((Scheme_Object *)0x0), NULL);
# else /* MZ_LONG_DOUBLE undefined */
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                   MYNAME ": " NOT_SUPPORTED_STR);
  return NULL;
# endif /* MZ_LONG_DOUBLE */
}
#undef MYNAME

#define MYNAME "memset"
static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
{
  return do_memop(MYNAME, 0, argc, argv);
}
#undef MYNAME
#define MYNAME "memmove"
static Scheme_Object *foreign_memmove(int argc, Scheme_Object *argv[])
{
  return do_memop(MYNAME, 1, argc, argv);
}
#undef MYNAME
#define MYNAME "memcpy"
static Scheme_Object *foreign_memcpy(int argc, Scheme_Object *argv[])
{
  return do_memop(MYNAME, 2, argc, argv);
}
#undef MYNAME

static Scheme_Object *abs_sym;

/* (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. */
#define MYNAME "ptr-ref"
static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
{
  intptr_t size=0; void *ptr; Scheme_Object *base;
  intptr_t delta; int gcsrc=1;
  Scheme_Object *cp, *already_ptr = NULL;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  delta = SCHEME_FFIANYPTR_OFFSET(cp);
  if (!is_gcable_pointer(cp))
    gcsrc = 0;
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  size = ctype_sizeof(base);

  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
    if (SCHEME_FFIOBJP(cp)) {
      /* The ffiobj pointer is the function pointer. */
      ptr = cp;
      delta = (intptr_t)&(((ffi_obj_struct*)0x0)->obj);
      /* Helps propagate a function name from `ffi-obj' to `ffi-call': */
      already_ptr = cp;
    }
  }

  if (size < 0) {
    /* should not happen */
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  } else if (size == 0) {
    wrong_void(MYNAME, NULL, 0, 1, argc, argv);
  }

  if (argc > 3) {
    if (!SAME_OBJ(argv[2],abs_sym))
      scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
    if (!SCHEME_INTP(argv[3]))
      scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
    if (SCHEME_INT_VAL(argv[3])) {
      delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
      already_ptr = NULL;
    }
  } else if (argc > 2) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
    if (!size)
      scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
    if (SCHEME_INT_VAL(argv[2])) {
      delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
      already_ptr = NULL;
    }
  }
  return C2SCHEME(already_ptr, argv[1], ptr, delta, 0, gcsrc);
}
#undef MYNAME

Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv)
{
  return foreign_ptr_ref(argc, argv);
}

/* (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. */
#define MYNAME "ptr-set!"
static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
{
  intptr_t size=0; void *ptr;
  intptr_t delta;
  Scheme_Object *val = argv[argc-1], *base;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(cp);
  delta = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  size = ctype_sizeof(base);

  if (size < 0) {
    /* should not happen */
    scheme_wrong_contract(MYNAME, "ctype?", 1, argc, argv);
  } else if (size == 0) {
    wrong_void(MYNAME, NULL, 0, 1, argc, argv);
  }

  if (argc > 4) {
    if (!SAME_OBJ(argv[2],abs_sym))
      scheme_wrong_contract(MYNAME, "'abs", 2, argc, argv);
    if (!SCHEME_INTP(argv[3]))
      scheme_wrong_contract(MYNAME, "fixnum?", 3, argc, argv);
    delta = add_check_overflow(MYNAME, delta, SCHEME_INT_VAL(argv[3]));
  } else if (argc > 3) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_contract(MYNAME, "fixnum?", 2, argc, argv);
    if (!size)
      scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
    delta = add_check_overflow(MYNAME, delta, mult_check_overflow(MYNAME, size, SCHEME_INT_VAL(argv[2])));
  }
  SCHEME2C(MYNAME, argv[1], ptr, delta, val, NULL, NULL, 0);
  return scheme_void;
}
#undef MYNAME

void scheme_foreign_ptr_set(int argc, Scheme_Object **argv)
{
  (void)foreign_ptr_set_bang(argc, argv);
}

/* (ptr-equal? cpointer cpointer) -> boolean */
#define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
{
  Scheme_Object *cp1, *cp2;
  cp1 = unwrap_cpointer_property(argv[0]);
  cp2 = unwrap_cpointer_property(argv[1]);
  if (!SCHEME_FFIANYPTRP(cp1))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (!SCHEME_FFIANYPTRP(cp2))
    scheme_wrong_contract(MYNAME, "cpointer?", 1, argc, argv);
  return (SAME_OBJ(cp1, cp2) ||
          (SCHEME_FFIANYPTR_OFFSETVAL(cp1)
           == SCHEME_FFIANYPTR_OFFSETVAL(cp2)))
         ? scheme_true : scheme_false;
}
#undef MYNAME

/* (make-sized-byte-string cpointer len) */
#define MYNAME "make-sized-byte-string"
static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[])
{
  /* 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.) */
  intptr_t len;
  Scheme_Object *cp;
  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
  if (!scheme_get_int_val(argv[1],&len))
    wrong_intptr(MYNAME, 1, argc, argv);
  return scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(cp),
                                       len, 0);
}
#undef MYNAME

/*****************************************************************************/
/* FFI named locks */

THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
  Scheme_Object *vec;
  void *original_gc;
  original_gc = GC_switch_to_master_gc();
  vec = scheme_make_vector(count, val);
  GC_switch_back_from_master(original_gc);
  return vec;
}

static void **malloc_immobile_box_in_master(Scheme_Object *v)
{
  void **imm;
  void *original_gc;
  original_gc = GC_switch_to_master_gc();
  imm = scheme_malloc_immobile_box(v);
  GC_switch_back_from_master(original_gc);
  return imm;
}
#endif

static void *name_to_ffi_lock(Scheme_Object *bstr)
{
  Scheme_Object *lock;

  if (!ffi_lock_ht) {
    REGISTER_SO(ffi_lock_ht);
    ffi_lock_ht = scheme_make_hash_table_equal();
  }

  lock = scheme_hash_get(ffi_lock_ht, bstr);
  if (!lock) {
#   ifdef MZ_USE_PLACES
    /* implement the lock with a compare-and-swap with fallback (on
       contention) to a place channel; this strategy has minimal
       overhead when there's no contention, which is good for avoiding
       a penalty in the common case of a single place (but it's probably
       not the best strategy for a contended lock) */
    void *lock_box, *old_lock_box;

    lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), NULL);
    if (!lock_box) {
      lock = scheme_place_make_async_channel();
      lock = make_vector_in_master(2, lock);
      SCHEME_VEC_ELS(lock)[1] = scheme_make_integer(-1);
      lock_box = malloc_immobile_box_in_master(lock);
      old_lock_box = scheme_register_process_global(SCHEME_BYTE_STR_VAL(bstr), lock_box);
      if (old_lock_box) {
        scheme_free_immobile_box(lock_box);
        lock_box = old_lock_box;
      }
    }
    lock = *(Scheme_Object **)lock_box;
#   else /* MZ_USE_PLACES undefined */
    lock = scheme_make_sema(1);
#   endif /* MZ_USE_PLACES */
    scheme_hash_set(ffi_lock_ht, bstr, lock);
  }

  return lock;
}

static void wait_ffi_lock(Scheme_Object *lock)
{
# ifdef MZ_USE_PLACES
  while (1) {
    if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                 (uintptr_t)scheme_make_integer(-1),
                 (uintptr_t)scheme_make_integer(scheme_current_place_id))) {
      /* obtained lock the fast way */
      break;
    } else if (!scheme_place_can_receive()) {
      /* We can get here while trying to terminate a place and run
         custodian callbacks or other shutdown actions, and since
         the place is shutting down, we can't commuincate with other
         places; since we can't pause nicely, just spin */
    } else {
      Scheme_Object *owner, *new_val;
      owner = SCHEME_VEC_ELS(lock)[1];
      if (SCHEME_INT_VAL(owner) != -1) {
        if (SCHEME_INT_VAL(owner) < -1) {
          /* other processes waiting, and now there's one more: */
          new_val = scheme_make_integer(SCHEME_INT_VAL(owner)-1);
        } else {
          /* notify owner that another process is now waiting: */
          new_val = scheme_make_integer(-2);
        }
        if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                     (uintptr_t)owner,
                     (uintptr_t)new_val)) {
          /* wait for lock the slow way - without blocking other Racket threads */
          (void)scheme_place_async_channel_receive(SCHEME_VEC_ELS(lock)[0]);

          /* not waiting anymore: */
          while (1) {
            owner = SCHEME_VEC_ELS(lock)[1];
            if (SCHEME_INT_VAL(owner) == -2) {
              /* no other processes waiting */
              new_val = scheme_make_integer(scheme_current_place_id);
            } else {
              /* one less process waiting */
              new_val = scheme_make_integer(SCHEME_INT_VAL(owner)+1);
            }
            if (mzrt_cas((uintptr_t*)&(SCHEME_VEC_ELS(lock)[1]),
                         (uintptr_t)owner,
                         (uintptr_t)new_val)) {
              break;
            }
          }
          break;
        }
      }
    }
  }
# else /* MZ_USE_PLACES undefined */
  scheme_wait_sema(lock, 0);
# endif /* MZ_USE_PLACES */
}

static void release_ffi_lock(void *lock)
{
# ifdef MZ_USE_PLACES
  if (mzrt_cas((uintptr_t *)&(SCHEME_VEC_ELS(lock)[1]),
               (uintptr_t)scheme_make_integer(scheme_current_place_id),
               (uintptr_t)scheme_make_integer(-1))) {
    /* released lock with no other process waiting */
  } else {
    /* assert: SCHEME_VEC_ELS(lock)[1] holds a negative
       number corresponding to the number of waiting processes */
    scheme_place_async_channel_send(SCHEME_VEC_ELS(lock)[0], scheme_false);
  }
# else /* MZ_USE_PLACES undefined */
  scheme_post_sema(lock);
# endif /* MZ_USE_PLACES */
}

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

static int extract_varargs_after(const char *who, int argc, Scheme_Object **argv, int argpos, int nargs)
{
  int varargs_after;

  if (SCHEME_FALSEP(argv[argpos]))
    varargs_after = -1;
  else if (SCHEME_INTP(argv[argpos])
           && (SCHEME_INT_VAL(argv[argpos]) > 0)) {
    varargs_after = SCHEME_INT_VAL(argv[argpos]);
  } else if (SCHEME_BIGNUMP(argv[argpos])
             && SCHEME_BIGPOS((argv[argpos]))) {
    varargs_after = nargs + 1;
  } else {
    varargs_after = -1;
    scheme_wrong_contract(who, "(or/c exact-positive-integer? #f)", argpos, argc, argv);
  }
  if (varargs_after > nargs)
    scheme_contract_error(who, "varargs-after value is too large",
                          "given value", 1, argv[argpos],
                          "argument count", 1, scheme_make_integer(nargs),
                          NULL);

  return varargs_after;
}

/*****************************************************************************/
/* Calling foreign function objects */

#define MAX_QUICK_ARGS 16

typedef void(*VoidFun)(void);

#ifdef MZ_USE_PLACES

typedef struct FFI_Orig_Place_Call {
  int needs_queue;
  ffi_cif *cif;
  void *c_func;
  intptr_t cfoff;
  int nargs;
  ForeignAny *ivals;
  void **avalues;
  intptr_t *offsets;
  void *p;
  void **signal_handle;
  struct FFI_Orig_Place_Call *next, *prev;
} FFI_Orig_Place_Call;

static mzrt_mutex *orig_place_mutex;
static FFI_Orig_Place_Call *orig_place_calls, *orig_place_calls_tail;
static void *orig_place_signal_handle;

static void check_foreign_work(int check_for_in_original);

static void ffi_call_in_orig_place(ffi_cif *cif, void *c_func, intptr_t cfoff,
                                   int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                                   intptr_t *offsets, void *p)
/* This function can trigger a GC, but it won't escape --- unless
   the called function goes back to Racket and raises an exception,
   and raising an exception in a callback creates all sorts of
   other problems, anyway. No other Racket threads will run in the
   place, so it's ok for the arguments to have stack addresses. */
{
  FFI_Orig_Place_Call *todo;
  void *sh;
  int ready;

  if (cached_orig_place_todo) {
    todo = cached_orig_place_todo;
    cached_orig_place_todo = NULL;
  } else
    todo = (FFI_Orig_Place_Call *)malloc(sizeof(FFI_Orig_Place_Call));
  sh = scheme_get_signal_handle();
  todo->signal_handle = sh;
  todo->needs_queue = 1;

  /* It would be simplest to just block the current place while the
     original place handles the call. Unfortunately, something like a
     master GC might be required between now and when the call is
     handled. So, we have to block in an atomic-like way to minimize
     GCs while we wait, but still wake up on an external signal. */

  GC_check_master_gc_request();
  /* If a GC is needed from here on, a signal will be posted
     to the current place */

  while (1) {
    todo->cif = cif;
    todo->c_func = c_func;
    todo->cfoff = cfoff;
    todo->nargs = nargs;
    todo->ivals = ivals;
    todo->avalues = avalues;
    todo->offsets = offsets;
    todo->p = p;

    mzrt_mutex_lock(orig_place_mutex);
    if (todo->needs_queue) {
      todo->next = orig_place_calls;
      todo->prev = NULL;
      if (orig_place_calls)
        orig_place_calls->prev = todo;
      else
        orig_place_calls_tail = todo;
      orig_place_calls = todo;
      ready = 0;
    } else {
      ready = !todo->signal_handle;
    }
    mzrt_mutex_unlock(orig_place_mutex);

    if (!ready) {
      /* Tell original-place thread that there's work: */
      scheme_signal_received_at(orig_place_signal_handle);
      /* Wait for notificiation or a master-GC request: */
      scheme_wait_until_signal_received();
    }

    mzrt_mutex_lock(orig_place_mutex);
    if (!todo->signal_handle) {
      /* Done */
      mzrt_mutex_unlock(orig_place_mutex);
      if (!cached_orig_place_todo)
        cached_orig_place_todo = todo;
      else
        free(todo);
      break;
    } else {
      /* Pause to allow actions such as a master GC.... */
      if (todo->needs_queue) {
        /* Remove from queue while we might GC: */
        if (todo->prev)
          todo->prev->next = todo->next;
        else
          orig_place_calls = todo->next;
        if (todo->next)
          todo->next->prev = todo->prev;
        else
          orig_place_calls_tail = todo->prev;
      } else {
        /* The call is being handled, so it's too late
           to remove it from the queue! */
      }
      mzrt_mutex_unlock(orig_place_mutex);

      /* Here's the atomic pause: */
      GC_check_master_gc_request();
      scheme_start_atomic();
      scheme_thread_block(0.0);
      scheme_end_atomic_no_swap();

      /* Since we called scheme_thread_block() in atomic mode,
         it doesn't check for foreign callbacks. We'd like
         to handle those anyway, since the call in the original
         place may lead to a callback that should run in
         this place. */
#     ifndef MZ_USE_FFIPOLL
      check_foreign_work(0);
#     endif /* MZ_USE_FFIPOLL */
    }
  }
}
#endif

static void finish_ffi_call(ffi_cif *cif, void *c_func, intptr_t cfoff,
                            int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                            intptr_t *offsets, void *p)
/* Complete an FFI call in non-GC mode, so that arguments won't move around: */
  XFORM_SKIP_PROC
{
  int i;
  for (i=0; i<nargs; i++) {
    if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
      avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
    else if ((ivals[i].x_fixnum != FOREIGN_struct)
             && (ivals[i].x_fixnum != FOREIGN_union)) { /* 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]);
    } else if (offsets[i]) {
      /* struct argument has an offset */
      avalues[i] = (char *)avalues[i] + offsets[i];
    }
    /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
    /* Add offset, if any: */
    if (offsets[i] != 0) {
      ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i];
    }
  }
  /* Finally, call the function */
  ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
}

static void finish_ffi_call_handle_exn(ffi_cif *cif, void *c_func, intptr_t cfoff,
                                       int nargs, GC_CAN_IGNORE ForeignAny *ivals, void **avalues,
                                       intptr_t *offsets, void *p,
                                       Scheme_Object *lock)
{
  mz_jmp_buf * volatile save, fresh;

  save = scheme_current_thread->error_buf;
  scheme_current_thread->error_buf = &fresh;

  if (scheme_setjmp(scheme_error_buf)) {
    if (SCHEME_TRUEP(lock))
      release_ffi_lock(lock);
    scheme_end_in_scheduler();
    scheme_longjmp(*save, 1);
  } else {
    finish_ffi_call(cif, c_func, cfoff,
                    nargs, ivals, avalues,
                    offsets, p);
  }

  scheme_current_thread->error_buf = save;
}

static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object *self)
/* data := {name, c-function, itypes, otype, cif} */
{
  Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
  const char    *name = ((Scheme_Primitive_Closure *)self)->p.name;
  void          *c_func = (curried
                           ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1]
                           : (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]);
  intptr_t      cfoff   = (curried
                           ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2])
                           : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]));
  int           save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]);
  Scheme_Object *lock = SCHEME_VEC_ELS(data)[7];
  int           callback_exns = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[8]);
#ifdef MZ_USE_PLACES
  int           orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[9]);
#endif
  int           nargs /* = cif->nargs, after checking cif */;
  /* 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
   * Racket 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.)
   */
  ForeignAny *ivals;
  void **avalues, *p, *newp;
  GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS], oval;
  void *stack_avalues[MAX_QUICK_ARGS];
  intptr_t stack_offsets[MAX_QUICK_ARGS];
  int i;
  intptr_t basetype, offset, *offsets;
#ifdef MZ_USE_PLACES
  if (orig_place && (scheme_current_place_id == 0) && !MZ_USE_FFIPOLL_COND)
    orig_place = 0;
#endif
  if (!cif) {
    scheme_signal_error("ffi-call: foreign-function reference was already finalized%s%s",
                        name ? "\n  name: " : "",
                        name ? name : "");
    return NULL;
  }
  nargs =  cif->nargs;
  if ((nargs <= MAX_QUICK_ARGS)) {
    ivals   = stack_ivals;
    avalues = stack_avalues;
    offsets = stack_offsets;
  } else {
    ivals   = scheme_malloc_atomic_allow_interior(nargs * sizeof(ForeignAny));
    avalues = scheme_malloc(nargs * sizeof(void*));
    offsets = scheme_malloc_atomic(nargs * sizeof(intptr_t));
  }
  /* iterate on input values and types */
  for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
    /* convert argv[i] according to current itype */
    offset = 0;
    p = SCHEME2C(name, SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
                 &offset, 0);
    if ((p != NULL) || offset) {
      avalues[i] = p;
      ivals[i].x_fixnum = basetype; /* remember the base type */
    } else {
      avalues[i] = NULL;
    }
    offsets[i] = offset;
  }
  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)
      || (CTYPE_PRIMLABEL(base) == FOREIGN_union)) {
    /* need to have p be a pointer that is invisible to the GC */
    p = malloc(CTYPE_PRIMTYPE(base)->size);
    {
      Scheme_Malloc_Proc mf;
      mf = ctype_allocator(base);
      newp = mf(CTYPE_PRIMTYPE(base)->size);
    }
  } else {
    p = &oval;
    newp = NULL;
  }

  if (SCHEME_TRUEP(lock))
    wait_ffi_lock(lock);

#ifdef MZ_USE_PLACES
  if (orig_place)
    ffi_call_in_orig_place(cif, c_func, cfoff,
                           nargs, ivals, avalues,
                           offsets, p);
  else
#endif
    {
      if (callback_exns)
        finish_ffi_call_handle_exn(cif, c_func, cfoff,
                                   nargs, ivals, avalues,
                                   offsets, p, lock);
      else
        finish_ffi_call(cif, c_func, cfoff,
                        nargs, ivals, avalues,
                        offsets, p);
    }

  if (SCHEME_TRUEP(lock))
    release_ffi_lock(lock);

  /* Use `data' to make sure it's kept alive (as far as the GC is concerned)
     until the foreign call returns: */
  if ((void*)data == (void*)scheme_true)
    scheme_signal_error("dummy test succeeded!?");

  if (save_errno != 0) save_errno_values(save_errno);
  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_struct:
  case FOREIGN_union:
    memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
    free(p);
    p = newp;
    break;
  case FOREIGN_array:
    /* array as result is treated as a pointer, so
       adjust `p' to make C2SCHEME work right */
    p = *(void **)p;
    break;
  }
  return C2SCHEME(NULL, otype, p, 0, 1, 1);
}

static Scheme_Object *ffi_do_call_k()
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object **argv, *self;

  argv = (Scheme_Object **)p->ku.k.p1;
  self = (Scheme_Object *)p->ku.k.p2;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  return ffi_do_call(p->ku.k.i1, argv, self);
}

static Scheme_Object *ffi_do_call_after_stack_check(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  /* Make sure we have an extra-comfortable amount of space on the
     stack before calling into foreign code: */
  if (!scheme_no_stack_overflow && scheme_is_stack_too_shallow()) {
    Scheme_Thread *p = scheme_current_thread;
    p->ku.k.i1 = argc;
    p->ku.k.p1 = argv;
    p->ku.k.p2 = self;
    return scheme_handle_stack_overflow(ffi_do_call_k);
  } else
    return ffi_do_call(argc, argv, self);
}

/* see below */
void free_fficall_data(void *data, void *p)
{
  SCHEME_VEC_ELS(data)[4] = NULL;
  free(((ffi_cif*)p)->arg_types);
  free(p);
}

static Scheme_Object *ffi_name = NULL;

static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  Scheme_Object *a[3], *name, *itypes, *obj, *cp;
  const char *name_str;
  intptr_t ooff;
  int nargs;

  cp = unwrap_cpointer_property(argv[0]);
  if (!SCHEME_FFIANYPTRP(cp))
    scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv);
  obj = SCHEME_FFIANYPTR_VAL(cp);
  ooff = SCHEME_FFIANYPTR_OFFSET(cp);
  if ((obj == NULL) && (ooff == 0))
    scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv);

  name = SCHEME_VEC_ELS(data)[0];
  if (SCHEME_FFIOBJP(cp))
    name_str = ((ffi_obj_struct*)(cp))->name;
  else
    name_str = SCHEME_BYTE_STR_VAL(name);

  itypes = SCHEME_VEC_ELS(data)[2];

  nargs = scheme_proper_list_length(itypes);

  a[0] = data;
  a[1] = obj;
  a[2] = scheme_make_integer_value(ooff);

  return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check,
                                          3, a,
                                          name_str,
                                          nargs, nargs);

}

static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) {
# define ARGPOS(n) ((n) - (curry ? 1 : 0))
  Scheme_Object *itypes = argv[ARGPOS(1)];
  Scheme_Object *otype  = argv[ARGPOS(2)];
  Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1];
  ffi_abi abi;
  int varargs_after;
  intptr_t ooff;
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  int i, nargs, save_errno, callback_exns;
  Scheme_Object *lock = scheme_false;
  Scheme_Performance_State perf_state;
# ifdef MZ_USE_PLACES
  int orig_place = MZ_USE_FFIPOLL_COND;
# define FFI_CALL_VEC_SIZE 10
# else /* MZ_USE_PLACES undefined */
# define FFI_CALL_VEC_SIZE 9
# endif /* MZ_USE_PLACES */
  scheme_performance_record_start(&perf_state);
  if (!curry) {
    cp = unwrap_cpointer_property(argv[ARGPOS(0)]);
    if (!SCHEME_FFIANYPTRP(cp))
      scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv);
    obj = SCHEME_FFIANYPTR_VAL(cp);
    ooff = SCHEME_FFIANYPTR_OFFSET(cp);
    if ((obj == NULL) && (ooff == 0))
      scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv);
  } else {
    cp = NULL;
    obj = NULL;
    ooff = 0;
  }
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
  rtype = CTYPE_ARG_PRIMTYPE(base);
  abi = GET_ABI(who, ARGPOS(3));
  if (argc > ARGPOS(4)) {
    save_errno = -1;
    if (SCHEME_FALSEP(argv[ARGPOS(4)]))
      save_errno = 0;
    else if (SCHEME_SYMBOLP(argv[ARGPOS(4)])
             && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) {
      if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix"))
        save_errno = 1;
      else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows"))
        save_errno = 2;
    }
    if (save_errno == -1) {
      scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv);
    }
  } else
    save_errno = 0;
# if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)
  if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]);
  else orig_place = 0;
# endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */
  if (argc > ARGPOS(6)) {
    if (!SCHEME_FALSEP(argv[ARGPOS(6)])) {
      if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)]))
        scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv);
      lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)]));
    }
  }
  /* ARGPOS(7) is `blocking?`, but we don't use that */
  if (argc > ARGPOS(8)) {
    varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(8), nargs);
  } else
    varargs_after = -1;
  if (argc > ARGPOS(9))
    callback_exns = SCHEME_TRUEP(argv[ARGPOS(9)]);
  else
    callback_exns = 0;

  if (cp && SCHEME_FFIOBJP(cp))
    name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name);
  else
    name = ffi_name;
  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_contract(who, "(listof ctype?)", ARGPOS(1), argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      wrong_void(who, SCHEME_CAR(p), 1, ARGPOS(1), argc, argv);
    atypes[i] = CTYPE_ARG_PRIMTYPE(base);
  }
  cif = malloc(sizeof(ffi_cif));
  if (varargs_after == -1) {
    if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  } else {
    if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
  }
  data = scheme_make_vector(FFI_CALL_VEC_SIZE, NULL);
  SCHEME_VEC_ELS(data)[0] = name;
  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_VEC_ELS(data)[7] = lock;
  SCHEME_VEC_ELS(data)[8] = (callback_exns ? scheme_true : scheme_false);
# ifdef MZ_USE_PLACES
  SCHEME_VEC_ELS(data)[9] = (orig_place ? scheme_true : scheme_false);
# endif /* MZ_USE_PLACES */
  scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
  a[0] = data;

  scheme_performance_record_end("comp-ffi-call", &perf_state);

  if (curry) {
    return scheme_make_prim_closure_w_arity(make_ffi_call_from_curried,
                                            1, a,
                                            "make-ffi-call",
                                            1, 1);
  } else {
    return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check,
                                            1, a,
                                            SCHEME_BYTE_STR_VAL(name),
                                            nargs, nargs);
  }
#undef ARGPOS
}

/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (in-types -> out-value) */
/* the real work is done by ffi_do_call above */
#define MYNAME "ffi-call"
static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[])
{
  return ffi_call_or_curry(MYNAME, 0, argc, argv);
}
#undef MYNAME

/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking? varargs-after exns?]) -> (ffi->obj -> (in-types -> out-value)) */
/* Curried version of `ffi-call` */
#define MYNAME "ffi-call-maker"
static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[])
{
  return ffi_call_or_curry(MYNAME, 1, argc, argv);
}
#undef MYNAME

/*****************************************************************************/
/* Racket callbacks */

typedef void (*ffi_callback_t)(ffi_cif* cif, void* resultp, void** args, void *userdata);

static ffi_callback_struct *extract_ffi_callback(void *userdata)
  XFORM_SKIP_PROC
{
  ffi_callback_struct *data;

#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

  return data;
}

static 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, *t;

  data = extract_ffi_callback(userdata);

  if (argc <= MAX_QUICK_ARGS)
    argv = argv_stack;
  else
    argv = scheme_malloc(argc * sizeof(Scheme_Object*));
  if (data->sync && !SCHEME_PROCP(data->sync))
    scheme_start_in_scheduler();
  for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
    t = SCHEME_CAR(p);
    if (CTYPE_PRIMLABEL(get_ctype_base(t)) == FOREIGN_array) {
      /* array as argument is treated as a pointer */
      v = C2SCHEME(NULL, t, *(void **)(args[i]), 0, 0, 0);
    } else
      v = C2SCHEME(NULL, t, args[i], 0, 0, 0);
    argv[i] = v;
  }
  p = _scheme_apply(data->proc, argc, argv);
  SCHEME2C("callback result", data->otype, resultp, 0, p, NULL, NULL, 1);
  if (data->sync && !SCHEME_PROCP(data->sync))
    scheme_end_in_scheduler();
}

#ifdef MZ_USE_MZRT

/* When OS-level thread support is available, support callbacks
   in foreign threads that are executed on the main Racket thread. */

typedef struct Queued_Callback {
  ffi_cif* cif;
  void* resultp;
  void** args;
  void *userdata;
  mzrt_sema *sema;
  int called;
  struct Queued_Callback *next;
} Queued_Callback;

typedef struct FFI_Sync_Queue {
  Queued_Callback *callbacks; /* malloc()ed list */
  mzrt_mutex *lock;
  mzrt_os_thread_id orig_thread;
  void *sig_hand;
} FFI_Sync_Queue;

THREAD_LOCAL_DECL(static struct FFI_Sync_Queue *ffi_sync_queue);

static Scheme_Object *callback_thunk(void *_qc, int argc, Scheme_Object *argv[])
{
  Queued_Callback *qc = (Queued_Callback *)_qc;

  if (qc->called)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "callback thunk for synchronization has already been called");
  qc->called = 1;

  ffi_do_callback(qc->cif, qc->resultp, qc->args, qc->userdata);

  mzrt_sema_post(qc->sema);

  return scheme_void;
}

static void check_foreign_work(int check_for_in_original)
# ifdef MZ_USE_FFIPOLL
  XFORM_SKIP_PROC
# endif /* MZ_USE_FFIPOLL */
{
  GC_CAN_IGNORE Queued_Callback *qc;
  ffi_callback_struct *data;
  Scheme_Object *a[1], *proc;

#ifdef MZ_USE_FFIPOLL
  /* We don't currently support callbacks from C to Racket in FFIPOLL
     mode, and this function is not allowed to touch the GC or Racket
     in that mode. */
#else
  if (ffi_sync_queue) {
    do {
      mzrt_mutex_lock(ffi_sync_queue->lock);
      qc = ffi_sync_queue->callbacks;
      if (qc)
        ffi_sync_queue->callbacks = qc->next;
      mzrt_mutex_unlock(ffi_sync_queue->lock);

      if (qc) {
        qc->next = NULL;

        data = extract_ffi_callback(qc->userdata);

        proc = scheme_make_closed_prim_w_arity(callback_thunk, (void *)qc,
                                               "callback-thunk", 0, 0);
        a[0] = proc;

        proc = data->sync;
        if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc);

        scheme_start_in_scheduler();
        _scheme_apply(proc, 1, a);
        scheme_end_in_scheduler();
      }

    } while (qc);
  }
#endif

#ifdef MZ_USE_PLACES
  if (check_for_in_original && ((scheme_current_place_id == 0) || MZ_USE_FFIPOLL_COND) && orig_place_mutex) {
    FFI_Orig_Place_Call *todo;
    void *sh;

    while (1) {
      mzrt_mutex_lock(orig_place_mutex);
      todo = orig_place_calls_tail;
      if (todo) {
        orig_place_calls_tail = todo->prev;
        if (todo->prev)
          todo->prev->next = NULL;
        else
          orig_place_calls = NULL;
        todo->needs_queue = 0;
      }
      mzrt_mutex_unlock(orig_place_mutex);

      if (todo) {
        finish_ffi_call(todo->cif, todo->c_func, todo->cfoff,
                        todo->nargs, todo->ivals, todo->avalues,
                        todo->offsets, todo->p);
        mzrt_mutex_lock(orig_place_mutex);
        sh = todo->signal_handle;
        todo->signal_handle = NULL; /* indicates "done" */
        scheme_signal_received_at(sh);
        mzrt_mutex_unlock(orig_place_mutex);
      } else
        break;
    }
  }
#endif
}

void scheme_check_foreign_work(void)
# ifdef MZ_USE_FFIPOLL
  XFORM_SKIP_PROC
# endif /* MZ_USE_FFIPOLL */
{
  check_foreign_work(1);
}

#endif

static void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
  XFORM_SKIP_PROC
{
#ifdef MZ_USE_MZRT
  /* This function must not refer to any GCable address, not even
     temporarily, because a GC may occur concurrent to this
     function if it's in another thread. */
  FFI_Sync_Queue *queue;
  void **data = (void **)userdata;

  queue = (FFI_Sync_Queue *)(data)[1];
  userdata = (data)[0];

  if (queue->orig_thread != mz_proc_os_thread_self()) {
    if (data[2]) {
      /* constant result */
      memcpy(resultp, data[2], (intptr_t)data[3]);
      return;
    } else {
      /* queue  a callback and wait: */
      Queued_Callback *qc;
      mzrt_sema *sema;

      mzrt_sema_create(&sema, 0);

      qc = (Queued_Callback *)malloc(sizeof(Queued_Callback));
      qc->cif = cif;
      qc->resultp = resultp;
      qc->args = args;
      qc->userdata = userdata;
      qc->sema = sema;
      qc->called = 0;

      mzrt_mutex_lock(queue->lock);
      qc->next = queue->callbacks;
      queue->callbacks = qc;
      mzrt_mutex_unlock(queue->lock);
      scheme_signal_received_at(queue->sig_hand);

      /* wait for the callback to be invoked in the main thread */
      mzrt_sema_wait(sema);

      mzrt_sema_destroy(sema);
      free(qc);
      return;
    }
  }
#endif

  ffi_do_callback(cif, resultp, args, userdata);
}

/* 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 */
static 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);
}

#ifdef MZ_USE_MZRT
static void free_cl_cif_queue_args(void *ignored, void *p)
{
  void *data = ((closure_and_cif*)p)->data, *constant_result;
  void **q = (void **)data;
  data = q[0];
  constant_result = q[2];
  free(q);
  if (constant_result) free(constant_result);
#ifdef MZ_PRECISE_GC
  GC_free_immobile_box((void**)data);
#endif
  scheme_free_code(p);
}
#endif

/* In `curry` mode, just check arguments */
static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) {
# define ARGPOS(n) ((n) - (curry ? 1 : 0))
  ffi_callback_struct *data;
  Scheme_Object *itypes = argv[ARGPOS(1)];
  Scheme_Object *otype = argv[ARGPOS(2)];
  Scheme_Object *sync;
  Scheme_Object *p, *base;
  ffi_abi abi;
  int is_atomic;
  int nargs, i, varargs_after;
  ffi_status ffi_ok;
  /* 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 Racket 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                 :               |  \-----> Racket 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;
  GC_CAN_IGNORE ffi_callback_t do_callback;
  GC_CAN_IGNORE void *callback_data;
  Scheme_Performance_State perf_state;
# ifdef MZ_USE_MZRT
  int keep_queue = 0;
  void *constant_reply = NULL;
  int constant_reply_size = 0;
# endif /* MZ_USE_MZRT */

  if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)]))
    scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv);
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv);
  rtype = CTYPE_ARG_PRIMTYPE(base);
  abi = GET_ABI(who, ARGPOS(3));
  is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)]));
  sync = (is_atomic ? scheme_true : NULL);
  if ((argc > ARGPOS(5))
      && !SCHEME_BOXP(argv[ARGPOS(5)])
      && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1))
    scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv);
  if (argc > ARGPOS(6))
    varargs_after = extract_varargs_after(who, argc, argv, ARGPOS(6), nargs);
  else
    varargs_after = -1;

  if (curry) {
    /* all checks are done */
    return NULL;
  }

  scheme_performance_record_start(&perf_state);

  if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) {
#   ifdef MZ_USE_MZRT
    if (!ffi_sync_queue) {
      mzrt_os_thread_id tid;
      void *sig_hand;

      ffi_sync_queue = (FFI_Sync_Queue *)malloc(sizeof(FFI_Sync_Queue));
      tid = mz_proc_os_thread_self();
      ffi_sync_queue->orig_thread = tid;
      mzrt_mutex_create(&ffi_sync_queue->lock);
      sig_hand = scheme_get_signal_handle();
      ffi_sync_queue->sig_hand = sig_hand;
      ffi_sync_queue->callbacks = NULL;
    }
    if (SCHEME_BOXP(argv[ARGPOS(5)])) {
      /* when called in a foreign thread, return a constant */
      constant_reply_size = ctype_sizeof(otype);
      if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) {
        /* void result */
        constant_reply = scheme_malloc_atomic(1);
      } else {
        /* non-void result */
        constant_reply = scheme_malloc_atomic(constant_reply_size);
        SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0);
      }
    } else {
      /* when called in a foreign thread, queue a reply back here */
      sync = argv[ARGPOS(5)];
      if (is_atomic) sync = scheme_box(sync);
      constant_reply = NULL;
      constant_reply_size = 0;
    }
    keep_queue = 1;
#   endif /* MZ_USE_MZRT */
    do_callback = ffi_queue_callback;
  } else
    do_callback = ffi_do_callback;

  /* 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*));
  scheme_thread_code_start_write();
  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_thread_code_end_write();
      scheme_wrong_contract(who, "(listof ctype?)", ARGPOS(1), argc, argv);
    }
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void) {
      scheme_thread_code_end_write();
      wrong_void(who, SCHEME_CAR(p), 1, ARGPOS(1), argc, argv);
    }
    atypes[i] = CTYPE_ARG_PRIMTYPE(base);
  }
  if (varargs_after == -1) {
    if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  } else {
    if (ffi_prep_cif_var(cif, abi, varargs_after, nargs, rtype, atypes) != FFI_OK)
      scheme_signal_error("internal error: ffi_prep_cif_var did not return FFI_OK");
  }
  scheme_thread_code_end_write();
  data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct));
  data->so.type = ffi_callback_tag;
  data->callback = (cl_cif_args);
  data->proc = ((curry ? NULL : argv[ARGPOS(0)]));
  data->itypes = (argv[ARGPOS(1)]);
  data->otype = (argv[ARGPOS(2)]);
  data->sync = (sync);
# ifdef MZ_PRECISE_GC
  {
    /* put data in immobile, weak box */
    GC_CAN_IGNORE void **tmp;
    tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1));
    callback_data = (struct immobile_box*)tmp;
  }
# else /* MZ_PRECISE_GC undefined */
  callback_data = (void*)data;
# endif /* MZ_PRECISE_GC */
# ifdef MZ_USE_MZRT
  if (keep_queue) {
    /* For ffi_queue_callback(), add a level of indirection in `data' to
       hold the place-specific `ffi_sync_queue'.  Use
       `free_cl_cif_queue_args' to clean up this extra level. */
    GC_CAN_IGNORE void **tmp, *cr;
    if (constant_reply) {
      cr = malloc(constant_reply_size ? constant_reply_size : 1);
      memcpy(cr, constant_reply, constant_reply_size);
      constant_reply = cr;
    }
    tmp = (void **)malloc(sizeof(void*) * 4);
    tmp[0] = callback_data;
    tmp[1] = ffi_sync_queue;
    tmp[2] = constant_reply;
    tmp[3] = (void *)(intptr_t)constant_reply_size;
    callback_data = (void *)tmp;
  }
# endif /* MZ_USE_MZRT */
  scheme_thread_code_start_write();
  cl_cif_args->data = callback_data;
  ffi_ok = ffi_prep_closure_loc(cl, cif, do_callback, (void*)(cl_cif_args->data), cl);
  scheme_thread_code_end_write();
  if (ffi_ok != FFI_OK)
    scheme_signal_error
      ("internal error: ffi_prep_closure did not return FFI_OK");
# ifdef MZ_USE_MZRT
  if (keep_queue)
    scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args,
                              NULL, NULL);
  else
# endif /* MZ_USE_MZRT */
  scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);

  scheme_performance_record_end("comp-ffi-back", &perf_state);

  return (Scheme_Object*)data;
#undef ARGPOS
}

/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> 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 */
#define MYNAME "ffi-callback"
static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
{
  return ffi_callback_or_curry(MYNAME, 0, argc, argv);
}
#undef MYNAME

static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self)
{
  Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0];
  Scheme_Object *a[7];
  int c = SCHEME_VEC_SIZE(vec), i;

  for (i = 0; i < c; i++) {
    a[i+1] = SCHEME_VEC_ELS(vec)[i];
  }
  a[0] = argv[0];

  return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a);
}

/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */
/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything
   otherwise until a function is available. */
#define MYNAME "ffi-callback-maker"
static Scheme_Object *foreign_ffi_callback_maker(int argc, Scheme_Object *argv[])
{
  int i;
  Scheme_Object *vec, *a[1];

  (void)ffi_callback_or_curry(MYNAME, 1, argc, argv);

  vec = scheme_make_vector(argc, NULL);
  for (i = 0; i < argc; i++) {
    SCHEME_VEC_ELS(vec)[i] = argv[i];
  }
  a[0] = vec;

  return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried,
                                          1, a,
                                          "make-ffi-callback",
                                          1, 1);
}
#undef MYNAME

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

#ifdef WINDOWS_DYNAMIC_LOAD
typedef int *(*get_errno_ptr_t)(void);
static get_errno_ptr_t get_errno_ptr;
#endif /* WINDOWS_DYNAMIC_LOAD */

static void save_errno_values(int kind)
{
  Scheme_Thread *p = scheme_current_thread;

  if (kind == 2) {
    intptr_t v = 0;
#   ifdef WINDOWS_DYNAMIC_LOAD
    v = GetLastError();
#   endif /* WINDOWS_DYNAMIC_LOAD */
    p->saved_errno = v;
    return;
  }

# ifdef WINDOWS_DYNAMIC_LOAD
  /* Depending on how Racket is compiled and linked, `errno` might
     not corresponds to the one from "MSVCRT.dll", which is likely
     to be the one that foreign code uses. Go get that one via
     _errno(), which returns a pointer to the current thread's
     `errno`. */
  if (!get_errno_ptr) {
    HMODULE hm;
    hm = LoadLibrary("msvcrt.dll");
    if (hm) {
      get_errno_ptr = (get_errno_ptr_t)GetProcAddress(hm, "_errno");
    }
  }

  if (get_errno_ptr) {
    GC_CAN_IGNORE int *errno_ptr;
    errno_ptr = get_errno_ptr();
    errno = *errno_ptr;
  }
# endif /* WINDOWS_DYNAMIC_LOAD */

  p->saved_errno = errno;
}

#define MYNAME "saved-errno"
static Scheme_Object *foreign_saved_errno(int argc, Scheme_Object *argv[])
{
  Scheme_Thread *p = scheme_current_thread;
  if (argc == 0) {
    return scheme_make_integer_value(p->saved_errno);
  } else {
    intptr_t v;
    if (!scheme_get_int_val(argv[0], &v)) {
      wrong_intptr(MYNAME, 0, argc, argv);
    }
    p->saved_errno = v;
    return scheme_void;
  }
}
#undef MYNAME

#define MYNAME "lookup-errno"
static Scheme_Object *foreign_lookup_errno(int argc, Scheme_Object *argv[])
{
  Scheme_Object *v = argv[0];
  if (!SCHEME_SYMBOLP(v)) {
    scheme_wrong_contract(MYNAME, "symbol?", 0, argc, argv);
    return NULL;
  }
  if (SCHEME_SYM_WEIRDP(v))
    return scheme_false;
# ifdef E2BIG
  if (!strcmp("E2BIG", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(E2BIG);
# endif /* E2BIG */
# ifdef EACCES
  if (!strcmp("EACCES", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EACCES);
# endif /* EACCES */
# ifdef EADDRINUSE
  if (!strcmp("EADDRINUSE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EADDRINUSE);
# endif /* EADDRINUSE */
# ifdef EADDRNOTAVAIL
  if (!strcmp("EADDRNOTAVAIL", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EADDRNOTAVAIL);
# endif /* EADDRNOTAVAIL */
# ifdef EAFNOSUPPORT
  if (!strcmp("EAFNOSUPPORT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EAFNOSUPPORT);
# endif /* EAFNOSUPPORT */
# ifdef EAGAIN
  if (!strcmp("EAGAIN", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EAGAIN);
# endif /* EAGAIN */
# ifdef EALREADY
  if (!strcmp("EALREADY", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EALREADY);
# endif /* EALREADY */
# ifdef EBADF
  if (!strcmp("EBADF", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EBADF);
# endif /* EBADF */
# ifdef EBADMSG
  if (!strcmp("EBADMSG", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EBADMSG);
# endif /* EBADMSG */
# ifdef EBUSY
  if (!strcmp("EBUSY", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EBUSY);
# endif /* EBUSY */
# ifdef ECANCELED
  if (!strcmp("ECANCELED", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ECANCELED);
# endif /* ECANCELED */
# ifdef ECHILD
  if (!strcmp("ECHILD", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ECHILD);
# endif /* ECHILD */
# ifdef ECONNABORTED
  if (!strcmp("ECONNABORTED", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ECONNABORTED);
# endif /* ECONNABORTED */
# ifdef ECONNREFUSED
  if (!strcmp("ECONNREFUSED", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ECONNREFUSED);
# endif /* ECONNREFUSED */
# ifdef ECONNRESET
  if (!strcmp("ECONNRESET", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ECONNRESET);
# endif /* ECONNRESET */
# ifdef EDEADLK
  if (!strcmp("EDEADLK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EDEADLK);
# endif /* EDEADLK */
# ifdef EDESTADDRREQ
  if (!strcmp("EDESTADDRREQ", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EDESTADDRREQ);
# endif /* EDESTADDRREQ */
# ifdef EDOM
  if (!strcmp("EDOM", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EDOM);
# endif /* EDOM */
# ifdef EDQUOT
  if (!strcmp("EDQUOT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EDQUOT);
# endif /* EDQUOT */
# ifdef EEXIST
  if (!strcmp("EEXIST", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EEXIST);
# endif /* EEXIST */
# ifdef EFAULT
  if (!strcmp("EFAULT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EFAULT);
# endif /* EFAULT */
# ifdef EFBIG
  if (!strcmp("EFBIG", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EFBIG);
# endif /* EFBIG */
# ifdef EHOSTUNREACH
  if (!strcmp("EHOSTUNREACH", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EHOSTUNREACH);
# endif /* EHOSTUNREACH */
# ifdef EIDRM
  if (!strcmp("EIDRM", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EIDRM);
# endif /* EIDRM */
# ifdef EILSEQ
  if (!strcmp("EILSEQ", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EILSEQ);
# endif /* EILSEQ */
# ifdef EINPROGRESS
  if (!strcmp("EINPROGRESS", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EINPROGRESS);
# endif /* EINPROGRESS */
# ifdef EINTR
  if (!strcmp("EINTR", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EINTR);
# endif /* EINTR */
# ifdef EINVAL
  if (!strcmp("EINVAL", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EINVAL);
# endif /* EINVAL */
# ifdef EIO
  if (!strcmp("EIO", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EIO);
# endif /* EIO */
# ifdef EISCONN
  if (!strcmp("EISCONN", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EISCONN);
# endif /* EISCONN */
# ifdef EISDIR
  if (!strcmp("EISDIR", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EISDIR);
# endif /* EISDIR */
# ifdef ELOOP
  if (!strcmp("ELOOP", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ELOOP);
# endif /* ELOOP */
# ifdef EMFILE
  if (!strcmp("EMFILE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EMFILE);
# endif /* EMFILE */
# ifdef EMLINK
  if (!strcmp("EMLINK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EMLINK);
# endif /* EMLINK */
# ifdef EMSGSIZE
  if (!strcmp("EMSGSIZE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EMSGSIZE);
# endif /* EMSGSIZE */
# ifdef EMULTIHOP
  if (!strcmp("EMULTIHOP", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EMULTIHOP);
# endif /* EMULTIHOP */
# ifdef ENAMETOOLONG
  if (!strcmp("ENAMETOOLONG", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENAMETOOLONG);
# endif /* ENAMETOOLONG */
# ifdef ENETDOWN
  if (!strcmp("ENETDOWN", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENETDOWN);
# endif /* ENETDOWN */
# ifdef ENETRESET
  if (!strcmp("ENETRESET", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENETRESET);
# endif /* ENETRESET */
# ifdef ENETUNREACH
  if (!strcmp("ENETUNREACH", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENETUNREACH);
# endif /* ENETUNREACH */
# ifdef ENFILE
  if (!strcmp("ENFILE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENFILE);
# endif /* ENFILE */
# ifdef ENOBUFS
  if (!strcmp("ENOBUFS", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOBUFS);
# endif /* ENOBUFS */
# ifdef ENODATA
  if (!strcmp("ENODATA", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENODATA);
# endif /* ENODATA */
# ifdef ENODEV
  if (!strcmp("ENODEV", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENODEV);
# endif /* ENODEV */
# ifdef ENOENT
  if (!strcmp("ENOENT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOENT);
# endif /* ENOENT */
# ifdef ENOEXEC
  if (!strcmp("ENOEXEC", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOEXEC);
# endif /* ENOEXEC */
# ifdef ENOLCK
  if (!strcmp("ENOLCK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOLCK);
# endif /* ENOLCK */
# ifdef ENOLINK
  if (!strcmp("ENOLINK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOLINK);
# endif /* ENOLINK */
# ifdef ENOMEM
  if (!strcmp("ENOMEM", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOMEM);
# endif /* ENOMEM */
# ifdef ENOMSG
  if (!strcmp("ENOMSG", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOMSG);
# endif /* ENOMSG */
# ifdef ENOPROTOOPT
  if (!strcmp("ENOPROTOOPT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOPROTOOPT);
# endif /* ENOPROTOOPT */
# ifdef ENOSPC
  if (!strcmp("ENOSPC", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOSPC);
# endif /* ENOSPC */
# ifdef ENOSR
  if (!strcmp("ENOSR", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOSR);
# endif /* ENOSR */
# ifdef ENOSTR
  if (!strcmp("ENOSTR", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOSTR);
# endif /* ENOSTR */
# ifdef ENOSYS
  if (!strcmp("ENOSYS", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOSYS);
# endif /* ENOSYS */
# ifdef ENOTCONN
  if (!strcmp("ENOTCONN", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTCONN);
# endif /* ENOTCONN */
# ifdef ENOTDIR
  if (!strcmp("ENOTDIR", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTDIR);
# endif /* ENOTDIR */
# ifdef ENOTEMPTY
  if (!strcmp("ENOTEMPTY", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTEMPTY);
# endif /* ENOTEMPTY */
# ifdef ENOTRECOVERABLE
  if (!strcmp("ENOTRECOVERABLE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTRECOVERABLE);
# endif /* ENOTRECOVERABLE */
# ifdef ENOTSOCK
  if (!strcmp("ENOTSOCK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTSOCK);
# endif /* ENOTSOCK */
# ifdef ENOTSUP
  if (!strcmp("ENOTSUP", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTSUP);
# endif /* ENOTSUP */
# ifdef ENOTTY
  if (!strcmp("ENOTTY", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENOTTY);
# endif /* ENOTTY */
# ifdef ENXIO
  if (!strcmp("ENXIO", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ENXIO);
# endif /* ENXIO */
# ifdef EOPNOTSUPP
  if (!strcmp("EOPNOTSUPP", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EOPNOTSUPP);
# endif /* EOPNOTSUPP */
# ifdef EOVERFLOW
  if (!strcmp("EOVERFLOW", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EOVERFLOW);
# endif /* EOVERFLOW */
# ifdef EOWNERDEAD
  if (!strcmp("EOWNERDEAD", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EOWNERDEAD);
# endif /* EOWNERDEAD */
# ifdef EPERM
  if (!strcmp("EPERM", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EPERM);
# endif /* EPERM */
# ifdef EPIPE
  if (!strcmp("EPIPE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EPIPE);
# endif /* EPIPE */
# ifdef EPROTO
  if (!strcmp("EPROTO", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EPROTO);
# endif /* EPROTO */
# ifdef EPROTONOSUPPORT
  if (!strcmp("EPROTONOSUPPORT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EPROTONOSUPPORT);
# endif /* EPROTONOSUPPORT */
# ifdef EPROTOTYPE
  if (!strcmp("EPROTOTYPE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EPROTOTYPE);
# endif /* EPROTOTYPE */
# ifdef ERANGE
  if (!strcmp("ERANGE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ERANGE);
# endif /* ERANGE */
# ifdef EROFS
  if (!strcmp("EROFS", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EROFS);
# endif /* EROFS */
# ifdef ESPIPE
  if (!strcmp("ESPIPE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ESPIPE);
# endif /* ESPIPE */
# ifdef ESRCH
  if (!strcmp("ESRCH", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ESRCH);
# endif /* ESRCH */
# ifdef ESTALE
  if (!strcmp("ESTALE", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ESTALE);
# endif /* ESTALE */
# ifdef ETIME
  if (!strcmp("ETIME", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ETIME);
# endif /* ETIME */
# ifdef ETIMEDOUT
  if (!strcmp("ETIMEDOUT", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ETIMEDOUT);
# endif /* ETIMEDOUT */
# ifdef ETXTBSY
  if (!strcmp("ETXTBSY", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(ETXTBSY);
# endif /* ETXTBSY */
# ifdef EWOULDBLOCK
  if (!strcmp("EWOULDBLOCK", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EWOULDBLOCK);
# endif /* EWOULDBLOCK */
# ifdef EXDEV
  if (!strcmp("EXDEV", SCHEME_SYM_VAL(v)))
    return scheme_make_integer(EXDEV);
# endif /* EXDEV */
  return scheme_false;
}
#undef MYNAME

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

/* (make-late-will-executor) -> #<will-executor> */
#define MYNAME "make-late-will-executor"
static Scheme_Object *foreign_make_late_will_executor(int argc, Scheme_Object *argv[])
{
  return scheme_make_late_will_executor();
}
#undef MYNAME

/* (make-late-weak-box val) -> #<weak-box> */
#define MYNAME "make-late-weak-box"
static Scheme_Object *foreign_make_late_weak_box(int argc, Scheme_Object *argv[])
{
  return scheme_make_late_weak_box(argv[0]);
}
#undef MYNAME

/* (make-late-weak-hasheq) -> #<hash> */
#define MYNAME "make-late-weak-hasheq"
static Scheme_Object *foreign_make_late_weak_hasheq(int argc, Scheme_Object *argv[])
{
  return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr);
}
#undef MYNAME

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

void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
  char *str;
  if (CTYPE_PRIMP(ctype)) {
    scheme_print_bytes(pp, "#<ctype:", 0, 8);
    ctype = CTYPE_BASETYPE(ctype);
    if (SCHEME_SYMBOLP(ctype)) {
      str = SCHEME_SYM_VAL(ctype);
      scheme_print_bytes(pp, str, 0, strlen(str));
    } else {
      scheme_print_bytes(pp, "cstruct", 0, 7);
    }
    scheme_print_bytes(pp, ">", 0, 1);
  } else {
    scheme_print_bytes(pp, "#<ctype>", 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()
{
  ffi_lib_tag = scheme_make_type("<ffi-lib>");
  ffi_obj_tag = scheme_make_type("<ffi-obj>");
  ;
  ffi_callback_tag = scheme_make_type("<ffi-callback>");
# ifdef MZ_PRECISE_GC
  GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0);
  GC_register_traversers(ffi_obj_tag, ffi_obj_SIZE, ffi_obj_MARK, ffi_obj_FIXUP, 1, 0);
  GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0);
  GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
# endif /* MZ_PRECISE_GC */
  scheme_set_type_printer(scheme_ctype_type, ctype_printer);
  MZ_REGISTER_STATIC(nonatomic_sym);
  nonatomic_sym = scheme_intern_symbol("nonatomic");
  MZ_REGISTER_STATIC(atomic_sym);
  atomic_sym = scheme_intern_symbol("atomic");
  MZ_REGISTER_STATIC(stubborn_sym);
  stubborn_sym = scheme_intern_symbol("stubborn");
  MZ_REGISTER_STATIC(uncollectable_sym);
  uncollectable_sym = scheme_intern_symbol("uncollectable");
  MZ_REGISTER_STATIC(eternal_sym);
  eternal_sym = scheme_intern_symbol("eternal");
  MZ_REGISTER_STATIC(interior_sym);
  interior_sym = scheme_intern_symbol("interior");
  MZ_REGISTER_STATIC(atomic_interior_sym);
  atomic_interior_sym = scheme_intern_symbol("atomic-interior");
  MZ_REGISTER_STATIC(raw_sym);
  raw_sym = scheme_intern_symbol("raw");
  MZ_REGISTER_STATIC(tagged_sym);
  tagged_sym = scheme_intern_symbol("tagged");
  MZ_REGISTER_STATIC(fail_ok_sym);
  fail_ok_sym = scheme_intern_symbol("fail-ok");
  MZ_REGISTER_STATIC(default_sym);
  default_sym = scheme_intern_symbol("default");
  MZ_REGISTER_STATIC(stdcall_sym);
  stdcall_sym = scheme_intern_symbol("stdcall");
  MZ_REGISTER_STATIC(sysv_sym);
  sysv_sym = scheme_intern_symbol("sysv");
  MZ_REGISTER_STATIC(abs_sym);
  abs_sym = scheme_intern_symbol("abs");

  MZ_REGISTER_STATIC(ffi_name);
  ffi_name = scheme_make_byte_string("ffi:proc");
}

void scheme_init_foreign_places() {
  MZ_REGISTER_STATIC(opened_libs);
  opened_libs = scheme_make_hash_table(SCHEME_hash_string);
#ifdef MZ_USE_PLACES
  if (!orig_place_mutex) {
    mzrt_mutex_create(&orig_place_mutex);
    orig_place_signal_handle = scheme_get_signal_handle();
  }
#endif
}

static Scheme_Object *scheme_make_inline_noncm_prim(Scheme_Prim *prim,
                                                    const char *name,
                                                    mzshort mina, mzshort maxa)
{
  Scheme_Object *p;
  int flags = 0;

  p = scheme_make_noncm_prim(prim, name, mina, maxa);

  if ((mina <= 1) && (maxa >= 1))
   flags |= SCHEME_PRIM_IS_UNARY_INLINED;
  if ((mina <= 2) && (maxa >= 2))
   flags |= SCHEME_PRIM_IS_BINARY_INLINED;
  if ((mina <= 0) || (maxa > 2))
   flags |= SCHEME_PRIM_IS_NARY_INLINED;

  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);

  return p;
}

Scheme_Object *scheme_pointer_ctype;
Scheme_Object *scheme_float_ctype;
Scheme_Object *scheme_double_ctype;
Scheme_Object *scheme_int8_ctype;
Scheme_Object *scheme_uint8_ctype;
Scheme_Object *scheme_int16_ctype;
Scheme_Object *scheme_uint16_ctype;
Scheme_Object *scheme_int32_ctype;
Scheme_Object *scheme_uint32_ctype;
Scheme_Object *scheme_int64_ctype;
Scheme_Object *scheme_uint64_ctype;

void scheme_init_foreign(Scheme_Startup_Env *env)
{
  ctype_struct *t;
  Scheme_Object *s;
  memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
  scheme_switch_prim_instance(env, "#%foreign");
  scheme_addto_prim_instance("ffi-lib?",
    scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), env);
  scheme_addto_prim_instance("ffi-lib",
    scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), env);
  scheme_addto_prim_instance("ffi-lib-name",
    scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), env);
  scheme_addto_prim_instance("ffi-lib-unload",
    scheme_make_noncm_prim(foreign_ffi_lib_unload, "ffi-lib-unload", 1, 1), env);
  scheme_addto_prim_instance("ffi-obj?",
    scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), env);
  scheme_addto_prim_instance("ffi-obj",
    scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), env);
  scheme_addto_prim_instance("ffi-obj-lib",
    scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), env);
  scheme_addto_prim_instance("ffi-obj-name",
    scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), env);
  scheme_addto_prim_instance("ctype?",
    scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), env);
  scheme_addto_prim_instance("ctype-basetype",
    scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), env);
  scheme_addto_prim_instance("ctype-scheme->c",
    scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), env);
  scheme_addto_prim_instance("ctype-c->scheme",
    scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), env);
  scheme_addto_prim_instance("make-ctype",
    scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), env);
  scheme_addto_prim_instance("make-cstruct-type",
    scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 4), env);
  scheme_addto_prim_instance("make-array-type",
    scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), env);
  scheme_addto_prim_instance("make-union-type",
    scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), env);
  scheme_addto_prim_instance("ffi-callback?",
    scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), env);
  scheme_addto_prim_instance("cpointer?",
    scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), env);
  scheme_addto_prim_instance("cpointer-tag",
    scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), env);
  scheme_addto_prim_instance("set-cpointer-tag!",
    scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), env);
  scheme_addto_prim_instance("cpointer-gcable?",
    scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), env);
  scheme_addto_prim_instance("ctype-sizeof",
    scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), env);
  scheme_addto_prim_instance("ctype-alignof",
    scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), env);
  scheme_addto_prim_instance("compiler-sizeof",
    scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env);
  scheme_addto_prim_instance("malloc",
    scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), env);
  scheme_addto_prim_instance("end-stubborn-change",
    scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), env);
  scheme_addto_prim_instance("free",
    scheme_make_noncm_prim(foreign_free, "free", 1, 1), env);
  scheme_addto_prim_instance("malloc-immobile-cell",
    scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), env);
  scheme_addto_prim_instance("free-immobile-cell",
    scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), env);
  scheme_addto_prim_instance("ptr-add",
    scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), env);
  scheme_addto_prim_instance("ptr-add!",
    scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), env);
  scheme_addto_prim_instance("offset-ptr?",
    scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), env);
  scheme_addto_prim_instance("ptr-offset",
    scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), env);
  scheme_addto_prim_instance("set-ptr-offset!",
    scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), env);
  scheme_addto_prim_instance("vector->cpointer",
    scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), env);
  scheme_addto_prim_instance("flvector->cpointer",
    scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), env);
  scheme_addto_prim_instance("extflvector->cpointer",
    scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), env);
  scheme_addto_prim_instance("memset",
    scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), env);
  scheme_addto_prim_instance("memmove",
    scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), env);
  scheme_addto_prim_instance("memcpy",
    scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), env);
  scheme_addto_prim_instance("ptr-ref",
    scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), env);
  scheme_addto_prim_instance("ptr-set!",
    scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), env);
  scheme_addto_prim_instance("ptr-equal?",
    scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), env);
  scheme_addto_prim_instance("make-sized-byte-string",
    scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env);
  scheme_addto_prim_instance("ffi-call",
    scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 10), env);
  scheme_addto_prim_instance("ffi-call-maker",
    scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 9), env);
  scheme_addto_prim_instance("ffi-callback",
    scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env);
  scheme_addto_prim_instance("ffi-callback-maker",
    scheme_make_noncm_prim(foreign_ffi_callback_maker, "ffi-callback-maker", 2, 6), env);
  scheme_addto_prim_instance("saved-errno",
    scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), env);
  scheme_addto_prim_instance("lookup-errno",
    scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), env);
  scheme_addto_prim_instance("make-late-will-executor",
    scheme_make_immed_prim(foreign_make_late_will_executor, "make-late-will-executor", 0, 0), env);
  scheme_addto_prim_instance("make-late-weak-box",
    scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), env);
  scheme_addto_prim_instance("make-late-weak-hasheq",
    scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), env);
  s = scheme_intern_symbol("void");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
  scheme_addto_prim_instance("_void", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("int8");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
  REGISTER_SO(scheme_int8_ctype);
  scheme_int8_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_int8", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("uint8");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
  REGISTER_SO(scheme_uint8_ctype);
  scheme_uint8_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_uint8", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("int16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
  REGISTER_SO(scheme_int16_ctype);
  scheme_int16_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_int16", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("uint16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
  REGISTER_SO(scheme_uint16_ctype);
  scheme_uint16_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_uint16", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("int32");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
  REGISTER_SO(scheme_int32_ctype);
  scheme_int32_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_int32", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("uint32");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
  REGISTER_SO(scheme_uint32_ctype);
  scheme_uint32_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_uint32", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("int64");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
  REGISTER_SO(scheme_int64_ctype);
  scheme_int64_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_int64", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("uint64");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
  REGISTER_SO(scheme_uint64_ctype);
  scheme_uint64_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_uint64", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("fixint");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
  scheme_addto_prim_instance("_fixint", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("ufixint");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
  scheme_addto_prim_instance("_ufixint", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("fixnum");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzintptr));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
  scheme_addto_prim_instance("_fixnum", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("ufixnum");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzintptr));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
  scheme_addto_prim_instance("_ufixnum", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("float");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
  REGISTER_SO(scheme_float_ctype);
  scheme_float_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_float", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("double");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
  REGISTER_SO(scheme_double_ctype);
  scheme_double_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_double", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("longdouble");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_slongdouble));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_longdouble);
  scheme_addto_prim_instance("_longdouble", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("double*");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
  scheme_addto_prim_instance("_double*", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("bool");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
  scheme_addto_prim_instance("_bool", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("stdbool");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_stdbool));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_stdbool);
  scheme_addto_prim_instance("_stdbool", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("string/ucs-4");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
  scheme_addto_prim_instance("_string/ucs-4", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("string/utf-16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
  scheme_addto_prim_instance("_string/utf-16", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("bytes");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
  scheme_addto_prim_instance("_bytes", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("path");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
  scheme_addto_prim_instance("_path", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("symbol");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
  scheme_addto_prim_instance("_symbol", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("pointer");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
  REGISTER_SO(scheme_pointer_ctype);
  scheme_pointer_ctype = (Scheme_Object *)t;
  scheme_addto_prim_instance("_pointer", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("gcpointer");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer);
  scheme_addto_prim_instance("_gcpointer", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("scheme");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
  scheme_addto_prim_instance("_scheme", (Scheme_Object*)t, env);
  s = scheme_intern_symbol("fpointer");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
  scheme_addto_prim_instance("_fpointer", (Scheme_Object*)t, env);
  scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env);
  scheme_restore_prim_instance(env);
}

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

#else /* DONT_USE_FOREIGN */

int scheme_is_cpointer(Scheme_Object *cp)
{
  return (SCHEME_FALSEP(cp)
          || SCHEME_CPTRP(x)
          || SCHEME_BYTE_STRINGP(x)
          || (SCHEME_CHAPERONE_STRUCTP(cp)
              && scheme_struct_type_property_ref(scheme_cpointer_property, cp)));
}

static Scheme_Object *unimplemented(int argc, Scheme_Object **argv, Scheme_Object *who)
{
  scheme_signal_error("%s: foreign interface not supported for this platform",
                      ((Scheme_Primitive_Proc *)who)->name);
  return NULL;
}

static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object **argv)
{
  return scheme_make_integer(4);
}

static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object **argv)
{
  return scheme_false;
}

static Scheme_Object *foreign_make_late_will_executor(int argc, Scheme_Object *argv[])
{
  return scheme_make_late_will_executor();
}

void scheme_init_foreign(Scheme_Env *env)
{
  /* Create a dummy module. */
  scheme_switch_prim_instance(env, "#%foreign");
  scheme_addto_primitive_instance("ffi-lib?",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), env);
  scheme_addto_primitive_instance("ffi-lib",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), env);
  scheme_addto_primitive_instance("ffi-lib-name",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), env);
  scheme_addto_primitive_instance("ffi-lib-unload",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-unload", 1, 1), env);
  scheme_addto_primitive_instance("ffi-obj?",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), env);
  scheme_addto_primitive_instance("ffi-obj",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), env);
  scheme_addto_primitive_instance("ffi-obj-lib",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), env);
  scheme_addto_primitive_instance("ffi-obj-name",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), env);
  scheme_addto_primitive_instance("ctype?",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), env);
  scheme_addto_primitive_instance("ctype-basetype",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), env);
  scheme_addto_primitive_instance("ctype-scheme->c",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), env);
  scheme_addto_primitive_instance("ctype-c->scheme",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), env);
  scheme_addto_primitive_instance("make-ctype",
   scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), env);
  scheme_addto_primitive_instance("make-cstruct-type",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 4), env);
  scheme_addto_primitive_instance("make-array-type",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), env);
  scheme_addto_primitive_instance("make-union-type",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), env);
  scheme_addto_primitive_instance("ffi-callback?",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), env);
  scheme_addto_primitive_instance("cpointer?",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), env);
  scheme_addto_primitive_instance("cpointer-tag",
   scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), env);
  scheme_addto_primitive_instance("set-cpointer-tag!",
   scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), env);
  scheme_addto_primitive_instance("cpointer-gcable?",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), env);
  scheme_addto_primitive_instance("ctype-sizeof",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), env);
  scheme_addto_primitive_instance("ctype-alignof",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), env);
  scheme_addto_primitive_instance("compiler-sizeof",
   scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env);
  scheme_addto_primitive_instance("malloc",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), env);
  scheme_addto_primitive_instance("end-stubborn-change",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), env);
  scheme_addto_primitive_instance("free",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), env);
  scheme_addto_primitive_instance("malloc-immobile-cell",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), env);
  scheme_addto_primitive_instance("free-immobile-cell",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), env);
  scheme_addto_primitive_instance("ptr-add",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), env);
  scheme_addto_primitive_instance("ptr-add!",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), env);
  scheme_addto_primitive_instance("offset-ptr?",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), env);
  scheme_addto_primitive_instance("ptr-offset",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), env);
  scheme_addto_primitive_instance("set-ptr-offset!",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), env);
  scheme_addto_primitive_instance("vector->cpointer",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), env);
  scheme_addto_primitive_instance("flvector->cpointer",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), env);
  scheme_addto_primitive_instance("extflvector->cpointer",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), env);
  scheme_addto_primitive_instance("memset",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), env);
  scheme_addto_primitive_instance("memmove",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), env);
  scheme_addto_primitive_instance("memcpy",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), env);
  scheme_addto_primitive_instance("ptr-ref",
   scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), env);
  scheme_addto_primitive_instance("ptr-set!",
   scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), env);
  scheme_addto_primitive_instance("ptr-equal?",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), env);
  scheme_addto_primitive_instance("make-sized-byte-string",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env);
  scheme_addto_primitive_instance("ffi-call",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 10), env);
  scheme_addto_primitive_instance("ffi-call-maker",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 9), env);
  scheme_addto_primitive_instance("ffi-callback",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env);
  scheme_addto_primitive_instance("ffi-callback-maker",
   scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback-maker", 2, 6), env);
  scheme_addto_primitive_instance("saved-errno",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), env);
  scheme_addto_primitive_instance("lookup-errno",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), env);
  scheme_addto_primitive_instance("make-late-will-executor",
   scheme_make_immed_prim((Scheme_Prim *)foreign_make_late_will_executor, "make-late-will-executor", 0, 0), env);
  scheme_addto_primitive_instance("make-late-weak-box",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), env);
  scheme_addto_primitive_instance("make-late-weak-hasheq",
   scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), env);
  scheme_add_global_constant("_void", scheme_false, env);
  scheme_add_global_constant("_int8", scheme_false, env);
  scheme_add_global_constant("_uint8", scheme_false, env);
  scheme_add_global_constant("_int16", scheme_false, env);
  scheme_add_global_constant("_uint16", scheme_false, env);
  scheme_add_global_constant("_int32", scheme_false, env);
  scheme_add_global_constant("_uint32", scheme_false, env);
  scheme_add_global_constant("_int64", scheme_false, env);
  scheme_add_global_constant("_uint64", scheme_false, env);
  scheme_add_global_constant("_fixint", scheme_false, env);
  scheme_add_global_constant("_ufixint", scheme_false, env);
  scheme_add_global_constant("_fixnum", scheme_false, env);
  scheme_add_global_constant("_ufixnum", scheme_false, env);
  scheme_add_global_constant("_float", scheme_false, env);
  scheme_add_global_constant("_double", scheme_false, env);
  scheme_add_global_constant("_longdouble", scheme_false, env);
  scheme_add_global_constant("_double*", scheme_false, env);
  scheme_add_global_constant("_bool", scheme_false, env);
  scheme_add_global_constant("_stdbool", scheme_false, env);
  scheme_add_global_constant("_string/ucs-4", scheme_false, env);
  scheme_add_global_constant("_string/utf-16", scheme_false, env);
  scheme_add_global_constant("_bytes", scheme_false, env);
  scheme_add_global_constant("_path", scheme_false, env);
  scheme_add_global_constant("_symbol", scheme_false, env);
  scheme_add_global_constant("_pointer", scheme_false, env);
  scheme_add_global_constant("_gcpointer", scheme_false, env);
  scheme_add_global_constant("_scheme", scheme_false, env);
  scheme_add_global_constant("_fpointer", scheme_false, env);
  scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env);
  scheme_restore_prim_instance(env);
}

#endif