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

avoid mis-aligned pointer (relevant for 3m) in ffi-set

Browse Source 
svn: r3973
This commit is contained in:
Matthew Flatt 2006-08-05 12:57:59 +00:00
parent b49af61b7c
commit 2211493242
2 changed files with 94 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

151
src/foreign/foreign.c
View File

@ -1078,7 +1078,7 @@ END_XFORM_SKIP;
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif
#define W_OFFSET(src, delta) ((char *)(src)+(delta))
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
{
@ -1135,16 +1135,16 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
* the function is different: in the relevant cases zero an int and offset the
* ptr */
#ifdef SCHEME_BIG_ENDIAN
#define SCHEME2C(typ,dst,val,basep,retloc) scheme_to_c(typ,dst,val,basep,retloc)
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
#else
#define SCHEME2C(typ,dst,val,basep,retloc) scheme_to_c(typ,dst,val,basep)
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
#endif
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
* NULL, then any pointer value (any pointer or a struct) is returned, and the
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
* then a struct value will be *copied* into dst. */
static void* SCHEME2C(Scheme_Object *type, void *dst,
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
Scheme_Object *val, long *basetype_p,
int ret_loc)
{
@ -1158,12 +1158,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
if (SCHEME_FFICALLBACKP(val))
((void**)dst)[0] = ((ffi_callback_struct*)val)->callback;
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val))
((void**)dst)[0] = SCHEME_CPTR_VAL(val);
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val))
((void**)dst)[0] = ((ffi_obj_struct*)val)->obj;
else /* ((void**)dst)[0] = val; */
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void:
@ -1171,14 +1171,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_int8:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tsint8));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint8));
}
#endif
if (SCHEME_INTP(val)) {
Tsint8 tmp;
tmp = (Tsint8)(SCHEME_INT_VAL(val));
(((Tsint8*)dst)[0]) = tmp; return NULL;
(((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","int8",0,1,&(val));
return NULL; /* shush the compiler */
@ -1186,14 +1186,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_uint8:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint8)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tuint8));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint8));
}
#endif
if (SCHEME_INTP(val)) {
Tuint8 tmp;
tmp = (Tuint8)(SCHEME_UINT_VAL(val));
(((Tuint8*)dst)[0]) = tmp; return NULL;
(((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","uint8",0,1,&(val));
return NULL; /* shush the compiler */
@ -1201,14 +1201,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_int16:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint16)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tsint16));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint16));
}
#endif
if (SCHEME_INTP(val)) {
Tsint16 tmp;
tmp = (Tsint16)(SCHEME_INT_VAL(val));
(((Tsint16*)dst)[0]) = tmp; return NULL;
(((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","int16",0,1,&(val));
return NULL; /* shush the compiler */
@ -1216,41 +1216,41 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_uint16:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint16)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tuint16));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint16));
}
#endif
if (SCHEME_INTP(val)) {
Tuint16 tmp;
tmp = (Tuint16)(SCHEME_UINT_VAL(val));
(((Tuint16*)dst)[0]) = tmp; return NULL;
(((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","uint16",0,1,&(val));
return NULL; /* shush the compiler */
}
case FOREIGN_int32:
if (!(scheme_get_realint_val(val,&(((Tsint32*)dst)[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val));
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*)dst)[0])))) scheme_wrong_type("Scheme->C","uint32",0,1,&(val));
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*)dst)[0])))) scheme_wrong_type("Scheme->C","int64",0,1,&(val));
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*)dst)[0])))) scheme_wrong_type("Scheme->C","uint64",0,1,&(val));
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*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tsint32));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tsint32));
}
#endif
if (SCHEME_INTP(val)) {
Tsint32 tmp;
tmp = (Tsint32)(SCHEME_INT_VAL(val));
(((Tsint32*)dst)[0]) = tmp; return NULL;
(((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","fixint",0,1,&(val));
return NULL; /* shush the compiler */
@ -1258,14 +1258,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_ufixint:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tuint32)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Tuint32));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Tuint32));
}
#endif
if (SCHEME_INTP(val)) {
Tuint32 tmp;
tmp = (Tuint32)(SCHEME_UINT_VAL(val));
(((Tuint32*)dst)[0]) = tmp; return NULL;
(((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","ufixint",0,1,&(val));
return NULL; /* shush the compiler */
@ -1273,14 +1273,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_fixnum:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(long)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(long));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(long));
}
#endif
if (SCHEME_INTP(val)) {
long tmp;
tmp = (long)(SCHEME_INT_VAL(val));
(((long*)dst)[0]) = tmp; return NULL;
(((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","fixnum",0,1,&(val));
return NULL; /* shush the compiler */
@ -1288,14 +1288,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_ufixnum:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned long)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(unsigned long));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned long));
}
#endif
if (SCHEME_INTP(val)) {
unsigned long tmp;
tmp = (unsigned long)(SCHEME_UINT_VAL(val));
(((unsigned long*)dst)[0]) = tmp; return NULL;
(((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val));
return NULL; /* shush the compiler */
@ -1303,14 +1303,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_float:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(float)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(float));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(float));
}
#endif
if (SCHEME_FLTP(val)) {
float tmp;
tmp = (float)(SCHEME_FLT_VAL(val));
(((float*)dst)[0]) = tmp; return NULL;
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","float",0,1,&(val));
return NULL; /* shush the compiler */
@ -1318,14 +1318,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_double:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(double)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(double));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(double));
}
#endif
if (SCHEME_DBLP(val)) {
double tmp;
tmp = (double)(SCHEME_DBL_VAL(val));
(((double*)dst)[0]) = tmp; return NULL;
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","double",0,1,&(val));
return NULL; /* shush the compiler */
@ -1333,14 +1333,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_doubleS:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(double)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(double));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(double));
}
#endif
if (SCHEME_REALP(val)) {
double tmp;
tmp = (double)(scheme_real_to_double(val));
(((double*)dst)[0]) = tmp; return NULL;
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","double*",0,1,&(val));
return NULL; /* shush the compiler */
@ -1348,14 +1348,14 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_bool:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(int)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(int));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(int));
}
#endif
if (1) {
int tmp;
tmp = (int)(SCHEME_TRUEP(val));
(((int*)dst)[0]) = tmp; return NULL;
(((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
scheme_wrong_type("Scheme->C","bool",0,1,&(val));
return NULL; /* shush the compiler */
@ -1363,15 +1363,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_string_ucs_4:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(mzchar*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(mzchar*));
}
#endif
if (SCHEME_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(SCHEME_CHAR_STR_VAL(val));
if (basetype_p == NULL || tmp == NULL) {
(((mzchar**)dst)[0]) = tmp; return NULL;
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_string_ucs_4; return tmp;
}
@ -1382,15 +1382,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_string_utf_16:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(unsigned short*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*));
}
#endif
if (SCHEME_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_to_utf16_pointer(val));
if (basetype_p == NULL || tmp == NULL) {
(((unsigned short**)dst)[0]) = tmp; return NULL;
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_string_utf_16; return tmp;
}
@ -1401,15 +1401,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_bytes:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(char*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
#endif
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**)dst)[0]) = tmp; return NULL;
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_bytes; return tmp;
}
@ -1420,15 +1420,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_path:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(char*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
#endif
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**)dst)[0]) = tmp; return NULL;
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_path; return tmp;
}
@ -1439,15 +1439,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_symbol:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(char*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(char*));
}
#endif
if (SCHEME_SYMBOLP(val)) {
char* tmp;
tmp = (char*)(SCHEME_SYM_VAL(val));
if (basetype_p == NULL || tmp == NULL) {
(((char**)dst)[0]) = tmp; return NULL;
(((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_symbol; return tmp;
}
@ -1458,15 +1458,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_pointer:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(void*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(void*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(void*));
}
#endif
if (SCHEME_FFIANYPTRP(val)) {
void* tmp;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
if (basetype_p == NULL || tmp == NULL) {
(((void**)dst)[0]) = tmp; return NULL;
(((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_pointer; return tmp;
}
@ -1477,15 +1477,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
case FOREIGN_scheme:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
((int*)dst)[0] = 0;
dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof(Scheme_Object*));
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(Scheme_Object*));
}
#endif
if (1) {
Scheme_Object* tmp;
tmp = (Scheme_Object*)(val);
if (basetype_p == NULL || tmp == NULL) {
(((Scheme_Object**)dst)[0]) = tmp; return NULL;
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
*basetype_p = FOREIGN_scheme; return tmp;
}
@ -1501,7 +1501,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
if (basetype_p == NULL) {
void* p = SCHEME_FFIANYPTR_VAL(val);
if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
memcpy(dst, p, CTYPE_PRIMTYPE(type)->size);
memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
return NULL;
} else {
*basetype_p = FOREIGN_struct;
@ -1808,6 +1808,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
{
int size=0; void *ptr;
long delta = 0;
Scheme_Object *val = argv[argc-1], *base;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
@ -1839,13 +1840,13 @@ static Scheme_Object *foreign_ptr_set(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS SCHEME_INT_VAL(argv[3]);
delta = SCHEME_INT_VAL(argv[3]);
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2]));
delta = (size * SCHEME_INT_VAL(argv[2]));
}
SCHEME2C(argv[1], ptr, val, NULL, 0);
SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
return scheme_void;
}
@ -1981,7 +1982,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* iterate on input values and types */
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
/* convert argv[i] according to current itype */
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), argv[i], &basetype, 0);
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
if (p != NULL) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
@ -2128,7 +2129,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, p, NULL, 1);
SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
}
/* see ffi-callback below */

35
src/foreign/foreign.ssc
View File

@ -906,7 +906,7 @@ void free_libffi_type(void *ignored, void *p)
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif
#define W_OFFSET(src, delta) ((char *)(src)+(delta))
#define W_OFFSET(src, delta) ((char *)(src) XFORM_OK_PLUS (delta))
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int args_loc)
{
@ -944,16 +944,16 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, int delta, int ar
* the function is different: in the relevant cases zero an int and offset the
* ptr */
#ifdef SCHEME_BIG_ENDIAN
#define SCHEME2C(typ,dst,val,basep,retloc) scheme_to_c(typ,dst,val,basep,retloc)
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep,retloc)
#else
#define SCHEME2C(typ,dst,val,basep,retloc) scheme_to_c(typ,dst,val,basep)
#define SCHEME2C(typ,dst,delta,val,basep,retloc) scheme_to_c(typ,dst,delta,val,basep)
#endif
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
* NULL, then any pointer value (any pointer or a struct) is returned, and the
* basetype_p is set to the corrsponding number tag. If basetype_p is NULL,
* then a struct value will be *copied* into dst. */
static void* SCHEME2C(Scheme_Object *type, void *dst,
static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
Scheme_Object *val, long *basetype_p,
int ret_loc)
{
@ -967,12 +967,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
if (SCHEME_FFICALLBACKP(val))
((void**)dst)[0] = ((ffi_callback_struct*)val)->callback;
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val))
((void**)dst)[0] = SCHEME_CPTR_VAL(val);
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val))
((void**)dst)[0] = ((ffi_obj_struct*)val)->obj;
else /* ((void**)dst)[0] = val; */
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
{:(for-each-type
@ -980,15 +980,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
(list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));"))
(~ "case FOREIGN_"cname":")
(if ctype
(let* ([x (list "((("ctype"*)dst)[0])")]
(let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")]
[f (lambda (p)
(if (procedure? p) (p "val" x) (list p"(val)")))])
(if s->c
(begin
(display "#ifdef SCHEME_BIG_ENDIAN\n")
(~ " if (sizeof("ctype")<sizeof(int) && ret_loc) {" \\
" ((int*)dst)[0] = 0;" \\
" dst = dst XFORM_OK_PLUS (sizeof(int)-sizeof("ctype"));"
" ((int*)W_OFFSET(dst,delta))[0] = 0;" \\
" delta += (sizeof(int)-sizeof("ctype"));"
\\
" }")
(display "#endif\n")
@ -1017,7 +1017,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
if (basetype_p == NULL) {
void* p = SCHEME_FFIANYPTR_VAL(val);
if (p == NULL) scheme_signal_error("FFI pointer value was NULL.");
memcpy(dst, p, CTYPE_PRIMTYPE(type)->size);
memcpy(W_OFFSET(dst, delta), p, CTYPE_PRIMTYPE(type)->size);
return NULL;
} else {
*basetype_p = FOREIGN_struct;
@ -1302,6 +1302,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
{:(cdefine ptr-set! 3 5):}
{
int size=0; void *ptr;
long delta = 0;
Scheme_Object *val = argv[argc-1], *base;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
@ -1333,13 +1334,13 @@ static void* SCHEME2C(Scheme_Object *type, void *dst,
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS SCHEME_INT_VAL(argv[3]);
delta = SCHEME_INT_VAL(argv[3]);
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
ptr = (char*)ptr XFORM_OK_PLUS (size * SCHEME_INT_VAL(argv[2]));
delta = (size * SCHEME_INT_VAL(argv[2]));
}
SCHEME2C(argv[1], ptr, val, NULL, 0);
SCHEME2C(argv[1], ptr, delta, val, NULL, 0);
return scheme_void;
}
@ -1473,7 +1474,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* iterate on input values and types */
for (i=0; i<nargs; i++, itypes=SCHEME_CDR(itypes)) {
/* convert argv[i] according to current itype */
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), argv[i], &basetype, 0);
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype, 0);
if (p != NULL) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
@ -1618,7 +1619,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, p, NULL, 1);
SCHEME2C(data->otype, resultp, 0, p, NULL, 1);
}
/* see ffi-callback below */