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

better macrology for c_to_scheme

Browse Source 
svn: r3682
This commit is contained in:
Eli Barzilay 2006-07-11 20:34:59 +00:00
parent e0a2943e5b
commit f63abcc9de
2 changed files with 28 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
src/foreign/foreign.c
View File

@ -1066,36 +1066,33 @@ END_XFORM_SKIP;
/*****************************************************************************/ /*****************************************************************************/
/* Scheme<-->C conversions */ /* Scheme<-->C conversions */
static Scheme_Object *c_to_scheme(Scheme_Object *type, void *src
/* On big endian machines we need to know whether we're pulling a value from an /* On big endian machines we need to know whether we're pulling a value from an
* argument location where it always takes a whole word or straight from a * argument location where it always takes a whole word or straight from a
* memory location */ * memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN #ifdef SCHEME_BIG_ENDIAN
, int args_loc #define C2SCHEME(typ,src,argsloc) c_to_scheme(typ,src,argsloc)
#endif #define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
)
#ifdef SCHEME_BIG_ENDIAN
#define REF_CTYPE(ctype) ((sizeof(ctype)<sizeof(int)) && args_loc \
? ((ctype)(((int*)src)[0])) : (((ctype *)src)[0])) ? ((ctype)(((int*)src)[0])) : (((ctype *)src)[0]))
#else #else
#define C2SCHEME(typ,src,argsloc) c_to_scheme(typ,src)
#define REF_CTYPE(ctype) (((ctype *)src)[0]) #define REF_CTYPE(ctype) (((ctype *)src)[0])
#endif #endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int args_loc)
{ {
Scheme_Object *res, *base; Scheme_Object *res, *base;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type); base = CTYPE_BASETYPE(type);
if (base != NULL) { if (base != NULL) {
#ifdef SCHEME_BIG_ENDIAN res = C2SCHEME(base, src, args_loc);
res = c_to_scheme(base, src, args_loc);
#else
res = c_to_scheme(base, src);
#endif
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the REF_CTYPE trick for pointers */
return (Scheme_Object*)src; return (Scheme_Object*)src;
} else switch (CTYPE_PRIMLABEL(type)) { } else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void: return scheme_void; case FOREIGN_void: return scheme_void;
@ -1145,6 +1142,7 @@ static void* scheme_to_c(Scheme_Object *type, void *dst,
type = CTYPE_BASETYPE(type); type = CTYPE_BASETYPE(type);
} }
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
if (SCHEME_FFICALLBACKP(val)) if (SCHEME_FFICALLBACKP(val))
((void**)dst)[0] = ((ffi_callback_struct*)val)->callback; ((void**)dst)[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val)) else if (SCHEME_CPTRP(val))
@ -1385,6 +1383,7 @@ static void* scheme_to_c(Scheme_Object *type, void *dst,
} }
return NULL; /* shush the compiler */ return NULL; /* shush the compiler */
} }
#undef SET_CTYPE
/*****************************************************************************/ /*****************************************************************************/
/* C type information */ /* C type information */
@ -1666,11 +1665,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "integer", 2, argc, argv); scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2])); ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2]));
} }
#ifdef SCHEME_BIG_ENDIAN return C2SCHEME(argv[1], ptr, 0);
return c_to_scheme(argv[1], ptr, 0);
#else
return c_to_scheme(argv[1], ptr);
#endif
} }
/* (ptr-set! cpointer type [['abs] n] value) -> void */ /* (ptr-set! cpointer type [['abs] n] value) -> void */
@ -1909,11 +1904,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
} }
break; break;
} }
#ifdef SCHEME_BIG_ENDIAN return C2SCHEME(otype, p, 1);
return c_to_scheme(otype, p, 1);
#else
return c_to_scheme(otype, p);
#endif
} }
/* see below */ /* see below */
@ -2002,11 +1993,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
else else
argv = scheme_malloc(argc * sizeof(Scheme_Object*)); argv = scheme_malloc(argc * sizeof(Scheme_Object*));
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
#ifdef SCHEME_BIG_ENDIAN v = C2SCHEME(SCHEME_CAR(p), args[i], 1);
v = c_to_scheme(SCHEME_CAR(p),args[i],1);
#else
v = c_to_scheme(SCHEME_CAR(p),args[i]);
#endif
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);

41
src/foreign/foreign.ssc
View File

@ -894,36 +894,33 @@ void free_libffi_type(void *ignored, void *p)
/*****************************************************************************/ /*****************************************************************************/
/* Scheme<-->C conversions */ /* Scheme<-->C conversions */
static Scheme_Object *c_to_scheme(Scheme_Object *type, void *src
/* On big endian machines we need to know whether we're pulling a value from an /* On big endian machines we need to know whether we're pulling a value from an
* argument location where it always takes a whole word or straight from a * argument location where it always takes a whole word or straight from a
* memory location */ * memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN #ifdef SCHEME_BIG_ENDIAN
, int args_loc #define C2SCHEME(typ,src,argsloc) c_to_scheme(typ,src,argsloc)
#endif #define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
)
#ifdef SCHEME_BIG_ENDIAN
#define REF_CTYPE(ctype) ((sizeof(ctype)<sizeof(int)) && args_loc \
? ((ctype)(((int*)src)[0])) : (((ctype *)src)[0])) ? ((ctype)(((int*)src)[0])) : (((ctype *)src)[0]))
#else #else
#define C2SCHEME(typ,src,argsloc) c_to_scheme(typ,src)
#define REF_CTYPE(ctype) (((ctype *)src)[0]) #define REF_CTYPE(ctype) (((ctype *)src)[0])
#endif #endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int args_loc)
{ {
Scheme_Object *res, *base; Scheme_Object *res, *base;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type); base = CTYPE_BASETYPE(type);
if (base != NULL) { if (base != NULL) {
#ifdef SCHEME_BIG_ENDIAN res = C2SCHEME(base, src, args_loc);
res = c_to_scheme(base, src, args_loc);
#else
res = c_to_scheme(base, src);
#endif
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the REF_CTYPE trick for pointers */
return (Scheme_Object*)src; return (Scheme_Object*)src;
} else switch (CTYPE_PRIMLABEL(type)) { } else switch (CTYPE_PRIMLABEL(type)) {
{:(for-each-type {:(for-each-type
@ -954,6 +951,7 @@ static void* scheme_to_c(Scheme_Object *type, void *dst,
type = CTYPE_BASETYPE(type); type = CTYPE_BASETYPE(type);
} }
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
if (SCHEME_FFICALLBACKP(val)) if (SCHEME_FFICALLBACKP(val))
((void**)dst)[0] = ((ffi_callback_struct*)val)->callback; ((void**)dst)[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val)) else if (SCHEME_CPTRP(val))
@ -1008,6 +1006,7 @@ static void* scheme_to_c(Scheme_Object *type, void *dst,
} }
return NULL; /* shush the compiler */ return NULL; /* shush the compiler */
} }
#undef SET_CTYPE
/*****************************************************************************/ /*****************************************************************************/
/* C type information */ /* C type information */
@ -1269,11 +1268,7 @@ static void* scheme_to_c(Scheme_Object *type, void *dst,
scheme_wrong_type(MYNAME, "integer", 2, argc, argv); scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2])); ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2]));
} }
#ifdef SCHEME_BIG_ENDIAN return C2SCHEME(argv[1], ptr, 0);
return c_to_scheme(argv[1], ptr, 0);
#else
return c_to_scheme(argv[1], ptr);
#endif
} }
/* (ptr-set! cpointer type [['abs] n] value) -> void */ /* (ptr-set! cpointer type [['abs] n] value) -> void */
@ -1508,11 +1503,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
} }
break; break;
} }
#ifdef SCHEME_BIG_ENDIAN return C2SCHEME(otype, p, 1);
return c_to_scheme(otype, p, 1);
#else
return c_to_scheme(otype, p);
#endif
} }
/* see below */ /* see below */
@ -1599,11 +1590,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
else else
argv = scheme_malloc(argc * sizeof(Scheme_Object*)); argv = scheme_malloc(argc * sizeof(Scheme_Object*));
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
#ifdef SCHEME_BIG_ENDIAN v = C2SCHEME(SCHEME_CAR(p), args[i], 1);
v = c_to_scheme(SCHEME_CAR(p),args[i],1);
#else
v = c_to_scheme(SCHEME_CAR(p),args[i]);
#endif
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);