Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
foreign.c File Reference
#include "schpriv.h"
#include <dlfcn.h>
#include "ffi.h"

Go to the source code of this file.

Classes

struct  ffi_lib_struct
struct  ffi_obj_struct
union  _ForeignAny
struct  ctype_struct
struct  ffi_callback_struct
struct  closure_and_cif_struct

Defines

#define XFORM_OK_PLUS   +
#define GC_CAN_IGNORE   /* empty */
#define W_OFFSET(src, delta)   ((char *)(src) XFORM_OK_PLUS (delta))
#define TO_PATH(x)   (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))
#define SCHEME_FFILIBP(x)   (SCHEME_TYPE(x)==ffi_lib_tag)
#define MYNAME   "ffi-lib?"
#define MYNAME   "ffi-lib"
#define MYNAME   "ffi-lib-name"
#define SCHEME_FFIOBJP(x)   (SCHEME_TYPE(x)==ffi_obj_tag)
#define MYNAME   "ffi-obj?"
#define MYNAME   "ffi-obj"
#define MYNAME   "ffi-obj-lib"
#define MYNAME   "ffi-obj-name"
#define SCHEME_UINT_VAL(obj)   ((unsigned)(SCHEME_INT_VAL(obj)))
#define scheme_make_integer_from_unsigned(i)   ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1))
#define scheme_get_realint_val(x, y)   scheme_get_int_val(x,(long*)(y))
#define scheme_get_unsigned_realint_val(x, y)   scheme_get_unsigned_int_val(x,(unsigned long*)(y))
#define scheme_make_realinteger_value   scheme_make_integer_value
#define scheme_make_realinteger_value_from_unsigned   scheme_make_integer_value_from_unsigned
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o)   (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
#define FOREIGN_void   (1)
#define FOREIGN_int8   (2)
#define FOREIGN_uint8   (3)
#define FOREIGN_int16   (4)
#define FOREIGN_uint16   (5)
#define FOREIGN_int32   (6)
#define FOREIGN_uint32   (7)
#define FOREIGN_int64   (8)
#define FOREIGN_uint64   (9)
#define FOREIGN_fixint   (10)
#define FOREIGN_ufixint   (11)
#define ffi_type_smzlong   ffi_type_sint32
#define ffi_type_umzlong   ffi_type_uint32
#define FOREIGN_fixnum   (12)
#define FOREIGN_ufixnum   (13)
#define FOREIGN_float   (14)
#define FOREIGN_double   (15)
#define FOREIGN_doubleS   (16)
#define FOREIGN_bool   (17)
#define FOREIGN_string_ucs_4   (18)
#define FOREIGN_string_utf_16   (19)
#define FOREIGN_bytes   (20)
#define FOREIGN_path   (21)
#define FOREIGN_symbol   (22)
#define FOREIGN_pointer   (23)
#define FOREIGN_scheme   (24)
#define FOREIGN_fpointer   (25)
#define FOREIGN_struct   (26)
#define SCHEME_CTYPEP(x)   (SCHEME_TYPE(x)==ctype_tag)
#define MYNAME   "ctype?"
#define CTYPE_BASETYPE(x)   (((ctype_struct*)(x))->basetype)
#define CTYPE_USERP(x)   (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x)   (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x)   ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x)   ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x)   (((ctype_struct*)(x))->scheme_to_c)
#define CTYPE_USER_C2S(x)   (((ctype_struct*)(x))->c_to_scheme)
#define MYNAME   "ctype-basetype"
#define MYNAME   "ctype-scheme->c"
#define MYNAME   "ctype-c->scheme"
#define MYNAME   "make-ctype"
#define GET_ABI(name, n)   ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)
#define MYNAME   "make-cstruct-type"
#define SCHEME_FFICALLBACKP(x)   (SCHEME_TYPE(x)==ffi_callback_tag)
#define MYNAME   "ffi-callback?"
#define SCHEME_FFIANYPTRP(x)
#define SCHEME_FFIANYPTR_VAL(x)
#define SCHEME_FFIANYPTR_OFFSET(x)   (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x)   W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x))
#define SCHEME_CPOINTER_W_OFFSET_P(x)   SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type)
#define scheme_make_foreign_cpointer(x)   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
#define MYNAME   "cpointer?"
#define MYNAME   "cpointer-tag"
#define MYNAME   "set-cpointer-tag!"
#define C2SCHEME(typ, src, delta, argsloc)   c_to_scheme(typ,src,delta)
#define REF_CTYPE(ctype)   (((ctype *)W_OFFSET(src,delta))[0])
#define MYNAME   "ctype-sizeof"
#define MYNAME   "ctype-alignof"
#define MYNAME   "compiler-sizeof"
#define RETSIZE(t)   res=((stars==0)?sizeof(t):sizeof(t *))
#define MYNAME   "malloc"
#define MYNAME   "end-stubborn-change"
#define MYNAME   "free"
#define MYNAME   "malloc-immobile-cell"
#define MYNAME   "free-immobile-cell"
#define C_LONG_TYPE_STR   "exact integer that fits a C long"
#define MYNAME   "ptr-add"
#define MYNAME   "ptr-add!"
#define MYNAME   "offset-ptr?"
#define MYNAME   "ptr-offset"
#define MYNAME   "set-ptr-offset!"
#define MYNAME   "memset"
#define MYNAME   "memmove"
#define MYNAME   "memcpy"
#define MYNAME   "ptr-ref"
#define MYNAME   "ptr-set!"
#define MYNAME   "ptr-equal?"
#define MYNAME   "make-sized-byte-string"
#define MAX_QUICK_ARGS   16
#define MYNAME   "ffi-call"
#define MYNAME   "ffi-callback"

Typedefs

typedef struct ffi_lib_struct ffi_lib_struct
typedef struct ffi_obj_struct ffi_obj_struct
typedef union _ForeignAny ForeignAny
typedef struct ctype_struct ctype_struct
typedef struct ffi_callback_struct ffi_callback_struct
typedef void(* VoidFun )()
typedef struct
closure_and_cif_struct 
closure_and_cif

Functions

static Scheme_Objectforeign_ffi_lib_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_lib (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_lib_name (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_obj_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_obj (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_obj_lib (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_obj_name (int argc, Scheme_Object *argv[])
static mzcharucs4_string_or_null_to_ucs4_pointer (Scheme_Object *ucs)
static unsigned short * ucs4_string_to_utf16_pointer (Scheme_Object *ucs)
static unsigned short * ucs4_string_or_null_to_utf16_pointer (Scheme_Object *ucs)
Scheme_Objectutf16_pointer_to_ucs4_string (unsigned short *utf)
static Scheme_Objectforeign_ctype_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ctype_basetype (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ctype_scheme_to_c (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ctype_c_to_scheme (int argc, Scheme_Object *argv[])
static Scheme_Objectget_ctype_base (Scheme_Object *type)
static int ctype_sizeof (Scheme_Object *type)
static Scheme_Objectforeign_make_ctype (int argc, Scheme_Object *argv[])
void free_libffi_type (void *ignored, void *p)
ffi_abi sym_to_abi (char *who, Scheme_Object *sym)
static Scheme_Objectforeign_make_cstruct_type (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ffi_callback_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_cpointer_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_cpointer_tag (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_set_cpointer_tag_bang (int argc, Scheme_Object *argv[])
static Scheme_ObjectC2SCHEME (Scheme_Object *type, void *src, int delta, int args_loc)
static voidSCHEME2C (Scheme_Object *type, void *dst, long delta, Scheme_Object *val, long *basetype_p, long *_offset, int ret_loc)
static Scheme_Objectforeign_ctype_sizeof (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ctype_alignof (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_compiler_sizeof (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_malloc (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_end_stubborn_change (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_free (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_malloc_immobile_cell (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_free_immobile_cell (int argc, Scheme_Object *argv[])
static Scheme_Objectdo_ptr_add (const char *who, int is_bang, int argc, Scheme_Object **argv)
static Scheme_Objectforeign_ptr_add (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ptr_add_bang (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_offset_ptr_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ptr_offset (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_set_ptr_offset_bang (int argc, Scheme_Object *argv[])
static Scheme_Objectdo_memop (const char *who, int mode, int argc, Scheme_Object **argv)
static Scheme_Objectforeign_memset (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_memmove (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_memcpy (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ptr_ref (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ptr_set_bang (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_ptr_equal_p (int argc, Scheme_Object *argv[])
static Scheme_Objectforeign_make_sized_byte_string (int argc, Scheme_Object *argv[])
void do_scm_finalizer (void *p, void *finalizer)
void do_ptr_finalizer (void *p, void *finalizer)
Scheme_Objectffi_do_call (void *data, int argc, Scheme_Object *argv[])
void free_fficall_data (void *ignored, void *p)
static Scheme_Objectforeign_ffi_call (int argc, Scheme_Object *argv[])
void ffi_do_callback (ffi_cif *cif, void *resultp, void **args, void *userdata)
void free_cl_cif_args (void *ignored, void *p)
static Scheme_Objectforeign_ffi_callback (int argc, Scheme_Object *argv[])
void ctype_printer (Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
void scheme_init_foreign_globals ()
void scheme_init_foreign (Scheme_Env *env)

Variables

static Scheme_Type ffi_lib_tag
static Scheme_Hash_Tableopened_libs
static Scheme_Type ffi_obj_tag
static Scheme_Type ctype_tag
static Scheme_Objectdefault_sym
static Scheme_Objectstdcall_sym
static Scheme_Objectsysv_sym
static Scheme_Type ffi_callback_tag
static Scheme_Objectnonatomic_sym
static Scheme_Objectatomic_sym
static Scheme_Objectstubborn_sym
static Scheme_Objectuncollectable_sym
static Scheme_Objecteternal_sym
static Scheme_Objectinterior_sym
static Scheme_Objectatomic_interior_sym
static Scheme_Objectraw_sym
static Scheme_Objectfail_ok_sym
static Scheme_Objectabs_sym

Class Documentation

struct ffi_lib_struct

Definition at line 156 of file foreign.c.

Collaboration diagram for ffi_lib_struct:
Class Members
void * handle
Scheme_Object * name
Scheme_Hash_Table * objects
Scheme_Object so
struct ffi_obj_struct

Definition at line 266 of file foreign.c.

Collaboration diagram for ffi_obj_struct:
Class Members
ffi_lib_struct * lib
char * name
void * obj
Scheme_Object so
union _ForeignAny

Definition at line 797 of file foreign.c.

Collaboration diagram for _ForeignAny:
Class Members
int x_bool
char * x_bytes
double x_double
double x_doubleS
Tsint32 x_fixint
long x_fixnum
float x_float
void * x_fpointer
Tsint16 x_int16
Tsint32 x_int32
Tsint64 x_int64
Tsint8 x_int8
char * x_path
void * x_pointer
Scheme_Object * x_scheme
mzchar * x_string_ucs_4
unsigned short * x_string_utf_16
char * x_symbol
Tuint32 x_ufixint
unsigned long x_ufixnum
Tuint16 x_uint16
Tuint32 x_uint32
Tuint64 x_uint64
Tuint8 x_uint8
struct ctype_struct

Definition at line 843 of file foreign.c.

Collaboration diagram for ctype_struct:
Class Members
Scheme_Object * basetype
Scheme_Object * c_to_scheme
Scheme_Object * scheme_to_c
Scheme_Object so
struct ffi_callback_struct

Definition at line 1086 of file foreign.c.

Collaboration diagram for ffi_callback_struct:
Class Members
int call_in_scheduler
void * callback
Scheme_Object * itypes
Scheme_Object * otype
Scheme_Object * proc
Scheme_Object so
struct closure_and_cif_struct

Definition at line 2549 of file foreign.c.

Class Members
ffi_cif cif
ffi_closure closure
void * data

Define Documentation

#define C2SCHEME (   typ,
  src,
  delta,
  argsloc 
)    c_to_scheme(typ,src,delta)

Definition at line 1192 of file foreign.c.

#define C_LONG_TYPE_STR   "exact integer that fits a C long"

Definition at line 1930 of file foreign.c.

#define CTYPE_BASETYPE (   x)    (((ctype_struct*)(x))->basetype)

Definition at line 879 of file foreign.c.

#define CTYPE_PRIMLABEL (   x)    ((long)(((ctype_struct*)(x))->c_to_scheme))

Definition at line 883 of file foreign.c.

#define CTYPE_PRIMP (   x)    (!CTYPE_USERP(x))

Definition at line 881 of file foreign.c.

#define CTYPE_PRIMTYPE (   x)    ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))

Definition at line 882 of file foreign.c.

#define CTYPE_USER_C2S (   x)    (((ctype_struct*)(x))->c_to_scheme)

Definition at line 885 of file foreign.c.

#define CTYPE_USER_S2C (   x)    (((ctype_struct*)(x))->scheme_to_c)

Definition at line 884 of file foreign.c.

#define CTYPE_USERP (   x)    (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))

Definition at line 880 of file foreign.c.

#define ffi_type_smzlong   ffi_type_sint32

Definition at line 631 of file foreign.c.

#define ffi_type_umzlong   ffi_type_uint32

Definition at line 632 of file foreign.c.

#define FOREIGN_bool   (17)

Definition at line 692 of file foreign.c.

#define FOREIGN_bytes   (20)

Definition at line 729 of file foreign.c.

#define FOREIGN_double   (15)

Definition at line 670 of file foreign.c.

#define FOREIGN_doubleS   (16)

Definition at line 681 of file foreign.c.

#define FOREIGN_fixint   (10)

Definition at line 608 of file foreign.c.

#define FOREIGN_fixnum   (12)

Definition at line 639 of file foreign.c.

#define FOREIGN_float   (14)

Definition at line 660 of file foreign.c.

#define FOREIGN_fpointer   (25)

Definition at line 787 of file foreign.c.

#define FOREIGN_int16   (4)

Definition at line 545 of file foreign.c.

#define FOREIGN_int32   (6)

Definition at line 566 of file foreign.c.

#define FOREIGN_int64   (8)

Definition at line 587 of file foreign.c.

#define FOREIGN_int8   (2)

Definition at line 525 of file foreign.c.

#define FOREIGN_path   (21)

Definition at line 739 of file foreign.c.

#define FOREIGN_pointer   (23)

Definition at line 762 of file foreign.c.

#define FOREIGN_scheme   (24)

Definition at line 774 of file foreign.c.

#define FOREIGN_string_ucs_4   (18)

Definition at line 706 of file foreign.c.

#define FOREIGN_string_utf_16   (19)

Definition at line 716 of file foreign.c.

#define FOREIGN_struct   (26)

Definition at line 825 of file foreign.c.

#define FOREIGN_symbol   (22)

Definition at line 749 of file foreign.c.

#define FOREIGN_ufixint   (11)

Definition at line 619 of file foreign.c.

#define FOREIGN_ufixnum   (13)

Definition at line 650 of file foreign.c.

#define FOREIGN_uint16   (5)

Definition at line 555 of file foreign.c.

#define FOREIGN_uint32   (7)

Definition at line 577 of file foreign.c.

#define FOREIGN_uint64   (9)

Definition at line 597 of file foreign.c.

#define FOREIGN_uint8   (3)

Definition at line 535 of file foreign.c.

#define FOREIGN_void   (1)

Definition at line 515 of file foreign.c.

#define GC_CAN_IGNORE   /* empty */

Definition at line 73 of file foreign.c.

#define GET_ABI (   name,
 
)    ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI)

Definition at line 1026 of file foreign.c.

#define MAX_QUICK_ARGS   16

Definition at line 2334 of file foreign.c.

#define MYNAME   "ffi-lib?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-lib"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-lib-name"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-obj?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-obj"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-obj-lib"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-obj-name"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype-basetype"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype-scheme->c"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype-c->scheme"

Definition at line 2576 of file foreign.c.

#define MYNAME   "make-ctype"

Definition at line 2576 of file foreign.c.

#define MYNAME   "make-cstruct-type"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-callback?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "cpointer?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "cpointer-tag"

Definition at line 2576 of file foreign.c.

#define MYNAME   "set-cpointer-tag!"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype-sizeof"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ctype-alignof"

Definition at line 2576 of file foreign.c.

#define MYNAME   "compiler-sizeof"

Definition at line 2576 of file foreign.c.

#define MYNAME   "malloc"

Definition at line 2576 of file foreign.c.

#define MYNAME   "end-stubborn-change"

Definition at line 2576 of file foreign.c.

#define MYNAME   "free"

Definition at line 2576 of file foreign.c.

#define MYNAME   "malloc-immobile-cell"

Definition at line 2576 of file foreign.c.

#define MYNAME   "free-immobile-cell"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-add"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-add!"

Definition at line 2576 of file foreign.c.

#define MYNAME   "offset-ptr?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-offset"

Definition at line 2576 of file foreign.c.

#define MYNAME   "set-ptr-offset!"

Definition at line 2576 of file foreign.c.

#define MYNAME   "memset"

Definition at line 2576 of file foreign.c.

#define MYNAME   "memmove"

Definition at line 2576 of file foreign.c.

#define MYNAME   "memcpy"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-ref"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-set!"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ptr-equal?"

Definition at line 2576 of file foreign.c.

#define MYNAME   "make-sized-byte-string"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-call"

Definition at line 2576 of file foreign.c.

#define MYNAME   "ffi-callback"

Definition at line 2576 of file foreign.c.

#define REF_CTYPE (   ctype)    (((ctype *)W_OFFSET(src,delta))[0])

Definition at line 1193 of file foreign.c.

#define RETSIZE (   t)    res=((stars==0)?sizeof(t):sizeof(t *))

Definition at line 1145 of file foreign.c.

#define SCHEME_CTYPEP (   x)    (SCHEME_TYPE(x)==ctype_tag)

Definition at line 849 of file foreign.c.

Definition at line 466 of file foreign.c.

Definition at line 1140 of file foreign.c.

Definition at line 1142 of file foreign.c.

#define SCHEME_FFIANYPTR_VAL (   x)
Value:

Definition at line 1133 of file foreign.c.

#define SCHEME_FFIANYPTRP (   x)
Value:
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
   SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))

Definition at line 1130 of file foreign.c.

Definition at line 1094 of file foreign.c.

#define SCHEME_FFILIBP (   x)    (SCHEME_TYPE(x)==ffi_lib_tag)

Definition at line 162 of file foreign.c.

#define SCHEME_FFIOBJP (   x)    (SCHEME_TYPE(x)==ffi_obj_tag)

Definition at line 272 of file foreign.c.

#define scheme_get_realint_val (   x,
  y 
)    scheme_get_int_val(x,(long*)(y))

Definition at line 414 of file foreign.c.

#define scheme_get_unsigned_realint_val (   x,
  y 
)    scheme_get_unsigned_int_val(x,(unsigned long*)(y))

Definition at line 416 of file foreign.c.

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

Definition at line 1148 of file foreign.c.

#define scheme_make_integer_from_unsigned (   i)    ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1))

Definition at line 408 of file foreign.c.

Definition at line 418 of file foreign.c.

Definition at line 420 of file foreign.c.

#define SCHEME_UINT_VAL (   obj)    ((unsigned)(SCHEME_INT_VAL(obj)))

Definition at line 407 of file foreign.c.

#define TO_PATH (   x)    (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x))

Definition at line 79 of file foreign.c.

#define W_OFFSET (   src,
  delta 
)    ((char *)(src) XFORM_OK_PLUS (delta))

Definition at line 76 of file foreign.c.

#define XFORM_OK_PLUS   +

Definition at line 72 of file foreign.c.


Typedef Documentation

typedef union _ForeignAny ForeignAny
typedef void(* VoidFun)()

Definition at line 2336 of file foreign.c.


Function Documentation

static Scheme_Object* C2SCHEME ( Scheme_Object type,
void src,
int  delta,
int  args_loc 
) [static]

Definition at line 1196 of file foreign.c.

{
  Scheme_Object *res;
  if (!SCHEME_CTYPEP(type))
    scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
  if (CTYPE_USERP(type)) {
    res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
    if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
      return res;
    else
      return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
  } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
    return scheme_make_foreign_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_from_unsigned(REF_CTYPE(Tuint8));
    case FOREIGN_int16: return scheme_make_integer(REF_CTYPE(Tsint16));
    case FOREIGN_uint16: return scheme_make_integer_from_unsigned(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(long));
    case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(unsigned long));
    case FOREIGN_float: return scheme_make_float(REF_CTYPE(float));
    case FOREIGN_double: return scheme_make_double(REF_CTYPE(double));
    case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
    case FOREIGN_bool: return (REF_CTYPE(int)?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_cpointer(REF_CTYPE(void*));
    case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
    case FOREIGN_fpointer: return (REF_CTYPE(void*));
    case FOREIGN_struct:
           return scheme_make_foreign_cpointer(W_OFFSET(src, delta));
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  return NULL; /* hush the compiler */
}

Here is the call graph for this function:

void ctype_printer ( Scheme_Object ctype,
int  dis,
Scheme_Print_Params pp 
)

Definition at line 2669 of file foreign.c.

{
  char *str;
  if (!SCHEME_CTYPEP(ctype))
    scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
  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);
  }
}

Here is the caller graph for this function:

static int ctype_sizeof ( Scheme_Object type) [static]

Definition at line 926 of file foreign.c.

{
  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(long);
  case FOREIGN_ufixnum: return sizeof(unsigned long);
  case FOREIGN_float: return sizeof(float);
  case FOREIGN_double: return sizeof(double);
  case FOREIGN_doubleS: return sizeof(double);
  case FOREIGN_bool: return sizeof(int);
  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_scheme: return sizeof(Scheme_Object*);
  case FOREIGN_fpointer: return sizeof(void*);
  /* for structs */
  default: return CTYPE_PRIMTYPE(type)->size;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_memop ( const char *  who,
int  mode,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 2043 of file foreign.c.

{
  void *src = NULL, *dest = NULL;
  long soff = 0, doff = 0, count, v, mult = 0;
  int i, j, ch = 0, argc1 = argc;

  /* arg parsing: last optional ctype, then count, then fill byte for memset,
   * then the first and second pointer+offset pair. */

  /* get the optional last ctype multiplier */
  if (SCHEME_CTYPEP(argv[argc1-1])) {
    argc1--;
    mult = ctype_sizeof(argv[argc1]);
    if (mult <= 0)
      scheme_wrong_type(who, "non-void-C-type", argc1, argc, argv);
  }

  /* get the count argument */
  argc1--;
  if ((!scheme_get_int_val(argv[argc1], &count)) || (count < 0))
    scheme_wrong_type(who, "count as " C_LONG_TYPE_STR, argc1, argc, argv);
  if (mult) count *= mult;

  /* get the fill byte for memset */
  if (!mode) {
    argc1--;
    ch = SCHEME_INTP(argv[argc1]) ? SCHEME_INT_VAL(argv[argc1]) : -1;
    if ((ch < 0) || (ch > 255))
      scheme_wrong_type(who, "byte", argc1, argc, argv);
  }

  /* get the two pointers + offsets */
  i = 0;
  for (j=0; j<2; j++) {
    if (!mode && j==1) break; /* memset needs only a dest argument */
    if (!(i<argc1))
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%s: missing a pointer argument for %s",
                       who, (j == 0 ? "destination" : "source"));
    if (!SCHEME_FFIANYPTRP(argv[i]))
      scheme_wrong_type(who, "cpointer", i, argc, argv);
    switch (j) {
    case 0: dest = SCHEME_FFIANYPTR_VAL(argv[i]);
            doff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
            break;
    case 1: src  = SCHEME_FFIANYPTR_VAL(argv[i]);
            soff = SCHEME_FFIANYPTR_OFFSET(argv[i]);
            break;
    }
    i++;
    if ((i<argc1) && SCHEME_EXACT_INTEGERP(argv[i])) {
      if (!scheme_get_int_val(argv[i], &v))
        scheme_wrong_type(who, C_LONG_TYPE_STR, 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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_ptr_add ( const char *  who,
int  is_bang,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 1938 of file foreign.c.

{
  long noff;
  if (is_bang) {
    if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
      scheme_wrong_type(who, "offset-cpointer", 0, argc, argv);
  } else {
    if (!SCHEME_FFIANYPTRP(argv[0]))
      scheme_wrong_type(who, "cpointer", 0, argc, argv);
  }
  if (!scheme_get_int_val(argv[1], &noff))
    scheme_wrong_type(who, C_LONG_TYPE_STR, 1, argc, argv);
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      long size;
      size = ctype_sizeof(argv[2]);
      if (size <= 0) scheme_wrong_type(who, "non-void-C-type", 2, argc, argv);
      noff = noff * size;
    } else
      scheme_wrong_type(who, "C-type", 2, argc, argv);
  }
  if (is_bang) {
    ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
    return scheme_void;
  } else {
    return scheme_make_offset_cptr
             (SCHEME_FFIANYPTR_VAL(argv[0]),
              SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
              (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

void do_ptr_finalizer ( void p,
void finalizer 
)

Definition at line 2284 of file foreign.c.

{
  Scheme_Object *f = (Scheme_Object*)finalizer;
  Scheme_Object *ptr;
  if (p == NULL) return;
  ptr = scheme_make_cptr(p,NULL);
  if (!SCHEME_FALSEP(f)) _scheme_apply(f, 1, (Scheme_Object**)(&ptr));
  /* don't leave dangling references! */
  SCHEME_CPTR_VAL(ptr) = NULL;
  ptr = NULL;
}
void do_scm_finalizer ( void p,
void finalizer 
)

Definition at line 2279 of file foreign.c.

Scheme_Object* ffi_do_call ( void data,
int  argc,
Scheme_Object argv[] 
)

Definition at line 2338 of file foreign.c.

{
  /* The name is not currently used */
  /* char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); */
  void          *c_func = (void*)(SCHEME_VEC_ELS(data)[1]);
  Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2];
  Scheme_Object *otype  = SCHEME_VEC_ELS(data)[3];
  Scheme_Object *base;
  ffi_cif       *cif    = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]);
  long          cfoff   = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]);
  int           nargs   = cif->nargs;
  /* When the foreign function is called, we need an array (ivals) of nargs
   * ForeignAny objects to store the actual C values that are created, and we
   * need another array (avalues) for the pointers to these values (this is
   * what libffi actually uses).  To make things more fun, ForeignAny is
   * problematic for the precise GC, since it is sometimes a pointer and
   * sometime not.  To deal with this, while converting argv objects into
   * ivals, scheme_to_c will save pointer values in avalues, so the GC can,
   * ignore ivals -- just before we reach the actual call, avalues is
   * overwritten, but from that point on it is all C code so there is no
   * problem.  Hopefully.
   * (Things get complicated if the C call can involve GC (usually due to a
   * Scheme callback), but then the programmer need to arrange for pointers
   * that cannot move.  Because of all this, the *only* array that should not
   * be ignored by the GC is avalues.)
   */
  GC_CAN_IGNORE ForeignAny *ivals, oval;
  void **avalues, *p, *newp, *tmp;
  GC_CAN_IGNORE ForeignAny stack_ivals[MAX_QUICK_ARGS];
  void *stack_avalues[MAX_QUICK_ARGS];
  long stack_offsets[MAX_QUICK_ARGS];
  int i;
  long basetype, offset, *offsets;
  if (nargs <= MAX_QUICK_ARGS) {
    ivals   = stack_ivals;
    avalues = stack_avalues;
    offsets = stack_offsets;
  } else {
    ivals   = malloc(nargs * sizeof(ForeignAny));
    avalues = scheme_malloc(nargs * sizeof(void*));
    offsets = scheme_malloc(nargs * sizeof(long));
  }
  /* 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(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) {
    /* need to have p be a pointer that is invisible to the GC */
    p = malloc(CTYPE_PRIMTYPE(base)->size);
    newp = scheme_malloc_atomic(CTYPE_PRIMTYPE(base)->size);
  } else {
    p = &oval;
    newp = NULL;
  }
  /* We finished with all possible mallocs, clear up the avalues and offsets
   * mess */
  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) { /* if *not* a struct... */
      /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
      ivals[i].x_pointer = avalues[i];
      avalues[i] = &(ivals[i]);
    }
    /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
    /* 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);
  if (ivals != stack_ivals) free(ivals);
  ivals = NULL; /* no need now to hold on to this */
  for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
  avalues = NULL;
  switch (CTYPE_PRIMLABEL(base)) {
  case FOREIGN_struct:
    memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
    free(p);
    p = newp;
    break;
  default:
    /* not sure why this code is here, looks fine to remove this case */
    if (CTYPE_PRIMTYPE(base) == &ffi_type_pointer) {
      tmp = ((void**)p)[0];
      p = &tmp;
    }
    break;
  }
  return C2SCHEME(otype, p, 0, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void ffi_do_callback ( ffi_cif *  cif,
void resultp,
void **  args,
void userdata 
)

Definition at line 2516 of file foreign.c.

{
  ffi_callback_struct *data;
  Scheme_Object *argv_stack[MAX_QUICK_ARGS];
  int argc = cif->nargs, i;
  Scheme_Object **argv, *p, *v;
#ifdef MZ_PRECISE_GC
  {
    void *tmp;
    tmp  = *((void**)userdata);
    data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp));
    if (data == NULL) scheme_signal_error("callback lost");
  }
#else
  data = (ffi_callback_struct*)userdata;
#endif
  if (argc <= MAX_QUICK_ARGS)
    argv = argv_stack;
  else
    argv = scheme_malloc(argc * sizeof(Scheme_Object*));
  if (data->call_in_scheduler)
    scheme_start_in_scheduler();
  for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
    v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
    argv[i] = v;
  }
  p = _scheme_apply(data->proc, argc, argv);
  SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
  if (data->call_in_scheduler)
    scheme_end_in_scheduler();
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_compiler_sizeof ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1686 of file foreign.c.

{
  int res=0;
  int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */
  int intsize = 0;  /* "short" => decrement, "long" => increment */
  int stars = 0;    /* number of "*"s */
  Scheme_Object *l = argv[0], *p;
  while (!SAME_OBJ(l, scheme_null)) {
    if (SCHEME_PAIRP(l)) { p = SCHEME_CAR(l); l = SCHEME_CDR(l); }
    else { p = l; l = scheme_null; }
    if (!SCHEME_SYMBOLP(p)) {
      scheme_wrong_type(MYNAME, "list of symbols", 0, argc, argv);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"int")) {
      if (basetype==0) basetype=1;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"char")) {
      if (basetype==0) basetype=2;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"void")) {
      if (basetype==0) basetype=3;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"float")) {
      if (basetype==0) basetype=4;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"double")) {
      if (basetype==0 || basetype==4) basetype=5;
      else scheme_signal_error(MYNAME": extraneous type: %V", p);
    } else if (!strcmp(SCHEME_SYM_VAL(p),"short")) {
      if (intsize>0)
        scheme_signal_error(MYNAME": cannot use both 'short and 'long");
      else intsize--;
    } else if (!strcmp(SCHEME_SYM_VAL(p),"long")) {
      if (intsize<0)
        scheme_signal_error(MYNAME": cannot use both 'short and 'long");
      else intsize++;
    } else if (!strcmp(SCHEME_SYM_VAL(p),"*")) {
      stars++;
    } else {
      scheme_wrong_type(MYNAME, "list of C type symbols", 0, argc, argv);
    }
  }
  if (stars > 1)
    scheme_signal_error(MYNAME": cannot handle more than one '*");
  if (intsize < -1)
    scheme_signal_error(MYNAME": cannot handle more than one 'short");
  if (intsize > 2)
    scheme_signal_error(MYNAME": cannot handle more than two 'long");
  if (basetype == 0) basetype = 1; /* int is the default type */
  /* don't assume anything, so it can be used to verify compiler assumptions */
  /* (only forbid stuff that the compiler doesn't allow) */
# define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))
  switch (basetype) {
  case 1: /* int */
    switch (intsize) {
    case 0:  RETSIZE(int); break;
    case 1:  RETSIZE(long int); break;
#   ifdef INT64_AS_LONG_LONG
    case 2:  RETSIZE(_int64); break; /* MSVC doesn't allow long long */
#   else /* 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(void);
    else if (stars==0)
      scheme_signal_error(MYNAME": cannot use 'void without a '*");
    else scheme_signal_error(MYNAME": cannot qualify 'void");
    break;
  case 4: /* float */
    if (intsize==0) RETSIZE(float);
    else scheme_signal_error(MYNAME": bad qualifiers for 'float");
    break;
  case 5: /* double */
    if (intsize==0) RETSIZE(double);
    else if (intsize==1) RETSIZE(long double);
    else scheme_signal_error(MYNAME": bad qualifiers for 'double");
    break;
  default:
    scheme_signal_error(MYNAME": internal error (unexpected type %d)",
                        basetype);
  }
# undef RETSIZE
  return scheme_make_integer(res);
}

Here is the caller graph for this function:

static Scheme_Object* foreign_cpointer_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1152 of file foreign.c.

{
  return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_cpointer_tag ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1159 of file foreign.c.

{
  Scheme_Object *tag = NULL;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  if (SCHEME_CPTRP(argv[0])) tag = SCHEME_CPTR_TYPE(argv[0]);
  return (tag == NULL) ? scheme_false : tag;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_alignof ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1671 of file foreign.c.

{
  Scheme_Object *type;
  type = get_ctype_base(argv[0]);
  if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
  else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment);
  return NULL; /* hush the compiler */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_basetype ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 889 of file foreign.c.

{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
  return CTYPE_BASETYPE(argv[0]);
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_c_to_scheme ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 908 of file foreign.c.

{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->c_to_scheme;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 851 of file foreign.c.

{
  return SCHEME_CTYPEP(argv[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_scheme_to_c ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 898 of file foreign.c.

{
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
  return (CTYPE_PRIMP(argv[0])) ? scheme_false :
           ((ctype_struct*)(argv[0]))->scheme_to_c;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ctype_sizeof ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1659 of file foreign.c.

{
  int size;
  size = ctype_sizeof(argv[0]);
  if (size >= 0) return scheme_make_integer(size);
  else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
  return NULL; /* hush the compiler */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_end_stubborn_change ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1871 of file foreign.c.

{
  void *ptr;
  long poff;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  scheme_end_stubborn_change(W_OFFSET(ptr, poff));
  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_call ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2456 of file foreign.c.

{
  static Scheme_Object *ffi_name_prefix = NULL;
  Scheme_Object *itypes = argv[1];
  Scheme_Object *otype  = argv[2];
  Scheme_Object *obj, *data, *p, *base;
  ffi_abi abi;
  long ooff;
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  int i, nargs;
  MZ_REGISTER_STATIC(ffi_name_prefix);
  if (!ffi_name_prefix)
    ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:");
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv);
  obj = SCHEME_FFIANYPTR_VAL(argv[0]);
  ooff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((obj == NULL) && (ooff == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
  rtype = CTYPE_PRIMTYPE(base);
  abi = GET_ABI(MYNAME,3);
  atypes = malloc(nargs * sizeof(ffi_type*));
  for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
    atypes[i] = CTYPE_PRIMTYPE(base);
  }
  cif = malloc(sizeof(ffi_cif));
  if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  data = scheme_make_vector(6, NULL);
  p = scheme_append_byte_string
        (ffi_name_prefix,
         scheme_make_byte_string_without_copying
           (SCHEME_FFIOBJP(argv[0]) ?
             ((ffi_obj_struct*)(argv[0]))->name : "proc"));
  SCHEME_VEC_ELS(data)[0] = p;
  SCHEME_VEC_ELS(data)[1] = obj;
  SCHEME_VEC_ELS(data)[2] = itypes;
  SCHEME_VEC_ELS(data)[3] = otype;
  SCHEME_VEC_ELS(data)[4] = (Scheme_Object*)cif;
  SCHEME_VEC_ELS(data)[5] = scheme_make_integer(ooff);
  scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
  return scheme_make_closed_prim_w_arity
           (ffi_do_call, (void*)data, SCHEME_BYTE_STR_VAL(p),
            nargs, nargs);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_callback ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2577 of file foreign.c.

{
  ffi_callback_struct *data;
  Scheme_Object *itypes = argv[1];
  Scheme_Object *otype = argv[2];
  Scheme_Object *p, *base;
  ffi_abi abi;
  int nargs, i;
  /* ffi_closure objects are problematic when used with a moving GC.  The
   * problem is that memory that is GC-visible can move at any time.  The
   * solution is to use an immobile-box, which an immobile pointer (in a simple
   * malloced block), which points to the ffi_callback_struct that contains the
   * relevant Scheme call details.  Another minor complexity is that an
   * immobile box serves as a reference for the GC, which means that nothing
   * will ever get collected: and the solution for this is to stick a weak-box
   * in the chain.  Users need to be aware of GC issues, and need to keep a
   * reference to the callback object to avoid releasing the whole thing --
   * when that reference is lost, the ffi_callback_struct will be GCed, and a
   * finalizer will free() the malloced memory.  Everything on the malloced
   * part is allocated in one block, to make it easy to free.  The final layout
   * of the various objects is:
   *
   * <<======malloc======>> : <<===========scheme_malloc===============>>
   *                        :
   *    ffi_closure <------------------------\
   *      |  |              :                |
   *      |  |              :                |
   *      |  \--> immobile ----> weak        |
   *      |         box     :    box         |
   *      |                 :     |          |
   *      |                 :     |          |
   *      |                 :     \--> ffi_callback_struct
   *      |                 :               |  |
   *      V                 :               |  \-----> Scheme Closure
   *     cif ---> atypes    :               |
   *                        :               \--------> input/output types
   */
  GC_CAN_IGNORE ffi_type *rtype, **atypes;
  GC_CAN_IGNORE ffi_cif *cif;
  GC_CAN_IGNORE ffi_closure *cl;
  GC_CAN_IGNORE closure_and_cif *cl_cif_args;
  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_type(MYNAME, "procedure", 0, argc, argv);
  nargs = scheme_proper_list_length(itypes);
  if (nargs < 0)
    scheme_wrong_type(MYNAME, "proper list", 1, argc, argv);
  if (NULL == (base = get_ctype_base(otype)))
    scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
  rtype = CTYPE_PRIMTYPE(base);
  abi = GET_ABI(MYNAME,3);
  /* malloc space for everything needed, so a single free gets rid of this */
  cl_cif_args = scheme_malloc_code(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
  cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
  cif = &(cl_cif_args->cif);
  atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));
  for (i=0, p=itypes; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 1, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv);
    atypes[i] = CTYPE_PRIMTYPE(base);
  }
  if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
    scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
  data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct));
  data->so.type = ffi_callback_tag;
  data->callback = (cl_cif_args);
  data->proc = (argv[0]);
  data->itypes = (argv[1]);
  data->otype = (argv[2]);
  data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
# ifdef MZ_PRECISE_GC
  {
    /* put data in immobile, weak box */
    void **tmp;
    tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0));
    cl_cif_args->data = (struct immobile_box*)tmp;
  }
# else /* MZ_PRECISE_GC undefined */
  cl_cif_args->data = (void*)data;
# endif /* MZ_PRECISE_GC */
  if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data))
      != FFI_OK)
    scheme_signal_error
      ("internal error: ffi_prep_closure did not return FFI_OK");
  scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
  return (Scheme_Object*)data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_callback_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1096 of file foreign.c.

{
  return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_lib ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 196 of file foreign.c.

{
  char *name;
  Scheme_Object *path, *hashname;
  void *handle;
  int null_ok = 0;
  ffi_lib_struct *lib;
  if (!(SCHEME_PATH_STRINGP(argv[0]) || SCHEME_FALSEP(argv[0])))
    scheme_wrong_type(MYNAME, "string-or-false", 0, argc, argv);
  /* leave the filename as given, the system will look for it */
  /* (`#f' means open the executable) */
  path = SCHEME_FALSEP(argv[0]) ? NULL : TO_PATH(argv[0]);
  name = (path==NULL) ? NULL : SCHEME_PATH_VAL(path);
  hashname = (Scheme_Object*)((name==NULL) ? "" : name);
  lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname);
  if (!lib) {
    Scheme_Hash_Table *ht;
#   ifdef WINDOWS_DYNAMIC_LOAD
    if (name==NULL) {
      /* openning the executable is marked by a NULL handle */
      handle = NULL;
      null_ok = 1;
    } else
      handle = LoadLibrary(name);
#   else /* WINDOWS_DYNAMIC_LOAD undefined */
    handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL);
#   endif /* WINDOWS_DYNAMIC_LOAD */
    if (handle == NULL && !null_ok) {
      if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false;
      else {
#       ifdef WINDOWS_DYNAMIC_LOAD
        long err;
        err = GetLastError();
        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                         MYNAME": couldn't open %V (%E)", argv[0], err);
#       else /* WINDOWS_DYNAMIC_LOAD undefined */
        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                         MYNAME": couldn't open %V (%s)", argv[0], dlerror());
#       endif /* WINDOWS_DYNAMIC_LOAD */
      }
    }
    ht = scheme_make_hash_table(SCHEME_hash_string);
    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->objects = (ht);
    scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib);
    /* no dlclose finalizer - since the hash table always keeps a reference */
    /* maybe add some explicit unload at some point */
  }
  return (Scheme_Object*)lib;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_lib_name ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 253 of file foreign.c.

{
  if (!SCHEME_FFILIBP(argv[0]))
    scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv);
  return ((ffi_lib_struct*)argv[0])->name;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_lib_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 164 of file foreign.c.

{
  return SCHEME_FFILIBP(argv[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_obj ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 304 of file foreign.c.

{
  ffi_obj_struct *obj;
  void *dlobj;
  ffi_lib_struct *lib = NULL;
  char *dlname;
  if (SCHEME_FFILIBP(argv[1]))
    lib = (ffi_lib_struct*)argv[1];
  else if (SCHEME_PATH_STRINGP(argv[1]) || SCHEME_FALSEP(argv[1]))
    lib = (ffi_lib_struct*)(foreign_ffi_lib(1,&argv[1]));
  else
    scheme_wrong_type(MYNAME, "ffi-lib", 1, argc, argv);
  if (!SCHEME_BYTE_STRINGP(argv[0]))
    scheme_wrong_type(MYNAME, "bytes", 0, argc, argv);
  dlname = SCHEME_BYTE_STR_VAL(argv[0]);
  obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname);
  if (!obj) {
#   ifdef WINDOWS_DYNAMIC_LOAD
    if (lib->handle) {
      dlobj = GetProcAddress(lib->handle, dlname);
    } else {
      /* this is for the executable-open case, which was marked by a NULL
       * handle, deal with it by searching all current modules */
#     define NUM_QUICK_MODS 16
      HMODULE *mods, me, quick_mods[NUM_QUICK_MODS];
      DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i;
      me = GetCurrentProcess();
      mods = quick_mods;
      if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) {
        if (actual_cnt > cnt) {
          cnt = actual_cnt;
          mods = (HMODULE *)scheme_malloc_atomic(cnt);
          if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt))
            mods = NULL;
        } else
          cnt = actual_cnt;
      } else
        mods = NULL;
      if (mods) {
        cnt /= sizeof(HMODULE);
        for (i = 0; i < cnt; i++) {
          dlobj = GetProcAddress(mods[i], dlname);
          if (dlobj) break;
        }
      } else
        dlobj = NULL;
    }
    if (!dlobj) {
      long err;
      err = GetLastError();
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                       MYNAME": couldn't get \"%s\" from %V (%E)",
                       dlname, lib->name, err);
    }
#   else /* WINDOWS_DYNAMIC_LOAD undefined */
    dlobj = dlsym(lib->handle, dlname);
    if (!dlobj) {
      const char *err;
      err = dlerror();
      if (err != NULL)
        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                         MYNAME": couldn't get \"%s\" from %V (%s)",
                         dlname, lib->name, err);
    }
#   endif /* WINDOWS_DYNAMIC_LOAD */
    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);
    scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj);
  }
  return (obj == NULL) ? scheme_false : (Scheme_Object*)obj;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_obj_lib ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 382 of file foreign.c.

{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
  return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_obj_name ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 392 of file foreign.c.

{
  if (!SCHEME_FFIOBJP(argv[0]))
    scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv);
  return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ffi_obj_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 274 of file foreign.c.

{
  return SCHEME_FFIOBJP(argv[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_free ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1890 of file foreign.c.

{
  void *ptr;
  long poff;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  free(W_OFFSET(ptr, poff));
  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_free_immobile_cell ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1915 of file foreign.c.

{
  void *ptr;
  long poff;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
  poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((ptr == NULL) && (poff == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_make_cstruct_type ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1037 of file foreign.c.

{
  Scheme_Object *p, *base;
  /* since ffi_type objects can be used in callbacks, they are allocated using
   * malloc so they don't move, and they are freed when the Scheme object is
   * GCed. */
  GC_CAN_IGNORE ffi_type **elements, *libffi_type, **dummy;
  ctype_struct *type;
  ffi_cif cif;
  int i, nargs;
  ffi_abi abi;
  nargs = scheme_proper_list_length(argv[0]);
  if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv);
  abi = GET_ABI(MYNAME,1);
  /* allocate the type elements */
  elements = malloc((nargs+1) * sizeof(ffi_type*));
  elements[nargs] = NULL;
  for (i=0, p=argv[0]; i<nargs; i++, p=SCHEME_CDR(p)) {
    if (NULL == (base = get_ctype_base(SCHEME_CAR(p))))
      scheme_wrong_type(MYNAME, "list-of-C-types", 0, argc, argv);
    if (CTYPE_PRIMLABEL(base) == FOREIGN_void)
      scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 0, argc, argv);
    elements[i] = CTYPE_PRIMTYPE(base);
  }
  /* allocate the new libffi type object */
  libffi_type = malloc(sizeof(ffi_type));
  libffi_type->size      = 0;
  libffi_type->alignment = 0;
  libffi_type->type      = FFI_TYPE_STRUCT;
  libffi_type->elements  = elements;
  /* use ffi_prep_cif to set the size and alignment information */
  dummy = &libffi_type;
  if (ffi_prep_cif(&cif, 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 = (argv[0]);
  type->scheme_to_c = ((Scheme_Object*)libffi_type);
  type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
  scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
  return (Scheme_Object*)type;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_make_ctype ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 966 of file foreign.c.

{
  ctype_struct *type;
  if (!SCHEME_CTYPEP(argv[0]))
    scheme_wrong_type(MYNAME, "C-type", 0, argc, argv);
  else if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1])))
    scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv);
  else if (!(SCHEME_FALSEP(argv[2]) || SCHEME_PROCP(argv[2])))
    scheme_wrong_type(MYNAME, "procedure-or-false", 2, argc, argv);
  else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2]))
    return argv[0];
  else {
    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 */
}

Here is the caller graph for this function:

static Scheme_Object* foreign_make_sized_byte_string ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2257 of file foreign.c.

{
  /* Warning: no copying is done so it is possible to share string contents. */
  /* Warning: if source ptr has a offset, resulting string object uses shifted
   * pointer.
   * (Should use real byte-strings with new version.) */
  long len;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  if (!scheme_get_int_val(argv[1],&len))
    scheme_wrong_type(MYNAME, "integer in a C long range", 1, argc, argv);
  if (SCHEME_FALSEP(argv[0])) return scheme_false;
  else return
         scheme_make_sized_byte_string(SCHEME_FFIANYPTR_OFFSETVAL(argv[0]),
                                       len, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_malloc ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1806 of file foreign.c.

{
  int i, size=0, num=0, failok=0;
  void *from = NULL, *res = NULL;
  long foff = 0;
  Scheme_Object *mode = NULL, *a, *base = NULL;
  void *(*mf)(size_t);
  for (i=0; i<argc; i++) {
    a = argv[i];
    if (SCHEME_INTP(a)) {
      if (num != 0)
        scheme_signal_error(MYNAME": specifying a second integer size: %V", a);
      num = SCHEME_INT_VAL(a);
      if (num <= 0)
        scheme_wrong_type(MYNAME, "positive-integer", 0, argc, argv);
    } else if (SCHEME_CTYPEP(a)) {
      if (size != 0)
        scheme_signal_error(MYNAME": specifying a second type: %V", a);
      if (NULL == (base = get_ctype_base(a)))
        scheme_wrong_type(MYNAME, "C-type", i, argc, argv);
      size = ctype_sizeof(a);
      if (size <= 0)
        scheme_wrong_type(MYNAME, "non-void-C-type", i, argc, argv);
    } else if (SAME_OBJ(a, fail_ok_sym)) {
      failok = 1;
    } else if (SCHEME_SYMBOLP(a)) {
      if (mode != NULL)
        scheme_signal_error(MYNAME": specifying a second mode symbol: %V", a);
      mode = a;
    } else if (SCHEME_FFIANYPTRP(a) && !SCHEME_FALSEP(a)) {
      if (from != NULL)
        scheme_signal_error(MYNAME": specifying a second source pointer: %V",
                            a);
      from = SCHEME_FFIANYPTR_VAL(a);
      foff = SCHEME_FFIANYPTR_OFFSET(a);
    } else {
      scheme_wrong_type(MYNAME, "malloc-argument", i, argc, argv);
    }
  }
  if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
  size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
  if (mode == NULL)
    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
      ? scheme_malloc : scheme_malloc_atomic;
  else if (SAME_OBJ(mode, nonatomic_sym))     mf = scheme_malloc;
  else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
  else if (SAME_OBJ(mode, stubborn_sym))      mf = scheme_malloc_stubborn;
  else if (SAME_OBJ(mode, eternal_sym))       mf = scheme_malloc_eternal;
  else if (SAME_OBJ(mode, uncollectable_sym)) mf = scheme_malloc_uncollectable;
  else if (SAME_OBJ(mode, interior_sym))      mf = scheme_malloc_atomic_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 {
    scheme_signal_error(MYNAME": bad allocation mode: %V", mode);
    return NULL; /* hush the compiler */
  }
  if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
  if (((from != NULL) || (foff != 0)) && (res != NULL))
    memcpy(res, W_OFFSET(from, foff), size);
  return scheme_make_foreign_cpointer(res);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_malloc_immobile_cell ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1907 of file foreign.c.

Here is the caller graph for this function:

static Scheme_Object* foreign_memcpy ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2133 of file foreign.c.

{
  return do_memop(MYNAME, 2, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_memmove ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2127 of file foreign.c.

{
  return do_memop(MYNAME, 1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_memset ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2121 of file foreign.c.

{
  return do_memop(MYNAME, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_offset_ptr_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1989 of file foreign.c.

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_add ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1973 of file foreign.c.

{
  return do_ptr_add(MYNAME, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_add_bang ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1980 of file foreign.c.

{
  return do_ptr_add(MYNAME, 1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_equal_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2242 of file foreign.c.

{
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  if (!SCHEME_FFIANYPTRP(argv[1]))
    scheme_wrong_type(MYNAME, "cpointer", 1, argc, argv);
  return (SAME_OBJ(argv[0],argv[1]) ||
          (SCHEME_FFIANYPTR_OFFSETVAL(argv[0])
           == SCHEME_FFIANYPTR_OFFSETVAL(argv[1])))
         ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_offset ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1998 of file foreign.c.

{
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0]));
}

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_ref ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2147 of file foreign.c.

{
  int size=0; void *ptr; Scheme_Object *base;
  long delta;

  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
  size = ctype_sizeof(base);

  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
    if (SCHEME_FFIOBJP(argv[0])) {
      /* The ffiobj pointer is the function pointer. */
      ptr = argv[0];
      delta = (long)&(((ffi_obj_struct*)0x0)->obj);
    }
  }

  if (size < 0) {
    /* should not happen */
    scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
  } else if (size == 0) {
    scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
  }

  if (argc > 3) {
    if (!SAME_OBJ(argv[2],abs_sym))
      scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
    if (!SCHEME_INTP(argv[3]))
      scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
    delta += SCHEME_INT_VAL(argv[3]);
  } else if (argc > 2) {
    if (!SCHEME_INTP(argv[2]))
      scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
    if (!size)
      scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
    delta += (size * SCHEME_INT_VAL(argv[2]));
  }
  return C2SCHEME(argv[1], ptr, delta, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_ptr_set_bang ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2200 of file foreign.c.

{
  int size=0; void *ptr;
  long delta;
  Scheme_Object *val = argv[argc-1], *base;
  if (!SCHEME_FFIANYPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
  ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
  delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
  if ((ptr == NULL) && (delta == 0))
    scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
  if (NULL == (base = get_ctype_base(argv[1])))
    scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
  size = ctype_sizeof(base);

  if (size < 0) {
    /* should not happen */
    scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
  } else if (size == 0) {
    scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
  }

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

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* foreign_set_cpointer_tag_bang ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1170 of file foreign.c.

{
  if (!SCHEME_CPTRP(argv[0]))
    scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv);
  SCHEME_CPTR_TYPE(argv[0]) = argv[1];
  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* foreign_set_ptr_offset_bang ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2010 of file foreign.c.

{
  long noff;
  if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0]))
    scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv);
  if (!scheme_get_int_val(argv[1], &noff)) {
    scheme_wrong_type(MYNAME, C_LONG_TYPE_STR, 1, argc, argv);
  }
  if (argc > 2) {
    if (SCHEME_CTYPEP(argv[2])) {
      long size;
      if (NULL == get_ctype_base(argv[2]))
        scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
      size = ctype_sizeof(argv[2]);
      if (size <= 0)
        scheme_wrong_type(MYNAME, "non-void-C-type", 2, argc, argv);
      noff = noff * size;
    } else
      scheme_wrong_type(MYNAME, "C-type", 2, argc, argv);
  }
  ((Scheme_Offset_Cptr*)(argv[0]))->offset = noff;
  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void free_cl_cif_args ( void ignored,
void p 
)

Definition at line 2559 of file foreign.c.

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

Here is the call graph for this function:

Here is the caller graph for this function:

void free_fficall_data ( void ignored,
void p 
)

Definition at line 2447 of file foreign.c.

{
  free(((ffi_cif*)p)->arg_types);
  free(p);
}

Here is the caller graph for this function:

void free_libffi_type ( void ignored,
void p 
)

Definition at line 990 of file foreign.c.

{
  free(((ffi_type*)p)->elements);
  free(p);
}

Here is the caller graph for this function:

static Scheme_Object* get_ctype_base ( Scheme_Object type) [static]

Definition at line 918 of file foreign.c.

{
  if (!SCHEME_CTYPEP(type)) return NULL;
  while (CTYPE_USERP(type)) { type = CTYPE_BASETYPE(type); }
  return type;
}

Here is the caller graph for this function:

static void* SCHEME2C ( Scheme_Object type,
void dst,
long  delta,
Scheme_Object val,
long *  basetype_p,
long *  _offset,
int  ret_loc 
) [static]

Definition at line 1255 of file foreign.c.

{
  if (!SCHEME_CTYPEP(type))
    scheme_wrong_type("Scheme->C", "C-type", 0, 1, &type);
  while (CTYPE_USERP(type)) {
    if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
      val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
    type = CTYPE_BASETYPE(type);
  }
  if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
    /* No need for the SET_CTYPE trick for pointers. */
    if (SCHEME_FFICALLBACKP(val))
      ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
    else if (SCHEME_CPTRP(val))
      ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
    else if (SCHEME_FFIOBJP(val))
      ((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
    else if (SCHEME_FALSEP(val))
      ((void**)W_OFFSET(dst,delta))[0] = NULL;
    else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
         scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
  } else switch (CTYPE_PRIMLABEL(type)) {
    case FOREIGN_void:
      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
      break;
    case FOREIGN_int8:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tsint8));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tsint8 tmp;
        tmp = (Tsint8)(SCHEME_INT_VAL(val));
        (((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","int8",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_uint8:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint8)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tuint8));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tuint8 tmp;
        tmp = (Tuint8)(SCHEME_UINT_VAL(val));
        (((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_int16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint16)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tsint16));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tsint16 tmp;
        tmp = (Tsint16)(SCHEME_INT_VAL(val));
        (((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","int16",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_uint16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint16)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tuint16));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tuint16 tmp;
        tmp = (Tuint16)(SCHEME_UINT_VAL(val));
        (((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_int32:
      if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val));
      return NULL;
    case FOREIGN_uint32:
      if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint32",0,1,&(val));
      return NULL;
    case FOREIGN_int64:
      if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int64",0,1,&(val));
      return NULL;
    case FOREIGN_uint64:
      if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint64",0,1,&(val));
      return NULL;
    case FOREIGN_fixint:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tsint32)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tsint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tsint32 tmp;
        tmp = (Tsint32)(SCHEME_INT_VAL(val));
        (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_ufixint:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Tuint32)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Tuint32));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        Tuint32 tmp;
        tmp = (Tuint32)(SCHEME_UINT_VAL(val));
        (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_fixnum:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(long)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(long));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        long tmp;
        tmp = (long)(SCHEME_INT_VAL(val));
        (((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_ufixnum:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(unsigned long)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(unsigned long));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_INTP(val)) {
        unsigned long tmp;
        tmp = (unsigned long)(SCHEME_UINT_VAL(val));
        (((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_float:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(float)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(float));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FLTP(val)) {
        float tmp;
        tmp = (float)(SCHEME_FLT_VAL(val));
        (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","float",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_double:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(double)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(double));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_DBLP(val)) {
        double tmp;
        tmp = (double)(SCHEME_DBL_VAL(val));
        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","double",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_doubleS:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(double)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(double));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_REALP(val)) {
        double tmp;
        tmp = (double)(scheme_real_to_double(val));
        (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","double*",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_bool:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(int)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(int));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (1) {
        int tmp;
        tmp = (int)(SCHEME_TRUEP(val));
        (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
      } else {
        scheme_wrong_type("Scheme->C","bool",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_string_ucs_4:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(mzchar*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
        mzchar* tmp;
        tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
        if (basetype_p == NULL || tmp == NULL) {
          (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_string_ucs_4;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_string_utf_16:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(unsigned short*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
        unsigned short* tmp;
        tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
        if (basetype_p == NULL || tmp == NULL) {
          (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_string_utf_16;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_bytes:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
        char* tmp;
        tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
        if (basetype_p == NULL || tmp == NULL) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_bytes;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","bytes",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_path:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
        char* tmp;
        tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
        if (basetype_p == NULL || tmp == NULL) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_path;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","path",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_symbol:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(char*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(char*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_SYMBOLP(val)) {
        char* tmp;
        tmp = (char*)(SCHEME_SYM_VAL(val));
        if (basetype_p == NULL || tmp == NULL) {
          (((char**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_symbol;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","symbol",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_pointer:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(void*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(void*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (SCHEME_FFIANYPTRP(val)) {
        void* tmp; long toff;
        tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
        toff = SCHEME_FFIANYPTR_OFFSET(val);
        if (_offset) *_offset = toff;
        if (basetype_p == NULL || (tmp == NULL && toff == 0)) {
          (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
          return NULL;
        } else {
          *basetype_p = FOREIGN_pointer;
          return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
        }
      } else {
        scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_scheme:
#     ifdef SCHEME_BIG_ENDIAN
      if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
        ((int*)W_OFFSET(dst,delta))[0] = 0;
        delta += (sizeof(int)-sizeof(Scheme_Object*));
      }
#     endif /* SCHEME_BIG_ENDIAN */
      if (1) {
        Scheme_Object* tmp;
        tmp = (Scheme_Object*)(val);
        if (basetype_p == NULL || tmp == NULL) {
          (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
          return NULL;
        } else {
          *basetype_p = FOREIGN_scheme;
          return tmp;
        }
      } else {
        scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
        return NULL; /* hush the compiler */
      }
    case FOREIGN_fpointer:
      if (!(ret_loc)) scheme_wrong_type("Scheme->C","fpointer",0,1,&(val));
      break;
    case FOREIGN_struct:
      if (!SCHEME_FFIANYPTRP(val))
        scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
      {
        void* p = SCHEME_FFIANYPTR_VAL(val);
        long poff = SCHEME_FFIANYPTR_OFFSET(val);
        if (basetype_p == NULL) {
          if (p == NULL && poff == 0)
            scheme_signal_error("FFI pointer value was NULL");
          memcpy(W_OFFSET(dst, delta), W_OFFSET(p, poff),
                 CTYPE_PRIMTYPE(type)->size);
          return NULL;
        } else {
          *basetype_p = FOREIGN_struct;
          if (_offset) {
            *_offset = poff;
            return p;
          } else {
            return W_OFFSET(p, poff);
          }
        }
      }
    default: scheme_signal_error("corrupt foreign type: %V", type);
  }
  return NULL; /* hush the compiler */
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2739 of file foreign.c.

{
  Scheme_Env *menv;
  ctype_struct *t;
  Scheme_Object *s;
  menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
  scheme_add_global("ffi-lib?",
    scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
  scheme_add_global("ffi-lib",
    scheme_make_prim_w_arity(foreign_ffi_lib, "ffi-lib", 1, 2), menv);
  scheme_add_global("ffi-lib-name",
    scheme_make_prim_w_arity(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv);
  scheme_add_global("ffi-obj?",
    scheme_make_prim_w_arity(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv);
  scheme_add_global("ffi-obj",
    scheme_make_prim_w_arity(foreign_ffi_obj, "ffi-obj", 2, 2), menv);
  scheme_add_global("ffi-obj-lib",
    scheme_make_prim_w_arity(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv);
  scheme_add_global("ffi-obj-name",
    scheme_make_prim_w_arity(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv);
  scheme_add_global("ctype?",
    scheme_make_prim_w_arity(foreign_ctype_p, "ctype?", 1, 1), menv);
  scheme_add_global("ctype-basetype",
    scheme_make_prim_w_arity(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv);
  scheme_add_global("ctype-scheme->c",
    scheme_make_prim_w_arity(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv);
  scheme_add_global("ctype-c->scheme",
    scheme_make_prim_w_arity(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv);
  scheme_add_global("make-ctype",
    scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
  scheme_add_global("make-cstruct-type",
    scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv);
  scheme_add_global("ffi-callback?",
    scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
  scheme_add_global("cpointer?",
    scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv);
  scheme_add_global("cpointer-tag",
    scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
  scheme_add_global("set-cpointer-tag!",
    scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
  scheme_add_global("ctype-sizeof",
    scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
  scheme_add_global("ctype-alignof",
    scheme_make_prim_w_arity(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv);
  scheme_add_global("compiler-sizeof",
    scheme_make_prim_w_arity(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
  scheme_add_global("malloc",
    scheme_make_prim_w_arity(foreign_malloc, "malloc", 1, 5), menv);
  scheme_add_global("end-stubborn-change",
    scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
  scheme_add_global("free",
    scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
  scheme_add_global("malloc-immobile-cell",
    scheme_make_prim_w_arity(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv);
  scheme_add_global("free-immobile-cell",
    scheme_make_prim_w_arity(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv);
  scheme_add_global("ptr-add",
    scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
  scheme_add_global("ptr-add!",
    scheme_make_prim_w_arity(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv);
  scheme_add_global("offset-ptr?",
    scheme_make_prim_w_arity(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv);
  scheme_add_global("ptr-offset",
    scheme_make_prim_w_arity(foreign_ptr_offset, "ptr-offset", 1, 1), menv);
  scheme_add_global("set-ptr-offset!",
    scheme_make_prim_w_arity(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv);
  scheme_add_global("memset",
    scheme_make_prim_w_arity(foreign_memset, "memset", 3, 5), menv);
  scheme_add_global("memmove",
    scheme_make_prim_w_arity(foreign_memmove, "memmove", 3, 6), menv);
  scheme_add_global("memcpy",
    scheme_make_prim_w_arity(foreign_memcpy, "memcpy", 3, 6), menv);
  scheme_add_global("ptr-ref",
    scheme_make_prim_w_arity(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
  scheme_add_global("ptr-set!",
    scheme_make_prim_w_arity(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
  scheme_add_global("ptr-equal?",
    scheme_make_prim_w_arity(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
  scheme_add_global("make-sized-byte-string",
    scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
  scheme_add_global("ffi-call",
    scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
  scheme_add_global("ffi-callback",
    scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
  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_add_global("_void", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("int8");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
  scheme_add_global("_int8", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("uint8");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
  scheme_add_global("_uint8", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("int16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
  scheme_add_global("_int16", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("uint16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
  scheme_add_global("_uint16", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("int32");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
  scheme_add_global("_int32", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("uint32");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
  scheme_add_global("_uint32", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("int64");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
  scheme_add_global("_int64", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("uint64");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
  scheme_add_global("_uint64", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("fixint");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
  scheme_add_global("_fixint", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("ufixint");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
  scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("fixnum");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
  scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("ufixnum");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
  scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("float");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
  scheme_add_global("_float", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("double");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
  scheme_add_global("_double", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("double*");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
  scheme_add_global("_double*", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("bool");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
  scheme_add_global("_bool", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("string/ucs-4");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
  scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("string/utf-16");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
  scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("bytes");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
  scheme_add_global("_bytes", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("path");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
  scheme_add_global("_path", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("symbol");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
  scheme_add_global("_symbol", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("pointer");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
  scheme_add_global("_pointer", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("scheme");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
  scheme_add_global("_scheme", (Scheme_Object*)t, menv);
  s = scheme_intern_symbol("fpointer");
  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
  t->so.type = ctype_tag;
  t->basetype = (s);
  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
  t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
  scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
  scheme_finish_primitive_module(menv);
  scheme_protect_primitive_provide(menv, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2696 of file foreign.c.

{
  ffi_lib_tag = scheme_make_type("<ffi-lib>");
  ffi_obj_tag = scheme_make_type("<ffi-obj>");
  ctype_tag = scheme_make_type("<ctype>");
  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(ctype_tag, ctype_printer);
  MZ_REGISTER_STATIC(opened_libs);
  opened_libs = scheme_make_hash_table(SCHEME_hash_string);
  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(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(fail_ok_sym);
  fail_ok_sym = scheme_intern_symbol("fail-ok");
  MZ_REGISTER_STATIC(abs_sym);
  abs_sym = scheme_intern_symbol("abs");
}

Here is the call graph for this function:

Here is the caller graph for this function:

ffi_abi sym_to_abi ( char *  who,
Scheme_Object sym 
)

Definition at line 1003 of file foreign.c.

{
  if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym))
    return FFI_DEFAULT_ABI;
  else if (SAME_OBJ(sym, sysv_sym)) {
#ifdef WINDOWS_DYNAMIC_LOAD
    return FFI_SYSV;
#else
    scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
  } else if (SAME_OBJ(sym, stdcall_sym)) {
#ifdef WINDOWS_DYNAMIC_LOAD
    return FFI_STDCALL;
#else
    scheme_signal_error("%s: ABI not implemented: %V", who, sym);
#endif
  } else {
    scheme_signal_error("%s: unknown ABI: %V", who, sym);
  }
  return 0; /* hush the compiler */
}

Definition at line 468 of file foreign.c.

{
  if (SCHEME_FALSEP(ucs)) return NULL;
  return SCHEME_CHAR_STR_VAL(ucs);
}

Here is the caller graph for this function:

static unsigned short* ucs4_string_or_null_to_utf16_pointer ( Scheme_Object ucs) [static]

Definition at line 484 of file foreign.c.

{
  if (SCHEME_FALSEP(ucs)) return NULL;
  return ucs4_string_to_utf16_pointer(ucs);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static unsigned short* ucs4_string_to_utf16_pointer ( Scheme_Object ucs) [static]

Definition at line 474 of file foreign.c.

{
  long ulen;
  unsigned short *res;
  res = scheme_ucs4_to_utf16
          (SCHEME_CHAR_STR_VAL(ucs), 0, 1+SCHEME_CHAR_STRLEN_VAL(ucs),
           NULL, -1, &ulen, 0);
  return res;
}

Here is the caller graph for this function:

Scheme_Object* utf16_pointer_to_ucs4_string ( unsigned short *  utf)

Definition at line 490 of file foreign.c.

{
  long ulen;
  mzchar *res;
  int end;
  if (!utf) return scheme_false;
  for (end=0; utf[end] != 0; end++) {  }
  res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
  return scheme_make_sized_char_string(res, ulen, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:


Variable Documentation

Definition at line 2139 of file foreign.c.

Definition at line 1787 of file foreign.c.

Definition at line 1782 of file foreign.c.

Definition at line 842 of file foreign.c.

Definition at line 999 of file foreign.c.

Definition at line 1785 of file foreign.c.

Definition at line 1789 of file foreign.c.

Definition at line 1085 of file foreign.c.

Definition at line 155 of file foreign.c.

Definition at line 265 of file foreign.c.

Definition at line 1786 of file foreign.c.

Definition at line 1781 of file foreign.c.

Definition at line 192 of file foreign.c.

Definition at line 1788 of file foreign.c.

Definition at line 1000 of file foreign.c.

Definition at line 1783 of file foreign.c.

Definition at line 1001 of file foreign.c.

Definition at line 1784 of file foreign.c.