suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

treat FFI primitives like other primitives internally

Browse Source 
This change paves the way for JIT-inlining FFI operations
such as `ptr-ref`. Even without JIT treatment, the change
slightly reduces the overhead for calling FFI primitives.
This commit is contained in:
Matthew Flatt 2014-02-24 16:42:05 -07:00
parent 46523d307b
commit eff53cde87
14 changed files with 2060 additions and 1905 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

558
racket/src/foreign/foreign.c
View File

@ -1591,7 +1591,7 @@ static int check_cpointer_property(Scheme_Object *v)
return 0;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
static Scheme_Object *unwrap_cpointer_property_slow(Scheme_Object *orig_v)
{
Scheme_Object *v = orig_v, *val;
int must = 0;
@ -1623,6 +1623,14 @@ static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
return v;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *v)
{
if (SCHEME_FFIANYPTRP(v))
return v;
else
return unwrap_cpointer_property_slow(v);
}
int scheme_is_cpointer(Scheme_Object *cp) {
return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}
@ -1792,8 +1800,8 @@ static void* SCHEME2C(const char *who,
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type);
}
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
val = unwrap_cpointer_property(val);
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
@ -1933,6 +1941,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_INTP(val)) {
Tsint32 tmp;
tmp = MZ_TYPE_CAST(Tsint32, SCHEME_INT_VAL(val));
@ -1953,6 +1962,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_INTP(val)) {
Tuint32 tmp;
tmp = MZ_TYPE_CAST(Tuint32, SCHEME_UINT_VAL(val));
@ -1973,6 +1983,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_INTP(val)) {
intptr_t tmp;
tmp = MZ_TYPE_CAST(intptr_t, SCHEME_INT_VAL(val));
@ -1993,6 +2004,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_INTP(val)) {
uintptr_t tmp;
tmp = MZ_TYPE_CAST(uintptr_t, SCHEME_UINT_VAL(val));
@ -2013,6 +2025,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FLOATP(val)) {
float tmp;
tmp = MZ_TYPE_CAST(float, SCHEME_FLOAT_VAL(val));
@ -2033,6 +2046,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FLOATP(val)) {
double tmp;
tmp = MZ_TYPE_CAST(double, SCHEME_FLOAT_VAL(val));
@ -2053,6 +2067,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_LONG_DBLP(val)) {
mz_long_double tmp;
tmp = MZ_NO_TYPE_CAST(mz_long_double, SCHEME_MAYBE_LONG_DBL_VAL(val));
@ -2073,6 +2088,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_REALP(val)) {
double tmp;
tmp = MZ_TYPE_CAST(double, scheme_real_to_double(val));
@ -2093,6 +2109,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (1) {
int tmp;
tmp = MZ_TYPE_CAST(int, SCHEME_TRUEP(val));
@ -2113,6 +2130,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = MZ_TYPE_CAST(mzchar*, ucs4_string_or_null_to_ucs4_pointer(val));
@ -2139,6 +2157,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = MZ_TYPE_CAST(unsigned short*, ucs4_string_or_null_to_utf16_pointer(val));
@ -2165,6 +2184,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
char* tmp;
tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
@ -2191,6 +2211,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
char* tmp;
tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
@ -2217,6 +2238,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (SCHEME_SYMBOLP(val)) {
char* tmp;
tmp = MZ_TYPE_CAST(char*, SCHEME_SYM_VAL(val));
@ -2243,6 +2265,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
val = unwrap_cpointer_property(val);
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; intptr_t toff;
tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
@ -2273,6 +2296,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
val = unwrap_cpointer_property(val);
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; intptr_t toff;
tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
@ -2303,6 +2327,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (1) {
Scheme_Object* tmp;
tmp = MZ_TYPE_CAST(Scheme_Object*, val);
@ -2334,6 +2359,7 @@ static void* SCHEME2C(const char *who,
case FOREIGN_struct:
case FOREIGN_array:
case FOREIGN_union:
val = unwrap_cpointer_property(val);
if (!SCHEME_FFIANYPTRP(val)) {
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_struct:
@ -4049,6 +4075,8 @@ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
/*****************************************************************************/
/* Initialization */
static Scheme_Env *ffi_env = NULL;
/* types need to be initialized before places can spawn
* types become entries in the GC mark and fixup tables
* this function should initialize read-only globals that can be
@ -4057,7 +4085,7 @@ void scheme_init_foreign_globals()
{
ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>");
ctype_tag = scheme_make_type("<ctype>");
ctype_tag = scheme_ctype_type;
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);
@ -4065,7 +4093,7 @@ void scheme_init_foreign_globals()
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);
scheme_set_type_printer(scheme_ctype_type, ctype_printer);
MZ_REGISTER_STATIC(default_sym);
default_sym = scheme_intern_symbol("default");
MZ_REGISTER_STATIC(stdcall_sym);
@ -4115,304 +4143,312 @@ void scheme_init_foreign(Scheme_Env *env)
Scheme_Object *s;
memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
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, 3), 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, 3), menv);
scheme_add_global("make-array-type",
scheme_make_prim_w_arity(foreign_make_array_type, "make-array-type", 2, 2), menv);
scheme_add_global("make-union-type",
scheme_make_prim_w_arity(foreign_make_union_type, "make-union-type", 1, -1), 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("cpointer-gcable?",
scheme_make_prim_w_arity(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), 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("vector->cpointer",
scheme_make_prim_w_arity(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv);
scheme_add_global("flvector->cpointer",
scheme_make_prim_w_arity(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv);
scheme_add_global("extflvector->cpointer",
scheme_make_prim_w_arity(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), 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, 6), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 6), menv);
scheme_add_global("saved-errno",
scheme_make_prim_w_arity(foreign_saved_errno, "saved-errno", 0, 0), menv);
scheme_add_global("lookup-errno",
scheme_make_prim_w_arity(foreign_lookup_errno, "lookup-errno", 1, 1), menv);
scheme_add_global("make-stubborn-will-executor",
scheme_make_prim_w_arity(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv);
scheme_add_global("make-late-weak-box",
scheme_make_prim_w_arity(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv);
scheme_add_global("make-late-weak-hasheq",
scheme_make_prim_w_arity(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), menv);
scheme_add_global_constant("ffi-lib?",
scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
scheme_add_global_constant("ffi-lib",
scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), menv);
scheme_add_global_constant("ffi-lib-name",
scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv);
scheme_add_global_constant("ffi-obj?",
scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv);
scheme_add_global_constant("ffi-obj",
scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), menv);
scheme_add_global_constant("ffi-obj-lib",
scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv);
scheme_add_global_constant("ffi-obj-name",
scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv);
scheme_add_global_constant("ctype?",
scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), menv);
scheme_add_global_constant("ctype-basetype",
scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv);
scheme_add_global_constant("ctype-scheme->c",
scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv);
scheme_add_global_constant("ctype-c->scheme",
scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv);
scheme_add_global_constant("make-ctype",
scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global_constant("make-cstruct-type",
scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), menv);
scheme_add_global_constant("make-array-type",
scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), menv);
scheme_add_global_constant("make-union-type",
scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), menv);
scheme_add_global_constant("ffi-callback?",
scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
scheme_add_global_constant("cpointer?",
scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), menv);
scheme_add_global_constant("cpointer-tag",
scheme_make_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global_constant("set-cpointer-tag!",
scheme_make_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global_constant("cpointer-gcable?",
scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), menv);
scheme_add_global_constant("ctype-sizeof",
scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
scheme_add_global_constant("ctype-alignof",
scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv);
scheme_add_global_constant("compiler-sizeof",
scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
scheme_add_global_constant("malloc",
scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), menv);
scheme_add_global_constant("end-stubborn-change",
scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
scheme_add_global_constant("free",
scheme_make_noncm_prim(foreign_free, "free", 1, 1), menv);
scheme_add_global_constant("malloc-immobile-cell",
scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv);
scheme_add_global_constant("free-immobile-cell",
scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv);
scheme_add_global_constant("ptr-add",
scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), menv);
scheme_add_global_constant("ptr-add!",
scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv);
scheme_add_global_constant("offset-ptr?",
scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv);
scheme_add_global_constant("ptr-offset",
scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), menv);
scheme_add_global_constant("set-ptr-offset!",
scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv);
scheme_add_global_constant("vector->cpointer",
scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv);
scheme_add_global_constant("flvector->cpointer",
scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv);
scheme_add_global_constant("extflvector->cpointer",
scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), menv);
scheme_add_global_constant("memset",
scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), menv);
scheme_add_global_constant("memmove",
scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), menv);
scheme_add_global_constant("memcpy",
scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref",
scheme_make_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
scheme_add_global_constant("ptr-set!",
scheme_make_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
scheme_add_global_constant("ptr-equal?",
scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string",
scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv);
scheme_add_global_constant("ffi-call",
scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 6), menv);
scheme_add_global_constant("ffi-callback",
scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), menv);
scheme_add_global_constant("saved-errno",
scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 0), menv);
scheme_add_global_constant("lookup-errno",
scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), menv);
scheme_add_global_constant("make-stubborn-will-executor",
scheme_make_immed_prim(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv);
scheme_add_global_constant("make-late-weak-box",
scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv);
scheme_add_global_constant("make-late-weak-hasheq",
scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), 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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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_smzintptr));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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_umzintptr));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("longdouble");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_slongdouble));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_longdouble);
scheme_add_global("_longdouble", (Scheme_Object*)t, menv);
scheme_add_global_constant("_longdouble", (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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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);
scheme_add_global_constant("_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);
scheme_add_global_constant("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("gcpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer);
scheme_add_global("_gcpointer", (Scheme_Object*)t, menv);
scheme_add_global_constant("_gcpointer", (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_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv);
scheme_add_global_constant("_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_add_global_constant("_fpointer", (Scheme_Object*)t, menv);
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
MZ_REGISTER_STATIC(ffi_env);
ffi_env = menv;
}
Scheme_Env *scheme_get_foreign_env() {
return ffi_env;
}
/*****************************************************************************/
#else /* DONT_USE_FOREIGN */
static Scheme_Env *ffi_env = NULL;
int scheme_is_cpointer(Scheme_Object *cp)
{
return (SCHEME_FALSEP(cp)
@ -4449,136 +4485,142 @@ void scheme_init_foreign(Scheme_Env *env)
/* Create a dummy module. */
Scheme_Env *menv;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
scheme_add_global("ffi-lib?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), menv);
scheme_add_global("ffi-lib",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), menv);
scheme_add_global("ffi-lib-name",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), menv);
scheme_add_global("ffi-obj?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), menv);
scheme_add_global("ffi-obj",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), menv);
scheme_add_global("ffi-obj-lib",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), menv);
scheme_add_global("ffi-obj-name",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), menv);
scheme_add_global("ctype?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype?", 1, 1), menv);
scheme_add_global("ctype-basetype",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), menv);
scheme_add_global("ctype-scheme->c",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), menv);
scheme_add_global("ctype-c->scheme",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), menv);
scheme_add_global("make-ctype",
scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv);
scheme_add_global("make-array-type",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv);
scheme_add_global("make-union-type",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv);
scheme_add_global("cpointer?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv);
scheme_add_global("cpointer-tag",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global("cpointer-gcable?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv);
scheme_add_global("ctype-sizeof",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), menv);
scheme_add_global("compiler-sizeof",
scheme_make_prim_w_arity((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
scheme_add_global("malloc",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "malloc", 1, 5), menv);
scheme_add_global("end-stubborn-change",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), menv);
scheme_add_global("free",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "free", 1, 1), menv);
scheme_add_global("malloc-immobile-cell",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), menv);
scheme_add_global("free-immobile-cell",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), menv);
scheme_add_global("ptr-add",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), menv);
scheme_add_global("ptr-add!",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), menv);
scheme_add_global("offset-ptr?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), menv);
scheme_add_global("ptr-offset",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), menv);
scheme_add_global("set-ptr-offset!",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), menv);
scheme_add_global("vector->cpointer",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv);
scheme_add_global("flvector->cpointer",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv);
scheme_add_global("extflvector->cpointer",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), menv);
scheme_add_global("memset",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memset", 3, 5), menv);
scheme_add_global("memmove",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memmove", 3, 6), menv);
scheme_add_global("memcpy",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv);
scheme_add_global("ptr-ref",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv);
scheme_add_global("ptr-set!",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv);
scheme_add_global("ptr-equal?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv);
scheme_add_global("make-sized-byte-string",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv);
scheme_add_global("ffi-call",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-call", 3, 6), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv);
scheme_add_global("saved-errno",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "saved-errno", 0, 0), menv);
scheme_add_global("lookup-errno",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv);
scheme_add_global("make-stubborn-will-executor",
scheme_make_prim_w_arity((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv);
scheme_add_global("make-late-weak-box",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv);
scheme_add_global("make-late-weak-hasheq",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), menv);
scheme_add_global("_void", scheme_false, menv);
scheme_add_global("_int8", scheme_false, menv);
scheme_add_global("_uint8", scheme_false, menv);
scheme_add_global("_int16", scheme_false, menv);
scheme_add_global("_uint16", scheme_false, menv);
scheme_add_global("_int32", scheme_false, menv);
scheme_add_global("_uint32", scheme_false, menv);
scheme_add_global("_int64", scheme_false, menv);
scheme_add_global("_uint64", scheme_false, menv);
scheme_add_global("_fixint", scheme_false, menv);
scheme_add_global("_ufixint", scheme_false, menv);
scheme_add_global("_fixnum", scheme_false, menv);
scheme_add_global("_ufixnum", scheme_false, menv);
scheme_add_global("_float", scheme_false, menv);
scheme_add_global("_double", scheme_false, menv);
scheme_add_global("_longdouble", scheme_false, menv);
scheme_add_global("_double*", scheme_false, menv);
scheme_add_global("_bool", scheme_false, menv);
scheme_add_global("_string/ucs-4", scheme_false, menv);
scheme_add_global("_string/utf-16", scheme_false, menv);
scheme_add_global("_bytes", scheme_false, menv);
scheme_add_global("_path", scheme_false, menv);
scheme_add_global("_symbol", scheme_false, menv);
scheme_add_global("_pointer", scheme_false, menv);
scheme_add_global("_gcpointer", scheme_false, menv);
scheme_add_global("_scheme", scheme_false, menv);
scheme_add_global("_fpointer", scheme_false, menv);
scheme_add_global_constant("ffi-lib?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), menv);
scheme_add_global_constant("ffi-lib",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), menv);
scheme_add_global_constant("ffi-lib-name",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), menv);
scheme_add_global_constant("ffi-obj?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), menv);
scheme_add_global_constant("ffi-obj",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), menv);
scheme_add_global_constant("ffi-obj-lib",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), menv);
scheme_add_global_constant("ffi-obj-name",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), menv);
scheme_add_global_constant("ctype?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), menv);
scheme_add_global_constant("ctype-basetype",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), menv);
scheme_add_global_constant("ctype-scheme->c",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), menv);
scheme_add_global_constant("ctype-c->scheme",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), menv);
scheme_add_global_constant("make-ctype",
scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global_constant("make-cstruct-type",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv);
scheme_add_global_constant("make-array-type",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv);
scheme_add_global_constant("make-union-type",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv);
scheme_add_global_constant("ffi-callback?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv);
scheme_add_global_constant("cpointer?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv);
scheme_add_global_constant("cpointer-tag",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv);
scheme_add_global_constant("set-cpointer-tag!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global_constant("cpointer-gcable?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv);
scheme_add_global_constant("ctype-sizeof",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv);
scheme_add_global_constant("ctype-alignof",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), menv);
scheme_add_global_constant("compiler-sizeof",
scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv);
scheme_add_global_constant("malloc",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), menv);
scheme_add_global_constant("end-stubborn-change",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), menv);
scheme_add_global_constant("free",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), menv);
scheme_add_global_constant("malloc-immobile-cell",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), menv);
scheme_add_global_constant("free-immobile-cell",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), menv);
scheme_add_global_constant("ptr-add",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), menv);
scheme_add_global_constant("ptr-add!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), menv);
scheme_add_global_constant("offset-ptr?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), menv);
scheme_add_global_constant("ptr-offset",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), menv);
scheme_add_global_constant("set-ptr-offset!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), menv);
scheme_add_global_constant("vector->cpointer",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv);
scheme_add_global_constant("flvector->cpointer",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv);
scheme_add_global_constant("extflvector->cpointer",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), menv);
scheme_add_global_constant("memset",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), menv);
scheme_add_global_constant("memmove",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), menv);
scheme_add_global_constant("memcpy",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv);
scheme_add_global_constant("ptr-set!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv);
scheme_add_global_constant("ptr-equal?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv);
scheme_add_global_constant("ffi-call",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 6), menv);
scheme_add_global_constant("ffi-callback",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv);
scheme_add_global_constant("saved-errno",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 0), menv);
scheme_add_global_constant("lookup-errno",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv);
scheme_add_global_constant("make-stubborn-will-executor",
scheme_make_immed_prim((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv);
scheme_add_global_constant("make-late-weak-box",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv);
scheme_add_global_constant("make-late-weak-hasheq",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), menv);
scheme_add_global_constant("_void", scheme_false, menv);
scheme_add_global_constant("_int8", scheme_false, menv);
scheme_add_global_constant("_uint8", scheme_false, menv);
scheme_add_global_constant("_int16", scheme_false, menv);
scheme_add_global_constant("_uint16", scheme_false, menv);
scheme_add_global_constant("_int32", scheme_false, menv);
scheme_add_global_constant("_uint32", scheme_false, menv);
scheme_add_global_constant("_int64", scheme_false, menv);
scheme_add_global_constant("_uint64", scheme_false, menv);
scheme_add_global_constant("_fixint", scheme_false, menv);
scheme_add_global_constant("_ufixint", scheme_false, menv);
scheme_add_global_constant("_fixnum", scheme_false, menv);
scheme_add_global_constant("_ufixnum", scheme_false, menv);
scheme_add_global_constant("_float", scheme_false, menv);
scheme_add_global_constant("_double", scheme_false, menv);
scheme_add_global_constant("_longdouble", scheme_false, menv);
scheme_add_global_constant("_double*", scheme_false, menv);
scheme_add_global_constant("_bool", scheme_false, menv);
scheme_add_global_constant("_string/ucs-4", scheme_false, menv);
scheme_add_global_constant("_string/utf-16", scheme_false, menv);
scheme_add_global_constant("_bytes", scheme_false, menv);
scheme_add_global_constant("_path", scheme_false, menv);
scheme_add_global_constant("_symbol", scheme_false, menv);
scheme_add_global_constant("_pointer", scheme_false, menv);
scheme_add_global_constant("_gcpointer", scheme_false, menv);
scheme_add_global_constant("_scheme", scheme_false, menv);
scheme_add_global_constant("_fpointer", scheme_false, menv);
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
MZ_REGISTER_STATIC(ffi_env);
ffi_env = menv;
}
Scheme_Env *scheme_get_foreign_env() {
return ffi_env;
}
#endif

102
racket/src/foreign/foreign.rktc
View File

@ -368,14 +368,14 @@ static uintptr_t adjustment;
}
/* (ffi-obj-lib ffi-obj) -> ffi-lib */
@cdefine[ffi-obj-lib 1]{
@cdefine[ffi-obj-lib 1 #:kind immed]{
if (!SCHEME_FFIOBJP(argv[0]))
scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib);
}
/* (ffi-obj-name ffi-obj) -> string */
@cdefine[ffi-obj-name 1]{
@cdefine[ffi-obj-name 1 #:kind immed]{
if (!SCHEME_FFIOBJP(argv[0]))
scheme_wrong_contract(MYNAME, "ffi-obj?", 0, argc, argv);
return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name);
@ -619,10 +619,12 @@ static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))]
[c->s (prop 'c->s)]
[offset (prop 'offset #f)]
[unwrap? (prop 'unwrap? #f)]
[cast (prop 'cast 'MZ_TYPE_CAST)])
(output (describe-type stype cname ftype ctype pred s->c c->s offset))
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset) (cast ,cast))))
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)
(unwrap? ,unwrap?) (cast ,cast))))
(define (defctype name . args)
(set! types (append types (list (make-ctype name args)))))
@ -648,11 +650,12 @@ static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[c->s (id 'c->s)]
[offset (id 'offset)]
[ptr? (id 'ptr?)]
[unwrap? (id 'unwrap?)]
[cast (id 'cast)])
#'(maplines #:semicolons? 'semi?
(lambda (t)
(define data (cdr t))
(define (get sym) (cadr (assq sym data)))
(define (get sym) (cadr (assq sym data)))
(let* ([stype (get 'stype)]
[cname (get 'cname)]
[ftype (get 'ftype)]
@ -664,6 +667,7 @@ static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[offset (get 'offset)]
[ptr? (or (equal? "pointer" ftype)
(equal? "gcpointer" ftype))]
[unwrap? (get 'unwrap?)]
[cast (get 'cast)])
body ...))
types)))]))
@ -867,12 +871,14 @@ static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* value, either a cpointer object or #f is returned. */
@(defctype 'pointer
'ctype "void*"
'unwrap? #t
'macro "FFIANYPTR"
'offset "FFIANYPTR"
'c->s "scheme_make_foreign_external_cpointer")
@(defctype 'gcpointer
'ftype "gcpointer"
'unwrap? #t
'ctype "void*"
'macro "FFIANYPTR"
'offset "FFIANYPTR"
@ -899,7 +905,7 @@ static Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
@(defctype 'fpointer 'ftype "pointer" 'ctype "void*")
@(defctype 'fpointer 'ftype "pointer" 'ctype "void*" 'unwrap? #t)
typedef union _ForeignAny {
@(map-types (when ctype @list{@ctype x_@cname}))
@ -949,20 +955,20 @@ static ffi_type ffi_type_gcpointer;
#define CTYPE_ARG_PRIMTYPE(x) ((CTYPE_PRIMLABEL(x) == FOREIGN_array) ? &ffi_type_pointer : CTYPE_PRIMTYPE(x))
/* Returns #f for primitive types. */
@cdefine[ctype-basetype 1]{
@cdefine[ctype-basetype 1 #:kind immed]{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return CTYPE_BASETYPE(argv[0]);
}
@cdefine[ctype-scheme->c 1]{
@cdefine[ctype-scheme->c 1 #:kind immed]{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return (CTYPE_PRIMP(argv[0])) ? scheme_false :
((ctype_struct*)(argv[0]))->scheme_to_c;
}
@cdefine[ctype-c->scheme 1]{
@cdefine[ctype-c->scheme 1 #:kind immed]{
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
return (CTYPE_PRIMP(argv[0])) ? scheme_false :
@ -1369,7 +1375,7 @@ static int check_cpointer_property(Scheme_Object *v)
return 0;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
static Scheme_Object *unwrap_cpointer_property_slow(Scheme_Object *orig_v)
{
Scheme_Object *v = orig_v, *val;
int must = 0;
@ -1401,11 +1407,19 @@ static Scheme_Object *unwrap_cpointer_property(Scheme_Object *orig_v)
return v;
}
static Scheme_Object *unwrap_cpointer_property(Scheme_Object *v)
{
if (SCHEME_FFIANYPTRP(v))
return v;
else
return unwrap_cpointer_property_slow(v);
}
int scheme_is_cpointer(Scheme_Object *cp) {
return (SCHEME_FFIANYPTRP(cp) || check_cpointer_property(cp));
}
@cdefine[cpointer? 1]{
@cdefine[cpointer? 1 #:kind immed]{
return (scheme_is_cpointer(argv[0])
? scheme_true
: scheme_false);
@ -1537,8 +1551,8 @@ static void* SCHEME2C(const char *who,
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
type = CTYPE_BASETYPE(type);
}
val = unwrap_cpointer_property(val);
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
val = unwrap_cpointer_property(val);
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
@ -1591,6 +1605,9 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
}
@(if unwrap?
@list{val = unwrap_cpointer_property(val);}
null)
if (@f[pred]) {
@ctype tmp@";"@and[offset]{ intptr_t toff@";"}
tmp = @cast(@ctype, @f[s->c]);
@ -1627,6 +1644,7 @@ static void* SCHEME2C(const char *who,
case FOREIGN_struct:
case FOREIGN_array:
case FOREIGN_union:
val = unwrap_cpointer_property(val);
if (!SCHEME_FFIANYPTRP(val)) {
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_struct:
@ -1670,7 +1688,7 @@ static void* SCHEME2C(const char *who,
/* C type information */
/* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */
@cdefine[ctype-sizeof 1]{
@cdefine[ctype-sizeof 1 #:kind immed]{
intptr_t size;
size = ctype_sizeof(argv[0]);
if (size >= 0) return scheme_make_integer(size);
@ -1679,7 +1697,7 @@ static void* SCHEME2C(const char *who,
}
/* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */
@cdefine[ctype-alignof 1]{
@cdefine[ctype-alignof 1 #:kind immed]{
Scheme_Object *type;
type = get_ctype_base(argv[0]);
if (type == NULL) scheme_wrong_contract(MYNAME, "ctype?", 0, argc, argv);
@ -1691,7 +1709,7 @@ static void* SCHEME2C(const char *who,
* The symbols are in 'int 'char 'void 'short 'long '*, order does not matter,
* when a single symbol is used, a list is not needed.
* (This is about actual C types, not C type objects.) */
@cdefine[compiler-sizeof 1]{
@cdefine[compiler-sizeof 1 #:kind immed]{
int res=0;
int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */
int intsize = 0; /* "short" => decrement, "long" => increment */
@ -1915,7 +1933,7 @@ static void* SCHEME2C(const char *who,
}
/* (malloc-immobile-cell v) */
@cdefine[malloc-immobile-cell 1]{
@cdefine[malloc-immobile-cell 1 #:kind immed]{
void *p;
p = scheme_malloc_immobile_box(argv[0]);
return scheme_make_foreign_external_cpointer(p); /* <- beware: macro duplicates `p' */
@ -2129,19 +2147,19 @@ static Scheme_Object *do_memop(const char *who, int mode,
return scheme_void;
}
@cdefine[vector->cpointer 1]{
@cdefine[vector->cpointer 1 #:kind immed]{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_contract(MYNAME, "vector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL);
}
@cdefine[flvector->cpointer 1]{
@cdefine[flvector->cpointer 1 #:kind immed]{
if (!SCHEME_FLVECTORP(argv[0]))
scheme_wrong_contract(MYNAME, "flvector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
}
@cdefine[extflvector->cpointer 1]{
@cdefine[extflvector->cpointer 1 #:kind immed]{
@@@IFDEF{MZ_LONG_DOUBLE}{
if (!SCHEME_EXTFLVECTORP(argv[0]))
scheme_wrong_contract(MYNAME, "extflvector?", 0, argc, argv);
@ -3172,12 +3190,12 @@ static void save_errno_values(int kind)
p->saved_errno = errno;
}
@cdefine[saved-errno 0]{
@cdefine[saved-errno 0 #:kind immed]{
Scheme_Thread *p = scheme_current_thread;
return scheme_make_integer_value(p->saved_errno);
}
@cdefine[lookup-errno 1]{
@cdefine[lookup-errno 1 #:kind immed]{
Scheme_Object *v = argv[0];
@(let* ([errnos '(EINTR EEXIST EAGAIN)]
[syms (string-append
@ -3204,17 +3222,17 @@ static void save_errno_values(int kind)
/*****************************************************************************/
/* (make-stubborn-will-executor) -> #<will-executor> */
@cdefine[make-stubborn-will-executor 0]{
@cdefine[make-stubborn-will-executor 0 #:kind immed]{
return scheme_make_stubborn_will_executor();
}
/* (make-late-weak-box val) -> #<weak-box> */
@cdefine[make-late-weak-box 1]{
@cdefine[make-late-weak-box 1 #:kind immed]{
return scheme_make_late_weak_box(argv[0]);
}
/* (make-late-weak-hasheq) -> #<hash> */
@cdefine[make-late-weak-hasheq 0]{
@cdefine[make-late-weak-hasheq 0 #:kind immed]{
return (Scheme_Object *)scheme_make_bucket_table(20, SCHEME_hash_late_weak_ptr);
}
@ -3241,6 +3259,8 @@ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
/*****************************************************************************/
/* Initialization */
static Scheme_Env *ffi_env = NULL;
/* types need to be initialized before places can spawn
* types become entries in the GC mark and fixup tables
* this function should initialize read-only globals that can be
@ -3248,7 +3268,9 @@ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
void scheme_init_foreign_globals()
{
@(maplines (lambda (x)
@list{@(cadr x)_tag = scheme_make_type("<@(car x)>")})
(if (equal? (cadr x) "ctype")
@list{ctype_tag = scheme_ctype_type}
@list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}))
(reverse (cstructs)))
@@IFDEF{MZ_PRECISE_GC}{
@(maplines (lambda (x)
@ -3256,7 +3278,7 @@ void scheme_init_foreign_globals()
@(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)})
(reverse (cstructs)))
}
scheme_set_type_printer(ctype_tag, ctype_printer);
scheme_set_type_printer(scheme_ctype_type, ctype_printer);
@(maplines (lambda (sym)
@list{MZ_REGISTER_STATIC(@(cadr sym));
@(cadr sym) = scheme_intern_symbol("@(car sym)")})
@ -3286,9 +3308,9 @@ void scheme_init_foreign(Scheme_Env *env)
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
@(maplines
(lambda (x)
(define-values (sname cfun min max) (apply values x))
@list{scheme_add_global("@sname",
scheme_make_prim_w_arity(@cfun, "@sname", @min, @max), menv)})
(define-values (sname cfun min max kind) (apply values x))
@list{scheme_add_global_constant("@sname",
scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), menv)})
(reverse (cfunctions)))
@(map-types
;; no need for these, at least for now:
@ -3298,16 +3320,24 @@ void scheme_init_foreign(Scheme_Env *env)
@cmake["t" ctype "s"
@list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
@list{(Scheme_Object*)FOREIGN_@cname}]
scheme_add_global("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
MZ_REGISTER_STATIC(ffi_env);
ffi_env = menv;
}
Scheme_Env *scheme_get_foreign_env() {
return ffi_env;
}
/*****************************************************************************/
#else /* DONT_USE_FOREIGN */
static Scheme_Env *ffi_env = NULL;
int scheme_is_cpointer(Scheme_Object *cp)
{
return (SCHEME_FALSEP(cp)
@ -3353,15 +3383,21 @@ void scheme_init_foreign(Scheme_Env *env)
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
@(maplines
(lambda (x)
(define-values (sname cfun min max) (apply values x))
@list{scheme_add_global("@sname",
scheme_make_prim_w_arity((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), menv)})
(define-values (sname cfun min max kind) (apply values x))
@list{scheme_add_global_constant("@sname",
scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), menv)})
(reverse (cfunctions)))
@(map-types
@list{scheme_add_global("_@stype", scheme_false, menv)})
@list{scheme_add_global_constant("_@stype", scheme_false, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);
scheme_protect_primitive_provide(menv, NULL);
MZ_REGISTER_STATIC(ffi_env);
ffi_env = menv;
}
Scheme_Env *scheme_get_foreign_env() {
return ffi_env;
}
#endif

17
racket/src/foreign/rktc-utils.rkt
View File

@ -51,9 +51,9 @@
;; User function definition
(provide cfunctions)
(define cfunctions (make-parameter '()))
(define (_cdefine name minargs maxargs . body)
(define (_cdefine name minargs maxargs kind . body)
(define cname @list{foreign_@(racket-id->c-name name)})
(cfunctions (cons (list name cname minargs maxargs) (cfunctions)))
(cfunctions (cons (list name cname minargs maxargs kind) (cfunctions)))
@list{@disable-prefix{#define MYNAME "@name"}
static Scheme_Object *@|cname|(int argc, Scheme_Object *argv[])
{
@ -63,11 +63,18 @@
(provide cdefine)
(define-syntax (cdefine stx)
(syntax-case stx ()
[(_ name minargs maxargs #:kind kind body ...)
(number? (syntax-e #'maxargs))
#'(_cdefine `name minargs maxargs `kind body ...)]
[(_ name minargs maxargs body ...)
(number? (syntax-e #'maxargs))
#'(_cdefine `name minargs maxargs body ...)]
;; Default is 'noncm, because anything that involves
;; cpointers can involve a structure-type property
#'(_cdefine `name minargs maxargs 'noncm body ...)]
[(_ name args #:kind kind body ...)
#'(_cdefine `name args args `kind body ...)]
[(_ name args body ...)
#'(_cdefine `name args args body ...)]))
#'(_cdefine `name args args 'noncm body ...)]))
;; Struct definitions
(provide cstructs)
@ -93,7 +100,7 @@
@(maplines (lambda (s t) @list{@t @s}) slots types)
} @|cname|_struct;
#define SCHEME_@|mname|P(x) (SCHEME_TYPE(x)==@|cname|_tag)
@_cdefine[predname 1 1]{
@_cdefine[predname 1 1 'immed]{
return SCHEME_@|mname|P(argv[0]) ? scheme_true : scheme_false@";"
}
/* 3m stuff for @cname */

13
racket/src/racket/src/compenv.c
View File

@ -2037,7 +2037,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
|| scheme_is_unsafe_modname(modname)
|| scheme_is_flfxnum_modname(modname)
|| scheme_is_extfl_modname(modname)
|| scheme_is_futures_modname(modname))
|| scheme_is_futures_modname(modname)
|| scheme_is_foreign_modname(modname))
|| (flags & SCHEME_REFERENCING))) {
/* Create a module variable reference, so that idx is preserved: */
return scheme_hash_module_variable(env->genv, modidx, find_id,
@ -2131,6 +2132,16 @@ Scheme_Object *scheme_extract_futures(Scheme_Object *o)
return NULL;
}
Scheme_Object *scheme_extract_foreign(Scheme_Object *o)
{
Scheme_Env *home;
home = scheme_get_bucket_home((Scheme_Bucket *)o);
if (home && home->module && scheme_is_foreign_modname(home->module->modname))
return (Scheme_Object *)((Scheme_Bucket *)o)->val;
else
return NULL;
}
int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame)
{
int any_use;

2
racket/src/racket/src/compile.c
View File

@ -4570,6 +4570,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
return scheme_extract_extfl(var);
} else if (scheme_extract_futures(var)) {
return scheme_extract_futures(var);
} else if (scheme_extract_foreign(var)) {
return scheme_extract_foreign(var);
}
}
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)

3030
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

53
racket/src/racket/src/env.c
View File

@ -393,7 +393,8 @@ static void init_extfl(Scheme_Env *env)
extfl_env->attached = 1;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT)) {
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT
+ EXPECTED_EXTFL_COUNT)) {
printf("extfl count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT,
EXPECTED_EXTFL_COUNT);
@ -418,9 +419,34 @@ static void init_futures(Scheme_Env *env)
futures_env->attached = 1;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) {
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT
+ EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) {
printf("Futures count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT - EXPECTED_EXTFL_COUNT, EXPECTED_FUTURES_COUNT);
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT
- EXPECTED_EXTFL_COUNT,
EXPECTED_FUTURES_COUNT);
abort();
}
#endif
}
static void init_foreign(Scheme_Env *env)
{
Scheme_Env *ffi_env;
scheme_init_foreign(env);
ffi_env = scheme_get_foreign_env();
scheme_populate_pt_ht(ffi_env->module->me->rt);
ffi_env->attached = 1;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT
+ EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT + EXPECTED_FOREIGN_COUNT)) {
printf("Foreign count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT
- EXPECTED_EXTFL_COUNT - EXPECTED_FUTURES_COUNT,
EXPECTED_FOREIGN_COUNT);
abort();
}
#endif
@ -536,8 +562,6 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
#endif
scheme_init_futures_per_place();
scheme_init_foreign(env);
REGISTER_SO(literal_string_table);
REGISTER_SO(literal_number_table);
literal_string_table = scheme_make_weak_equal_table();
@ -787,6 +811,7 @@ static void make_kernel_env(void)
init_flfxnum(env);
init_extfl(env);
init_futures(env);
init_foreign(env);
scheme_init_print_global_constants();
scheme_init_variable_references_constants();
@ -1444,7 +1469,7 @@ Scheme_Object **scheme_make_builtin_references_table(void)
t[j] = scheme_false;
}
for (j = 0; j < 5; j++) {
for (j = 0; j < 6; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
@ -1453,8 +1478,10 @@ Scheme_Object **scheme_make_builtin_references_table(void)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
else if (j == 4)
kenv = futures_env;
else
kenv = scheme_get_foreign_env();
ht = kenv->toplevel;
@ -1481,7 +1508,7 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
result = scheme_make_hash_table(SCHEME_hash_ptr);
for (j = 0; j < 5; j++) {
for (j = 0; j < 6; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
@ -1490,8 +1517,10 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
else if (j == 4)
kenv = futures_env;
else
kenv = scheme_get_foreign_env();
ht = kenv->toplevel;
bs = ht->buckets;
@ -1515,7 +1544,7 @@ const char *scheme_look_for_primitive(void *code)
intptr_t i;
int j;
for (j = 0; j < 5; j++) {
for (j = 0; j < 6; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
@ -1524,8 +1553,10 @@ const char *scheme_look_for_primitive(void *code)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
else if (j == 4)
kenv = futures_env;
else
kenv = scheme_get_foreign_env();
ht = kenv->toplevel;
bs = ht->buckets;

29
racket/src/racket/src/module.c
View File

@ -181,6 +181,7 @@ READ_ONLY static Scheme_Object *flfxnum_modname;
READ_ONLY static Scheme_Object *extfl_modname;
READ_ONLY static Scheme_Object *futures_modname;
READ_ONLY static Scheme_Object *unsafe_modname;
READ_ONLY static Scheme_Object *foreign_modname;
/* global read-only phase wraps */
READ_ONLY static Scheme_Object *scheme_sys_wraps0;
@ -429,6 +430,7 @@ void scheme_init_module(Scheme_Env *env)
REGISTER_SO(flfxnum_modname);
REGISTER_SO(extfl_modname);
REGISTER_SO(futures_modname);
REGISTER_SO(foreign_modname);
kernel_symbol = scheme_intern_symbol("#%kernel");
kernel_modname = scheme_intern_resolved_module_path(kernel_symbol);
kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol,
@ -440,6 +442,7 @@ void scheme_init_module(Scheme_Env *env)
flfxnum_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%flfxnum"));
extfl_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%extfl"));
futures_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%futures"));
foreign_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%foreign"));
REGISTER_SO(module_begin_symbol);
module_begin_symbol = scheme_intern_symbol("#%module-begin");
@ -780,6 +783,11 @@ int scheme_is_futures_modname(Scheme_Object *modname)
return SAME_OBJ(modname, futures_modname);
}
int scheme_is_foreign_modname(Scheme_Object *modname)
{
return SAME_OBJ(modname, foreign_modname);
}
Scheme_Module *get_special_module(Scheme_Object *name)
{
if (SAME_OBJ(name, kernel_modname))
@ -792,6 +800,8 @@ Scheme_Module *get_special_module(Scheme_Object *name)
return scheme_get_extfl_env()->module;
else if (SAME_OBJ(name, futures_modname))
return scheme_get_futures_env()->module;
else if (SAME_OBJ(name, foreign_modname))
return scheme_get_foreign_env()->module;
else
return NULL;
}
@ -808,6 +818,8 @@ Scheme_Env *get_special_modenv(Scheme_Object *name)
return scheme_get_futures_env();
else if (SAME_OBJ(name, unsafe_modname))
return scheme_get_unsafe_env();
else if (SAME_OBJ(name, foreign_modname))
return scheme_get_foreign_env();
else
return NULL;
}
@ -818,7 +830,8 @@ static int is_builtin_modname(Scheme_Object *modname)
|| SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname));
|| SAME_OBJ(modname, futures_modname)
|| SAME_OBJ(modname, foreign_modname));
}
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env)
@ -2339,7 +2352,8 @@ static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]
if (!SAME_OBJ(name, kernel_modname)
&& !SAME_OBJ(name, flfxnum_modname)
&& !SAME_OBJ(name, extfl_modname)
&& !SAME_OBJ(name, futures_modname)) {
&& !SAME_OBJ(name, futures_modname)
&& !SAME_OBJ(name, foreign_modname)) {
if (SAME_OBJ(name, unsafe_modname))
menv2 = scheme_get_unsafe_env();
else
@ -4733,7 +4747,8 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem
|| SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname))
|| SAME_OBJ(modname, futures_modname)
|| SAME_OBJ(modname, foreign_modname))
return -1;
m = module_load(modname, env, NULL);
@ -4767,7 +4782,8 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env,
} else if (SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname)) {
|| SAME_OBJ(modname, futures_modname)
|| SAME_OBJ(modname, foreign_modname)) {
/* no unsafe, flfxnum, extfl, or futures syntax */
return NULL;
} else {
@ -7200,7 +7216,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
|| SAME_OBJ(m->modname, unsafe_modname)
|| SAME_OBJ(m->modname, flfxnum_modname)
|| SAME_OBJ(m->modname, extfl_modname)
|| SAME_OBJ(m->modname, futures_modname)) {
|| SAME_OBJ(m->modname, futures_modname)
|| SAME_OBJ(m->modname, foreign_modname)) {
/* Too confusing. Give it a different name while compiling. */
Scheme_Object *k2;
const char *kname;
@ -7212,6 +7229,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
kname = "#%extfl";
else if (SAME_OBJ(m->modname, futures_modname))
kname = "#%futures";
else if (SAME_OBJ(m->modname, foreign_modname))
kname = "#%foreign";
else
kname = "#%unsafe";
k2 = scheme_intern_resolved_module_path(scheme_make_symbol(kname)); /* uninterned! */

1
racket/src/racket/src/print.c
View File

@ -2031,6 +2031,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
|| SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_ctype_type, SCHEME_TYPE(obj))
|| SAME_OBJ(scheme_app_mark_impersonator_property, obj))) {
/* Check whether this is a global constant */
Scheme_Object *val;

5
racket/src/racket/src/read.c
View File

@ -4794,8 +4794,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT
+ EXPECTED_UNSAFE_COUNT
+ EXPECTED_FLFXNUM_COUNT
+ EXPECTED_EXTFL_COUNT
+ EXPECTED_FUTURES_COUNT));
+ EXPECTED_EXTFL_COUNT
+ EXPECTED_FUTURES_COUNT
+ EXPECTED_FOREIGN_COUNT));
return variable_references[l];
break;
case CPT_LOCAL:

1
racket/src/racket/src/schminc.h
View File

@ -19,6 +19,7 @@
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15
#define EXPECTED_FOREIGN_COUNT 78
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

3
racket/src/racket/src/schpriv.h
View File

@ -2737,6 +2737,7 @@ Scheme_Object *scheme_extract_unsafe(Scheme_Object *o);
Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o);
Scheme_Object *scheme_extract_extfl(Scheme_Object *o);
Scheme_Object *scheme_extract_futures(Scheme_Object *o);
Scheme_Object *scheme_extract_foreign(Scheme_Object *o);
Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Comp_Env *upto);
@ -3503,6 +3504,7 @@ Scheme_Env *scheme_get_unsafe_env();
Scheme_Env *scheme_get_flfxnum_env();
Scheme_Env *scheme_get_extfl_env();
Scheme_Env *scheme_get_futures_env();
Scheme_Env *scheme_get_foreign_env();
void scheme_install_initial_module_set(Scheme_Env *env);
Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home);
@ -3518,6 +3520,7 @@ int scheme_is_unsafe_modname(Scheme_Object *modname);
int scheme_is_flfxnum_modname(Scheme_Object *modname);
int scheme_is_extfl_modname(Scheme_Object *modname);
int scheme_is_futures_modname(Scheme_Object *modname);
int scheme_is_foreign_modname(Scheme_Object *modname);
void scheme_clear_modidx_cache(void);
void scheme_clear_shift_cache(void);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.0.0.2"
#define MZSCHEME_VERSION "6.0.0.3"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

147
racket/src/racket/src/stypes.h
View File

@ -210,83 +210,84 @@ enum {
scheme_phantom_bytes_type, /* 186 */
scheme_environment_variables_type, /* 187 */
scheme_filesystem_change_evt_type, /* 188 */
scheme_ctype_type, /* 189 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 189 */
_scheme_last_normal_type_, /* 190 */
scheme_rt_weak_array, /* 190 */
scheme_rt_weak_array, /* 191 */
scheme_rt_comp_env, /* 191 */
scheme_rt_constant_binding, /* 192 */
scheme_rt_resolve_info, /* 193 */
scheme_rt_unresolve_info, /* 194 */
scheme_rt_optimize_info, /* 195 */
scheme_rt_compile_info, /* 196 */
scheme_rt_cont_mark, /* 197 */
scheme_rt_saved_stack, /* 198 */
scheme_rt_reply_item, /* 199 */
scheme_rt_closure_info, /* 200 */
scheme_rt_overflow, /* 201 */
scheme_rt_overflow_jmp, /* 202 */
scheme_rt_meta_cont, /* 203 */
scheme_rt_dyn_wind_cell, /* 204 */
scheme_rt_dyn_wind_info, /* 205 */
scheme_rt_dyn_wind, /* 206 */
scheme_rt_dup_check, /* 207 */
scheme_rt_thread_memory, /* 208 */
scheme_rt_input_file, /* 209 */
scheme_rt_input_fd, /* 210 */
scheme_rt_oskit_console_input, /* 211 */
scheme_rt_tested_input_file, /* 212 */
scheme_rt_tested_output_file, /* 213 */
scheme_rt_indexed_string, /* 214 */
scheme_rt_output_file, /* 215 */
scheme_rt_load_handler_data, /* 216 */
scheme_rt_pipe, /* 217 */
scheme_rt_beos_process, /* 218 */
scheme_rt_system_child, /* 219 */
scheme_rt_tcp, /* 220 */
scheme_rt_write_data, /* 221 */
scheme_rt_tcp_select_info, /* 222 */
scheme_rt_param_data, /* 223 */
scheme_rt_will, /* 224 */
scheme_rt_linker_name, /* 225 */
scheme_rt_param_map, /* 226 */
scheme_rt_finalization, /* 227 */
scheme_rt_finalizations, /* 228 */
scheme_rt_cpp_object, /* 229 */
scheme_rt_cpp_array_object, /* 230 */
scheme_rt_stack_object, /* 231 */
scheme_rt_preallocated_object, /* 232 */
scheme_thread_hop_type, /* 233 */
scheme_rt_srcloc, /* 234 */
scheme_rt_evt, /* 235 */
scheme_rt_syncing, /* 236 */
scheme_rt_comp_prefix, /* 237 */
scheme_rt_user_input, /* 238 */
scheme_rt_user_output, /* 239 */
scheme_rt_compact_port, /* 240 */
scheme_rt_read_special_dw, /* 241 */
scheme_rt_regwork, /* 242 */
scheme_rt_rx_lazy_string, /* 243 */
scheme_rt_buf_holder, /* 244 */
scheme_rt_parameterization, /* 245 */
scheme_rt_print_params, /* 246 */
scheme_rt_read_params, /* 247 */
scheme_rt_native_code, /* 248 */
scheme_rt_native_code_plus_case, /* 249 */
scheme_rt_jitter_data, /* 250 */
scheme_rt_module_exports, /* 251 */
scheme_rt_delay_load_info, /* 252 */
scheme_rt_marshal_info, /* 253 */
scheme_rt_unmarshal_info, /* 254 */
scheme_rt_runstack, /* 255 */
scheme_rt_sfs_info, /* 256 */
scheme_rt_validate_clearing, /* 257 */
scheme_rt_avl_node, /* 258 */
scheme_rt_lightweight_cont, /* 259 */
scheme_rt_export_info, /* 260 */
scheme_rt_cont_jmp, /* 261 */
scheme_rt_comp_env, /* 192 */
scheme_rt_constant_binding, /* 193 */
scheme_rt_resolve_info, /* 194 */
scheme_rt_unresolve_info, /* 195 */
scheme_rt_optimize_info, /* 196 */
scheme_rt_compile_info, /* 197 */
scheme_rt_cont_mark, /* 198 */
scheme_rt_saved_stack, /* 199 */
scheme_rt_reply_item, /* 200 */
scheme_rt_closure_info, /* 201 */
scheme_rt_overflow, /* 202 */
scheme_rt_overflow_jmp, /* 203 */
scheme_rt_meta_cont, /* 204 */
scheme_rt_dyn_wind_cell, /* 205 */
scheme_rt_dyn_wind_info, /* 206 */
scheme_rt_dyn_wind, /* 207 */
scheme_rt_dup_check, /* 208 */
scheme_rt_thread_memory, /* 209 */
scheme_rt_input_file, /* 210 */
scheme_rt_input_fd, /* 211 */
scheme_rt_oskit_console_input, /* 212 */
scheme_rt_tested_input_file, /* 213 */
scheme_rt_tested_output_file, /* 214 */
scheme_rt_indexed_string, /* 215 */
scheme_rt_output_file, /* 216 */
scheme_rt_load_handler_data, /* 217 */
scheme_rt_pipe, /* 218 */
scheme_rt_beos_process, /* 219 */
scheme_rt_system_child, /* 220 */
scheme_rt_tcp, /* 221 */
scheme_rt_write_data, /* 222 */
scheme_rt_tcp_select_info, /* 223 */
scheme_rt_param_data, /* 224 */
scheme_rt_will, /* 225 */
scheme_rt_linker_name, /* 226 */
scheme_rt_param_map, /* 227 */
scheme_rt_finalization, /* 228 */
scheme_rt_finalizations, /* 229 */
scheme_rt_cpp_object, /* 230 */
scheme_rt_cpp_array_object, /* 231 */
scheme_rt_stack_object, /* 232 */
scheme_rt_preallocated_object, /* 233 */
scheme_thread_hop_type, /* 234 */
scheme_rt_srcloc, /* 235 */
scheme_rt_evt, /* 236 */
scheme_rt_syncing, /* 237 */
scheme_rt_comp_prefix, /* 238 */
scheme_rt_user_input, /* 239 */
scheme_rt_user_output, /* 240 */
scheme_rt_compact_port, /* 241 */
scheme_rt_read_special_dw, /* 242 */
scheme_rt_regwork, /* 243 */
scheme_rt_rx_lazy_string, /* 244 */
scheme_rt_buf_holder, /* 245 */
scheme_rt_parameterization, /* 246 */
scheme_rt_print_params, /* 247 */
scheme_rt_read_params, /* 248 */
scheme_rt_native_code, /* 249 */
scheme_rt_native_code_plus_case, /* 250 */
scheme_rt_jitter_data, /* 251 */
scheme_rt_module_exports, /* 252 */
scheme_rt_delay_load_info, /* 253 */
scheme_rt_marshal_info, /* 254 */
scheme_rt_unmarshal_info, /* 255 */
scheme_rt_runstack, /* 256 */
scheme_rt_sfs_info, /* 257 */
scheme_rt_validate_clearing, /* 258 */
scheme_rt_avl_node, /* 259 */
scheme_rt_lightweight_cont, /* 260 */
scheme_rt_export_info, /* 261 */
scheme_rt_cont_jmp, /* 262 */
#endif
_scheme_last_type_