From 31f5f88889117a3ad31231412caa7b1cd4a61c0c Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sun, 14 Sep 2008 04:17:24 -0700 Subject: [PATCH] first test of ffi works: > (import (ikarus system $foreign)) > (((ffi-prep-cif 'void '(uint32)) (dlsym (dlopen #f) "hello_world")) 10) Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World > --- c64 | 9 +- config.h.in | 9 ++ configure | 266 +++++++++++++++++++++++++++++++++++++- configure.ac | 22 +++- scheme/ikarus.pointers.ss | 39 +++++- scheme/last-revision | 2 +- scheme/makefile.ss | 1 + src/Makefile.am | 2 +- src/Makefile.in | 6 +- src/ikarus-ffi.c | 172 ++++++++++++++++++++++++ src/ikarus-pointers.c | 17 ++- 11 files changed, 525 insertions(+), 20 deletions(-) create mode 100644 src/ikarus-ffi.c diff --git a/c64 b/c64 index 52eb721..cb887c3 100755 --- a/c64 +++ b/c64 @@ -2,8 +2,15 @@ ./configure --prefix=/Users/ikarus/.opt \ --enable-libffi \ - CFLAGS="-m64 -I/Users/ikarus/.opt64/include" \ + CFLAGS="-m64 -I/Users/ikarus/.opt64/include -I/Users/ikarus/.opt64/lib/libffi-3.0.6/include" \ LDFLAGS="-m64 -L/Users/ikarus/.opt64/lib" \ && make clean \ && make +# LIBFFI configuration (on darwin): +# ./configure +# --target=x86_64-darwin +# --build=x86_64-darwin +# --prefix=/Users/ikarus/.opt64 +# CFLAGS=-m64 +# LDFLAGS=-m64 diff --git a/config.h.in b/config.h.in index b82c46c..df662fb 100644 --- a/config.h.in +++ b/config.h.in @@ -1,5 +1,8 @@ /* config.h.in. Generated from configure.ac by autoheader. */ +/* adds support for libffi */ +#undef ENABLE_LIBFFI + /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H @@ -15,6 +18,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H +/* Define to 1 if you have the header file. */ +#undef HAVE_FFI_H + /* Define to 1 if you have the `fork' function. */ #undef HAVE_FORK @@ -33,6 +39,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H +/* Define to 1 if you have the `ffi' library (-lffi). */ +#undef HAVE_LIBFFI + /* Define to 1 if you have the `gmp' library (-lgmp). */ #undef HAVE_LIBGMP diff --git a/configure b/configure index 7bcec7a..f371e15 100755 --- a/configure +++ b/configure @@ -740,6 +740,7 @@ ac_subst_files='' ac_user_opts=' enable_option_checking enable_dependency_tracking +enable_libffi ' ac_precious_vars='build_alias host_alias @@ -1385,6 +1386,7 @@ Optional Features: --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors + --enable-libffi enable support for libffi. Some influential environment variables: CC C compiler command @@ -6645,11 +6647,265 @@ fi ac_cv_lib_gmp=ac_cv_lib_gmp_main -# AC_ARG_ENABLE(libffi, -# [ --enable-libffi enable support for libffi.], -# AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi])) -# AC_CHECK_HEADERS([libffi.h]) -# AC_HAVE_LIBRARY([ffi]) +# Check whether --enable-libffi was given. +if test "${enable_libffi+set}" = set; then + enableval=$enable_libffi; +cat >>confdefs.h <<\_ACEOF +#define ENABLE_LIBFFI 1 +_ACEOF + +fi + + +for ac_header in ffi.h +do +as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 +$as_echo_n "checking for $ac_header... " >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + $as_echo_n "(cached) " >&6 +fi +ac_res=`eval 'as_val=${'$as_ac_Header'} + $as_echo "$as_val"'` + { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 +$as_echo_n "checking $ac_header usability... " >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" +$as_echo "$ac_try_echo") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_header_compiler=yes +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_compiler=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 +$as_echo_n "checking $ac_header presence... " >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" +$as_echo "$ac_try_echo") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + ac_header_preproc=yes +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi + +rm -f conftest.err conftest.$ac_ext +{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +$as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +$as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( cat <<\_ASBOX +## -------------------------------------- ## +## Report this to aghuloum@cs.indiana.edu ## +## -------------------------------------- ## +_ASBOX + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 +$as_echo_n "checking for $ac_header... " >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + $as_echo_n "(cached) " >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +ac_res=`eval 'as_val=${'$as_ac_Header'} + $as_echo "$as_val"'` + { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + +fi +as_val=`eval 'as_val=${'$as_ac_Header'} + $as_echo "$as_val"'` + if test "x$as_val" = x""yes; then + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +else + if test "$enable_libffi" = "yes"; then + { { $as_echo "$as_me:$LINENO: error: ffi.h cannot be found. +Please specify the location of the header file using + ./configure CFLAGS=-I +" >&5 +$as_echo "$as_me: error: ffi.h cannot be found. +Please specify the location of the header file using + ./configure CFLAGS=-I +" >&2;} + { (exit 1); exit 1; }; } + fi +fi + +done + + +{ $as_echo "$as_me:$LINENO: checking for ffi_call in -lffi" >&5 +$as_echo_n "checking for ffi_call in -lffi... " >&6; } +if test "${ac_cv_lib_ffi_ffi_call+set}" = set; then + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lffi $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char ffi_call (); +int +main () +{ +return ffi_call (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" +$as_echo "$ac_try_echo") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + $as_test_x conftest$ac_exeext + }; then + ac_cv_lib_ffi_ffi_call=yes +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_ffi_ffi_call=no +fi + +rm -rf conftest.dSYM +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_ffi_ffi_call" >&5 +$as_echo "$ac_cv_lib_ffi_ffi_call" >&6; } +if test "x$ac_cv_lib_ffi_ffi_call" = x""yes; then + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBFFI 1 +_ACEOF + + LIBS="-lffi $LIBS" + +else + if test "$enable_libffi" = "yes"; then + { { $as_echo "$as_me:$LINENO: error: libffi cannot be found. +Please specify the location of the library file using + ./configure LDFLAGS=-L +" >&5 +$as_echo "$as_me: error: libffi cannot be found. +Please specify the location of the library file using + ./configure LDFLAGS=-L +" >&2;} + { (exit 1); exit 1; }; } + fi +fi + # Checks for typedefs, structures, and compiler characteristics. { $as_echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5 diff --git a/configure.ac b/configure.ac index d518afb..67e2d62 100644 --- a/configure.ac +++ b/configure.ac @@ -63,11 +63,23 @@ ERROR: the gmp.h header file), and LDFLAGS=-L (containing ERROR: libgmp.so) if libgmp is installed in a non-standard location. ERROR: libgmp can be obtained from . ])]) -# AC_ARG_ENABLE(libffi, -# [ --enable-libffi enable support for libffi.], -# AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi])) -# AC_CHECK_HEADERS([libffi.h]) -# AC_HAVE_LIBRARY([ffi]) +AC_ARG_ENABLE(libffi, + [ --enable-libffi enable support for libffi.], + AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi])) +AC_CHECK_HEADERS([ffi.h],, + if test "$enable_libffi" = "yes"; then + AC_MSG_ERROR([ffi.h cannot be found. +Please specify the location of the header file using + ./configure CFLAGS=-I +]) + fi) +AC_CHECK_LIB(ffi,ffi_call,, + if test "$enable_libffi" = "yes"; then + AC_MSG_ERROR([libffi cannot be found. +Please specify the location of the library file using + ./configure LDFLAGS=-L +]) + fi) # Checks for typedefs, structures, and compiler characteristics. AC_C_CONST diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 03ef485..47ceee5 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -4,7 +4,8 @@ dlopen dlerror dlclose dlsym malloc free pointer-ref-char pointer-ref-short pointer-ref-int pointer-ref-long pointer-ref-uchar pointer-ref-ushort pointer-ref-uint pointer-ref-ulong - pointer-set-char pointer-set-short pointer-set-int pointer-set-long) + pointer-set-char pointer-set-short pointer-set-int pointer-set-long + ffi-prep-cif) (import (except (ikarus) pointer? @@ -118,6 +119,42 @@ (define-setter pointer-set-int "ikrt_set_int") (define-setter pointer-set-long "ikrt_set_long") + ;;; libffi interface + + (define (ffi-prep-cif rtype argtypes) + (define who 'ffi-prep-cif) + (define (convert x) + (case x + [(void) 1] + [(uint8) 2] + [(sint8) 3] + [(uint16) 4] + [(sint16) 5] + [(uint32) 6] + [(sint32) 7] + [(uint64) 8] + [(sint64) 9] + [(float) 10] + [(double) 11] + [(pointer) 12] + [else (die who "invalid type" x)])) + (unless (list? argtypes) + (die who "arg types is not a list" argtypes)) + (let ([argtypes-n (vector-map convert (list->vector argtypes))] + [rtype-n (convert rtype)]) + (let ([cif (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n) + (die who "failed to initialize" rtype argtypes))]) + (lambda (cfun) + (define data (vector cif cfun argtypes-n rtype-n)) + (unless (pointer? cfun) + (die 'ffi "not a pointer" cfun)) + (lambda args + (let ([argsvec (list->vector args)]) + (unless (= (vector-length argsvec) + (vector-length argtypes-n)) + (error 'ffi "args mismatch" argtypes args)) + (foreign-call "ikrt_ffi_call" data argsvec))))))) + ) diff --git a/scheme/last-revision b/scheme/last-revision index 17f9d40..bf90791 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1598 +1599 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 731559c..c4e7100 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1476,6 +1476,7 @@ [pointer-set-short $for] [pointer-set-int $for] [pointer-set-long $for] + [ffi-prep-cif $for] )) diff --git a/src/Makefile.am b/src/Makefile.am index 65e812f..af77491 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -7,7 +7,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \ ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \ - ikarus-errno.c ikarus-main.h ikarus-pointers.c + ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus-ffi.c ikarus_SOURCES = $(SRCS) ikarus.c scheme_script_SOURCES = $(SRCS) scheme-script.c diff --git a/src/Makefile.in b/src/Makefile.in index a9e063b..c347c79 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -55,7 +55,8 @@ am__objects_1 = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \ ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \ cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \ ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \ - ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT) + ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT) \ + ikarus-ffi.$(OBJEXT) am_ikarus_OBJECTS = $(am__objects_1) ikarus.$(OBJEXT) nodist_ikarus_OBJECTS = ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS) @@ -185,7 +186,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \ ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \ - ikarus-errno.c ikarus-main.h ikarus-pointers.c + ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus-ffi.c ikarus_SOURCES = $(SRCS) ikarus.c scheme_script_SOURCES = $(SRCS) scheme-script.c @@ -268,6 +269,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-errno.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-exec.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-fasl.Po@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-ffi.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-flonums.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-getaddrinfo.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-io.Po@am__quote@ diff --git a/src/ikarus-ffi.c b/src/ikarus-ffi.c new file mode 100644 index 0000000..7c7291d --- /dev/null +++ b/src/ikarus-ffi.c @@ -0,0 +1,172 @@ + +#include "ikarus-data.h" +#include "config.h" + +#if ENABLE_LIBFFI +#include +#include +#include + +static void* +alloc(size_t n, int m) { + void* x = calloc(n, m); + if (x == NULL) { + fprintf(stderr, "ERROR (ikarus): calloc failed!\n"); + exit(-1); + } + return x; +} + +static ffi_type* +scheme_to_ffi_type_cast(int n){ + switch (n & 0xF) { + case 1: return &ffi_type_void; + case 2: return &ffi_type_uint8; + case 3: return &ffi_type_sint8; + case 4: return &ffi_type_uint16; + case 5: return &ffi_type_sint16; + case 6: return &ffi_type_uint32; + case 7: return &ffi_type_sint32; + case 8: return &ffi_type_uint64; + case 9: return &ffi_type_sint64; + case 10: return &ffi_type_float; + case 11: return &ffi_type_double; + case 12: return &ffi_type_pointer; + default: + fprintf(stderr, "INVALID ARG %d", n); + exit(-1); + } +} + +static void* +alloc_room_for_type(int n){ + ffi_type* t = scheme_to_ffi_type_cast(n); + return alloc(t->size, 1); +} + +extern long extract_num(ikptr x); + +static void* +scheme_to_ffi_value_cast(int n, ikptr p) { + void* r = alloc_room_for_type(n); + switch (n & 0xF) { + case 1: { free(r); return NULL; } + case 2: // ffi_type_uint8; + case 3: + { *((char*)r) = extract_num(p); return r; } + case 4: // ffi_type_uint16; + case 5: + { *((short*)r) = extract_num(p); return r; } + case 6: // ffi_type_uint32; + case 7: + { *((int*)r) = extract_num(p); return r; } + case 8: // ffi_type_uint64; + case 9: + { *((long*)r) = extract_num(p); return r; } + case 10: //return &ffi_type_float; + { *((float*)r) = flonum_data(p); return r; } + case 11: //return &ffi_type_double; + { *((double*)r) = flonum_data(p); return r; } + case 12: //return &ffi_type_pointer; + { *((void**)r) = (void*)ref(p, off_pointer_data); return r; } + default: + fprintf(stderr, "INVALID ARG %d", n); + exit(-1); + } +} + + +extern ikptr u_to_number(unsigned long x, ikpcb* pcb); +extern ikptr s_to_number(signed long x, ikpcb* pcb); +extern ikptr d_to_number(double x, ikpcb* pcb); +extern ikptr make_pointer(void* x, ikpcb* pcb); +static ikptr +ffi_to_scheme_value_cast(int n, void* p, ikpcb* pcb) { + switch (n & 0xF) { + case 1: return void_object; + case 2: return u_to_number(*((unsigned char*)p), pcb); + case 3: return s_to_number(*((signed char*)p), pcb); + case 4: return u_to_number(*((unsigned short*)p), pcb); + case 5: return s_to_number(*((signed short*)p), pcb); + case 6: return u_to_number(*((unsigned int*)p), pcb); + case 7: return s_to_number(*((signed int*)p), pcb); + case 8: return u_to_number(*((unsigned long*)p), pcb); + case 9: return s_to_number(*((signed long*)p), pcb); + case 10: return d_to_number(*((float*)p), pcb); + case 11: return d_to_number(*((double*)p), pcb); + case 12: return make_pointer(*((void**)p), pcb); + default: + fprintf(stderr, "INVALID ARG %d", n); + exit(-1); + } +} + +ikptr +ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) { + ffi_cif* cif = alloc(sizeof(ffi_cif), 1); + bzero(cif, sizeof(ffi_cif)); + ffi_abi abi = FFI_DEFAULT_ABI; + unsigned int nargs = unfix(ref(argstptr, off_vector_length)); + ffi_type** argtypes = alloc(sizeof(ffi_type*), nargs); + int i; + for(i=0; i 0) { + fprintf(stderr, "Hello World\n"); + n--; + } +} + +#else +ikptr ikrt_ffi_prep_cif() { return false_object; } +ikrt_ffi_call() { return false_object; } +#endif + + + + + diff --git a/src/ikarus-pointers.c b/src/ikarus-pointers.c index 563b9cd..6c256f3 100644 --- a/src/ikarus-pointers.c +++ b/src/ikarus-pointers.c @@ -35,7 +35,7 @@ ikrt_pointer_to_int(ikptr x, ikpcb* pcb) { } } -static ikptr +ikptr make_pointer(long int x, ikpcb* pcb) { ikptr r = ik_safe_alloc(pcb, pointer_size); ref(r, 0) = pointer_tag; @@ -152,7 +152,7 @@ ikrt_ref_ushort(ikptr p, ikptr off /*, ikpcb* pcb*/) { return fix(*((unsigned short*)(((long)ref(p, off_pointer_data)) + unfix(off)))); } -static ikptr +ikptr s_to_number(signed long n, ikpcb* pcb) { ikptr fx = fix(n); if (unfix(fx) == n) { @@ -172,7 +172,7 @@ s_to_number(signed long n, ikpcb* pcb) { return bn+vector_tag; } -static ikptr +ikptr u_to_number(unsigned long n, ikpcb* pcb) { unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1); if (n <= mxn) { @@ -184,6 +184,15 @@ u_to_number(unsigned long n, ikpcb* pcb) { return bn+vector_tag; } +ikptr +d_to_number(double n, ikpcb* pcb) { + ikptr x = ik_safe_alloc(pcb, flonum_size) + vector_tag; + ref(x, -vector_tag) = flonum_tag; + flonum_data(x) = n; + return x; +} + + ikptr ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) { @@ -221,7 +230,7 @@ ikrt_ref_ulong(ikptr p, ikptr off , ikpcb* pcb) { return u_to_number(r, pcb); } -static long +long extract_num(ikptr x) { if (is_fixnum(x)) { return unfix(x);