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

adjust _float' and _double' FFI types to accept any inexact real

Browse Source 
whether single-precision or double-precision
This commit is contained in:
Matthew Flatt 2011-01-31 17:58:35 -07:00
parent f9bcdc9baf
commit 1e09a544a6
3 changed files with 12 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/racket/foreign-test.rktl
View File

@ -374,7 +374,9 @@ added.
(foo-test "foo_byte" '(156) (_fun _byte -> _byte)) (foo-test "foo_byte" '(156) (_fun _byte -> _byte))
(foo-test "foo_ubyte" '(156) (_fun _ubyte -> _ubyte)) (foo-test "foo_ubyte" '(156) (_fun _ubyte -> _ubyte))
(foo-test "foo_double" '(81.0) (_fun _double -> _double)) (foo-test "foo_double" '(81.0) (_fun _double -> _double))
(foo-test "foo_double" '(81.0f0) (_fun _double -> _double))
(foo-test "foo_float" '(81.0) (_fun _float -> _float)) (foo-test "foo_float" '(81.0) (_fun _float -> _float))
(foo-test "foo_float" '(81.0f0) (_fun _float -> _float))
(exit) ;======================================================================= (exit) ;=======================================================================
(newline) (newline)

16
src/foreign/foreign.c
View File

@ -674,8 +674,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Type Name: float /* Type Name: float
* LibFfi type: ffi_type_float * LibFfi type: ffi_type_float
* C type: float * C type: float
* Predicate: SCHEME_FLTP(<Scheme>) * Predicate: SCHEME_FLOATP(<Scheme>)
* Scheme->C: SCHEME_FLT_VAL(<Scheme>) * Scheme->C: SCHEME_FLOAT_VAL(<Scheme>)
* S->C offset: 0 * S->C offset: 0
* C->Scheme: scheme_make_float(<C>) * C->Scheme: scheme_make_float(<C>)
*/ */
@ -684,8 +684,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Type Name: double /* Type Name: double
* LibFfi type: ffi_type_double * LibFfi type: ffi_type_double
* C type: double * C type: double
* Predicate: SCHEME_DBLP(<Scheme>) * Predicate: SCHEME_FLOATP(<Scheme>)
* Scheme->C: SCHEME_DBL_VAL(<Scheme>) * Scheme->C: SCHEME_FLOAT_VAL(<Scheme>)
* S->C offset: 0 * S->C offset: 0
* C->Scheme: scheme_make_double(<C>) * C->Scheme: scheme_make_double(<C>)
*/ */
@ -1507,9 +1507,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
delta += (sizeof(int)-sizeof(float)); delta += (sizeof(int)-sizeof(float));
} }
# endif /* SCHEME_BIG_ENDIAN */ # endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FLTP(val)) { if (SCHEME_FLOATP(val)) {
float tmp; float tmp;
tmp = (float)(SCHEME_FLT_VAL(val)); tmp = (float)(SCHEME_FLOAT_VAL(val));
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else { } else {
scheme_wrong_type("Scheme->C","float",0,1,&(val)); scheme_wrong_type("Scheme->C","float",0,1,&(val));
@ -1522,9 +1522,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta,
delta += (sizeof(int)-sizeof(double)); delta += (sizeof(int)-sizeof(double));
} }
# endif /* SCHEME_BIG_ENDIAN */ # endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_DBLP(val)) { if (SCHEME_FLOATP(val)) {
double tmp; double tmp;
tmp = (double)(SCHEME_DBL_VAL(val)); tmp = (double)(SCHEME_FLOAT_VAL(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else { } else {
scheme_wrong_type("Scheme->C","double",0,1,&(val)); scheme_wrong_type("Scheme->C","double",0,1,&(val));

4
src/foreign/foreign.rktc
View File

@ -640,9 +640,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
@(defctype* '(ufixnum "umzintptr") @(defctype* '(ufixnum "umzintptr")
"uintptr_t" "INT" "UINT" "integer_from_unsigned") "uintptr_t" "INT" "UINT" "integer_from_unsigned")
@(defctype* 'float "float" "FLT" "FLT" "float") @(defctype* 'float "float" "FLOAT" "FLOAT" "float")
@(defctype* 'double "double" "DBL" "DBL" "double") @(defctype* 'double "double" "FLOAT" "FLOAT" "double")
@; @;
@; Not useful? not implemented in any case. @; Not useful? not implemented in any case.
@; (defctype* 'longdouble "long double" ...???...) @; (defctype* 'longdouble "long double" ...???...)