[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-29-g17d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-29-g17d819d |
|
Date: |
Wed, 27 Jan 2010 21:26:06 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=17d819d4c43701e0e0e92f6c2001343d4730db83
The branch, master has been updated
via 17d819d4c43701e0e0e92f6c2001343d4730db83 (commit)
via 3435f3c07c27c62fcd0a6112243a27ea4ae7b462 (commit)
via 663212bbc66b616cca9ba55d9992e2fb339d8250 (commit)
via d27a7811db7947bb9bba536303702c8906219165 (commit)
via 0515661235e3c17935b918565c70145d7895d37e (commit)
via 80e22004bd01a719578997f333aa09d907a450e4 (commit)
via c612ed59ab3ba92a0b778d30f21c493341160df2 (commit)
via 75383ddbd77d5981e5ab4ac72818b96d391c9e22 (commit)
via 70ea39f70f54e82fc38204ac5f7768505cc37dff (commit)
via 9a396cbdbea984f8265e760f64414e8e712e49ab (commit)
via 37371ea1ba160e2eb61fb3415024ef8e79b2e502 (commit)
via 4d9130a5b733e844e42f27f209e148fa64f731be (commit)
via d8b04f04e90882f3903092ea85038a9e3cd10d39 (commit)
via 827dc8dcb61dcbdd62ad1ae41b98d65ecd8d5b66 (commit)
via 20aafae22a4f11289b65dba685495a808ebd6b07 (commit)
via ab4779ffcfb463201d46459e06b9188dd5f1cbda (commit)
via 52fd9639fdeee068434342e1bdb8693b05ecac5c (commit)
via 75c242a256c273ab0690397df4277d44f01946e6 (commit)
from e03b7f73e2927178f2d9485320435edb6260c311 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
-----------------------------------------------------------------------
Summary of changes:
NEWS | 209 +-------
configure.ac | 18 +-
libguile/Makefile.am | 4 +-
libguile/_scm.h | 2 +-
libguile/dynl.c | 61 ++-
libguile/dynl.h | 3 +-
libguile/foreign.c | 947 ++++++++++++++++++++++++++----
libguile/foreign.h | 88 ++-
libguile/goops.c | 10 +-
libguile/gsubr.c | 8 +-
libguile/gsubr.h | 4 +-
libguile/init.c | 2 +-
libguile/snarf.h | 10 +-
libguile/vm-i-loader.c | 18 +-
libguile/vm-i-scheme.c | 459 ++++++++-------
libguile/vm-i-system.c | 84 ++-
module/Makefile.am | 1 +
module/language/tree-il/compile-glil.scm | 1 +
module/language/tree-il/primitives.scm | 1 +
module/statprof.scm | 42 +-
module/system/foreign.scm | 103 ++++
test-suite/standalone/Makefile.am | 12 +-
test-suite/standalone/test-ffi | 174 ++++++
test-suite/standalone/test-ffi-lib.c | 215 +++++++
24 files changed, 1805 insertions(+), 671 deletions(-)
create mode 100644 module/system/foreign.scm
create mode 100755 test-suite/standalone/test-ffi
create mode 100644 test-suite/standalone/test-ffi-lib.c
diff --git a/NEWS b/NEWS
index dbe5b11..a0bde90 100644
--- a/NEWS
+++ b/NEWS
@@ -8,214 +8,7 @@ Please send Guile bug reports to address@hidden
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
-Changes in 1.9.7 (since the 1.9.6 prerelease):
-
-** Complete support for version information in Guile's `module' form
-
-Guile modules now have a `#:version' field. They may be loaded by
-version as well. See "R6RS Version References", "General Information
-about Modules", "Using Guile Modules", and "Creating Guile Modules" in
-the manual for more information.
-
-** Support for renaming bindings on module export
-
-Wherever Guile accepts a symbol as an argument to specify a binding to
-export, it now also accepts a pair of symbols, indicating that a binding
-should be renamed on export. See "Creating Guile Modules" in the manual
-for more information.
-
-** Imported statprof, SSAX, and texinfo modules from Guile-Lib
-
-The statprof statistical profiler, the SSAX XML toolkit, and the texinfo
-toolkit from Guile-Lib have been imported into Guile proper. See
-"Standard Library" in the manual for more details.
-
-** Function profiling and tracing at the REPL
-
-The `,profile FORM' REPL meta-command can now be used to statistically
-profile execution of a form, to see which functions are taking the most
-time. See `,help profile' for more information.
-
-Similarly, `,trace FORM' traces all function applications that occur
-during the execution of `FORM'. See `,help trace' for more information.
-
-** New debugger
-
-By default, if an exception is raised at the REPL and not caught by user
-code, Guile will drop the user into a debugger. The user may request a
-backtrace, inspect frames, or continue raising the exception. Full
-documentation is available from within the debugger.
-
-** New function, `truncated-print', with `format' support
-
-`(ice-9 pretty-print)' now exports `truncated-print', a printer that
-will ensure that the output stays within a certain width, truncating the
-output in what is hopefully an intelligent manner. See the manual for
-more details.
-
-There is a new `format' specifier, address@hidden', for doing a truncated
-print (as opposed to `~y', which does a pretty-print). See the `format'
-documentation for more details.
-
-** Primitive procedures are now VM trampoline procedures
-
-Guile's old evaluator used to have special cases for applying "gsubrs",
-primitive procedures with specified numbers of required, optional, and
-rest arguments. Now, however, Guile represents gsubrs as normal VM
-procedures, with appropriate bytecode to parse out the correct number of
-arguments, including optional and rest arguments, and then with a
-special bytecode to apply the gsubr.
-
-This allows primitive procedures to appear on the VM stack, allowing
-them to be accurately counted in profiles. Also they now have more
-debugging information attached to them -- their number of arguments, for
-example. In addition, the VM can completely inline the application
-mechanics, allowing for faster primitive calls.
-
-However there are some changes on the C level. There is no more
-`scm_tc7_gsubr' or `scm_tcs_subrs' typecode for primitive procedures, as
-they are just VM procedures. Likewise the macros `SCM_GSUBR_TYPE',
-`SCM_GSUBR_MAKTYPE', `SCM_GSUBR_REQ', `SCM_GSUBR_OPT', and
-`SCM_GSUBR_REST' are gone, as are `SCM_SUBR_META_INFO', `SCM_SUBR_PROPS'
-`SCM_SET_SUBR_GENERIC_LOC', and `SCM_SUBR_ARITY_TO_TYPE'.
-
-Perhaps more significantly, `scm_c_make_subr',
-`scm_c_make_subr_with_generic', `scm_c_define_subr', and
-`scm_c_define_subr_with_generic'. They all operated on subr typecodes,
-and there are no more subr typecodes. Use the scm_c_make_gsubr family
-instead.
-
-Normal users of gsubrs should not be affected, though, as the
-scm_c_make_gsubr family still is the correct way to create primitive
-procedures.
-
-** SRFI-4 vectors reimplemented in terms of R6RS bytevectors
-
-Guile now implements SRFI-4 vectors using bytevectors. Often when you
-have a numeric vector, you end up wanting to write its bytes somewhere,
-or have access to the underlying bytes, or read in bytes from somewhere
-else. Bytevectors are very good at this sort of thing. But the SRFI-4
-APIs are nicer to use when doing number-crunching, because they are
-addressed by element and not by byte.
-
-So as a compromise, Guile allows all bytevector functions to operate on
-numeric vectors. They address the underlying bytes in the native
-endianness, as one would expect.
-
-Following the same reasoning, that it's just bytes underneath, Guile
-also allows uniform vectors of a given type to be accessed as if they
-were of any type. One can fill a u32vector, and access its elements with
-u8vector-ref. One can use f64vector-ref on bytevectors. It's all the
-same to Guile.
-
-In this way, uniform numeric vectors may be written to and read from
-input/output ports using the procedures that operate on bytevectors.
-
-Calls to SRFI-4 accessors (ref and set functions) from Scheme are now
-inlined to the VM instructions for bytevector access.
-
-See "SRFI-4" in the manual, for more information.
-
-** Nonstandard SRFI-4 procedures now available from `(srfi srfi-4 gnu)'
-
-Guile's `(srfi srfi-4)' now only exports those srfi-4 procedures that
-are part of the standard. Complex uniform vectors and the
-`any->FOOvector' family are now available only from `(srfi srfi-4 gnu)'.
-
-Guile's default environment imports `(srfi srfi-4)', and probably should
-import `(srfi srfi-4 gnu)' as well.
-
-See "SRFI-4 Extensions" in the manual, for more information.
-
-** Unicode: String normalization, general categories, title case
-
-Guile now exports the Unicode string normalization functions
-`string-normalize-nfc', `string-normalize-nfd', `string-normalize-nfkc',
-and `string-normalize-nfkd'. See "String Comparison" in the manual for
-more information. See "Characters" for information on the new
-`char-general-category', and "Character Case Mapping" for
-`char-titlecase', `char-locale-titlecase', and
-`string-locale-titlecase'.
-
-** Faster access to the free variables of a closure
-
-Guile's old garbage collector limited the size of Scheme objects to be 2
-or 4 words. Now with the BDW collector, Guile can allocate
-variable-sized objects, allowing storage of the free variables of a
-closure inline to the closure itself.
-
-** New primitive `getsid'
-
-Scheme binding for the `getsid' C library call.
-
-** Changed invocation mechanics of applicable SMOBs
-
-Guile's old evaluator used to have special cases for applying SMOB
-objects. Now, with the VM, when Guile sees a SMOB, it looks up a VM
-trampoline procedure for it, and use the normal mechanics to apply the
-trampoline. This simplifies procedure application in the normal,
-non-SMOB case.
-
-The upshot is that the mechanics used to apply a SMOB are different from
-1.8. Descriptors no longer have `apply_0', `apply_1', `apply_2', and
-`apply_3' functions, and the macros SCM_SMOB_APPLY_0 and friends are now
-deprecated. Just use the scm_call_0 family of procedures.
-
-** Remove deprecated array C interfaces
-
-Removed the deprecated array functions `scm_i_arrayp',
-`scm_i_array_ndim', `scm_i_array_mem', `scm_i_array_v',
-`scm_i_array_base', `scm_i_array_dims', and the deprecated macros
-`SCM_ARRAYP', `SCM_ARRAY_NDIM', `SCM_ARRAY_CONTP', `SCM_ARRAY_MEM',
-`SCM_ARRAY_V', `SCM_ARRAY_BASE', and `SCM_ARRAY_DIMS'.
-
-** String encoding errors throw to `encoding-error' instead of `misc-error'
-
-** Keyword argument errors uniformly throw to `keyword-argument-error'
-
-** Remove unused snarf macros
-
-`SCM_DEFINE1', `SCM_PRIMITIVE_GENERIC_1', `SCM_PROC1, and `SCM_GPROC1'
-are no more. Use SCM_DEFINE or SCM_PRIMITIVE_GENERIC instead.
-
-** Add foreign value wrapper
-
-Guile now has a datatype for aliasing "foreign" values, such as native
-long values. This should be useful for making a proper foreign function
-interface. Interested hackers should see libguile/foreign.h.
-
-** New functions: `scm_call_n', `scm_c_run_hookn'
-
-`scm_call_n' applies to apply a function to an array of arguments.
-`scm_c_run_hookn' runs a hook with an array of arguments.
-
-** Load path change: search in version-specific paths before site paths
-
-When looking for a module, Guile now searches first in Guile's
-version-specific path (the library path), *then* in the site dir. This
-allows Guile's copy of SSAX to override any Guile-Lib copy the user has
-installed. Also it should cut the number of `stat' system calls by half,
-in the common case.
-
-** Compile-time warning: -Wunused-toplevel
-
-Guile can warn about potentially unused top-level (global)
-variables. Pass the -Wunused-toplevel on the `guile-tools compile'
-command line, or add
-`#:warnings '(unused-toplevel)' to your `compile' or `compile-file'
-invocation.
-
-** New reader options: `square-brackets' and `r6rs-hex-escapes'
-
-The reader supports a new option (changeable via `read-options'),
-`square-brackets', which instructs it to interpret square brackets as
-parenthesis. This option is on by default.
-
-If this causes problems with your code, make sure to report it to
address@hidden so we can change the default.
-
-When the new `r6rs-hex-escapes' reader option is enabled, the reader
-will recognize string escape sequences as defined in R6RS.
+Changes in 1.9.8 (since the 1.9.7 prerelease):
** And of course, the usual collection of bugfixes
diff --git a/configure.ac b/configure.ac
index baac33d..35e902c 100644
--- a/configure.ac
+++ b/configure.ac
@@ -4,7 +4,7 @@ dnl
define(GUILE_CONFIGURE_COPYRIGHT,[[
-Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
2008, 2009 Free Software Foundation, Inc.
+Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
2008, 2009, 2010 Free Software Foundation, Inc.
This file is part of GUILE
@@ -879,6 +879,22 @@ else
AC_MSG_ERROR([GNU libunistring is required, please install it.])
fi
+dnl Libffi is needed to compile Guile's foreign function interface, but its
+dnl interface isn't exposed in Guile's API.
+PKG_CHECK_MODULES(LIBFFI, libffi)
+AC_SUBST(LIBFFI_CFLAGS)
+AC_SUBST(LIBFFI_LIBS)
+
+dnl figure out approriate ffi type for size_t
+AC_CHECK_SIZEOF(size_t)
+AC_CHECK_SIZEOF(ssize_t)
+ffi_size_type=uint$(($ac_cv_sizeof_size_t*8))
+ffi_ssize_type=sint$(($ac_cv_sizeof_ssize_t*8))
+AC_DEFINE_UNQUOTED(ffi_type_size_t, ffi_type_${ffi_size_type},
+ [ffi type for size_t])
+AC_DEFINE_UNQUOTED(ffi_type_ssize_t, ffi_type_${ffi_ssize_type},
+ [ffi type for ssize_t])
+
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
#AC_CHECK_FUNCS(gettext)
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 856c87a..0455835 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -33,7 +33,7 @@ DEFAULT_INCLUDES =
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
- -I$(top_srcdir)/lib -I$(top_builddir)/lib
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib $(LIBFFI_CFLAGS)
AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
@@ -442,7 +442,7 @@ libguile_la_LIBADD = \
@LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) \
$(LTLIBUNISTRING) $(LTLIBICONV)
libguile_la_LDFLAGS = \
- @LTLIBINTL@ $(INET_NTOP_LIB) $(INET_PTON_LIB)
\
+ @LTLIBINTL@ $(LIBFFI_LIBS) $(INET_NTOP_LIB) $(INET_PTON_LIB) \
-version-info
@LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@
\
-export-dynamic -no-undefined
\
$(GNU_LD_FLAGS)
diff --git a/libguile/_scm.h b/libguile/_scm.h
index b4416ff..a1884ca 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -178,7 +178,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION O
+#define SCM_OBJCODE_MINOR_VERSION P
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/dynl.c b/libguile/dynl.c
index a55ba86..0175c33 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -100,7 +100,7 @@ sysdep_dynl_unlink (void *handle, const char *subr)
}
static void *
-sysdep_dynl_func (const char *symb, void *handle, const char *subr)
+sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
@@ -214,23 +214,31 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
- (SCM name, SCM dobj),
- "Return a ``handle'' for the function @var{name} in the\n"
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
+ (SCM name, SCM type, SCM dobj, SCM len),
+ "Return a ``handle'' for the pointer @var{name} in the\n"
"shared object referred to by @var{dobj}. The handle\n"
- "can be passed to @code{dynamic-call} to actually\n"
- "call the function.\n\n"
+ "aliases a C value, and is declared to be of type\n"
+ "@var{type}. Valid types are defined in the\n"
+ "@code{(system vm ffi)} module.\n\n"
+ "This facility works by asking the operating system for\n"
+ "the address of a symbol, then assuming that it aliases a\n"
+ "value of a given type. Obviously, the user must be very\n"
+ "careful to ensure that the value actually is of the\n"
+ "declared type, or bad things will happen.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
"since it will be added automatically when necessary.")
-#define FUNC_NAME s_scm_dynamic_func
+#define FUNC_NAME s_scm_dynamic_pointer
{
- void (*func) ();
+ void *val;
+ scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name);
+ t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
/*fixme* GC-problem */
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+ SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
} else {
@@ -239,15 +247,36 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
scm_dynwind_begin (0);
chars = scm_to_locale_string (name);
scm_dynwind_free (chars);
- func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
- FUNC_NAME);
+ val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end ();
- return scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, &func, 0, NULL);
+ return scm_take_foreign_pointer (t, val,
+ SCM_UNBNDP (len) ? 0 : scm_to_size_t
(len),
+ NULL);
}
}
#undef FUNC_NAME
+SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``handle'' for the function @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "can be passed to @code{dynamic-call} to actually\n"
+ "call the function.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_func
+{
+ return scm_dynamic_pointer (name,
+ scm_from_uint (SCM_FOREIGN_TYPE_VOID),
+ dobj,
+ SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
(SCM func, SCM dobj),
"Call a C function in a dynamic object. Two styles of\n"
@@ -272,9 +301,9 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
- fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
+ fptr = SCM_FOREIGN_POINTER (func, void);
fptr ();
return SCM_UNSPECIFIED;
}
@@ -302,9 +331,9 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3,
0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
- fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
+ fptr = SCM_FOREIGN_POINTER (func, void);
argv = scm_i_allocate_string_pointers (args);
for (argc = 0; argv[argc]; argc++)
diff --git a/libguile/dynl.h b/libguile/dynl.h
index eb318ae..2b34c2e 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNL_H
#define SCM_DYNL_H
-/* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2006, 2008, 2010 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -30,6 +30,7 @@
SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
+SCM_API SCM scm_dynamic_pointer (SCM name, SCM type, SCM dobj, SCM len);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 4a4b218..b754fad 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -20,85 +20,67 @@
# include <config.h>
#endif
+#include <ffi.h>
+
+#include <alignof.h>
#include <string.h>
#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/instructions.h"
#include "libguile/foreign.h"
-static size_t
-sizeof_type (scm_t_foreign_type type)
-{
- switch (type)
- {
- case SCM_FOREIGN_TYPE_VOID: abort ();
- case SCM_FOREIGN_TYPE_FLOAT: return sizeof(float);
- case SCM_FOREIGN_TYPE_DOUBLE: return sizeof(double);
- case SCM_FOREIGN_TYPE_UINT8: return sizeof(scm_t_uint8);
- case SCM_FOREIGN_TYPE_INT8: return sizeof(scm_t_int8);
- case SCM_FOREIGN_TYPE_UINT16: return sizeof(scm_t_uint16);
- case SCM_FOREIGN_TYPE_INT16: return sizeof(scm_t_int16);
- case SCM_FOREIGN_TYPE_UINT32: return sizeof(scm_t_uint32);
- case SCM_FOREIGN_TYPE_INT32: return sizeof(scm_t_int32);
- case SCM_FOREIGN_TYPE_UINT64: return sizeof(scm_t_uint64);
- case SCM_FOREIGN_TYPE_INT64: return sizeof(scm_t_int64);
- case SCM_FOREIGN_TYPE_STRUCT: abort ();
- case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*);
- default: abort ();
- }
-}
+SCM_SYMBOL (sym_void, "void");
+SCM_SYMBOL (sym_float, "float");
+SCM_SYMBOL (sym_double, "double");
+SCM_SYMBOL (sym_uint8, "uint8");
+SCM_SYMBOL (sym_int8, "int8");
+SCM_SYMBOL (sym_uint16, "uint16");
+SCM_SYMBOL (sym_int16, "int16");
+SCM_SYMBOL (sym_uint32, "uint32");
+SCM_SYMBOL (sym_int32, "int32");
+SCM_SYMBOL (sym_uint64, "uint64");
+SCM_SYMBOL (sym_int64, "int64");
+
+/* that's for pointers, you know. */
+SCM_SYMBOL (sym_asterisk, "*");
+
+static SCM cif_to_procedure (SCM cif, SCM func_ptr);
+
+static SCM foreign_weak_refs = SCM_BOOL_F;
+
+static void
+register_weak_reference (SCM from, SCM to)
+{
+ scm_hashq_set_x (foreign_weak_refs, from, to);
+}
+
static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
scm_t_foreign_finalizer finalizer = data;
- finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*));
+ finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
}
SCM
-scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size,
- scm_t_foreign_finalizer finalizer)
+scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
+ scm_t_foreign_finalizer finalizer)
{
SCM ret;
- if (!size)
- size = sizeof_type (type);
+ scm_t_bits word0;
- ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size,
- "foreign"));
- SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
-
- /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which
will
- be 8-byte aligned. Then copy *val into that space. */
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
- memcpy (SCM_FOREIGN_OBJECT (ret, void), val, size);
-
- if (finalizer)
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- foreign_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
- }
-
- return ret;
-}
-
-SCM
-scm_c_take_foreign (scm_t_foreign_type type, void *val,
- scm_t_foreign_finalizer finalizer)
-{
- SCM ret;
+ word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
+ | (finalizer ? (1<<16) : 0) | (len<<17));
+ if (SCM_UNLIKELY ((word0 >> 17) != len))
+ scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
"foreign"));
- SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
- /* Set SCM_FOREIGN_OBJECT to the given pointer. */
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val);
+ SCM_SET_CELL_WORD_0 (ret, word0);
+ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
if (finalizer)
{
@@ -118,41 +100,44 @@ scm_c_take_foreign (scm_t_foreign_type type, void *val,
SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
(SCM foreign),
"Reference the foreign value wrapped by @var{foreign}.\n\n"
- "Note that only \"simple\" types may be referenced by this\n"
- "function. See @code{foreign-struct-ref} or
@code{foreign-pointer-ref}\n"
- "for structs or pointers, respectively.")
+ "The value will be referenced according to its type.")
#define FUNC_NAME s_scm_foreign_ref
{
- SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
- switch (SCM_FOREIGN_TYPE (foreign))
+ SCM_VALIDATE_FOREIGN (1, foreign);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+ ftype = SCM_FOREIGN_TYPE (foreign);
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ /* FIXME: accessing unaligned pointers */
+ switch (ftype)
{
+ case SCM_FOREIGN_TYPE_VOID:
+ return scm_from_ulong ((unsigned long)ptr);
case SCM_FOREIGN_TYPE_FLOAT:
- return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float));
+ return scm_from_double (*(float*)ptr);
case SCM_FOREIGN_TYPE_DOUBLE:
- return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double));
+ return scm_from_double (*(double*)ptr);
case SCM_FOREIGN_TYPE_UINT8:
- return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8));
+ return scm_from_uint8 (*(scm_t_uint8*)ptr);
case SCM_FOREIGN_TYPE_INT8:
- return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8));
+ return scm_from_int8 (*(scm_t_int8*)ptr);
case SCM_FOREIGN_TYPE_UINT16:
- return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16));
+ return scm_from_uint16 (*(scm_t_uint16*)ptr);
case SCM_FOREIGN_TYPE_INT16:
- return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16));
+ return scm_from_int16 (*(scm_t_int16*)ptr);
case SCM_FOREIGN_TYPE_UINT32:
- return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32));
+ return scm_from_uint32 (*(scm_t_uint32*)ptr);
case SCM_FOREIGN_TYPE_INT32:
- return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32));
+ return scm_from_int32 (*(scm_t_int32*)ptr);
case SCM_FOREIGN_TYPE_UINT64:
- return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64));
+ return scm_from_uint64 (*(scm_t_uint64*)ptr);
case SCM_FOREIGN_TYPE_INT64:
- return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64));
- case SCM_FOREIGN_TYPE_VOID:
- case SCM_FOREIGN_TYPE_STRUCT:
- case SCM_FOREIGN_TYPE_POINTER:
+ return scm_from_int64 (*(scm_t_int64*)ptr);
default:
- /* other cases should have been caught by the FOREIGN_SIMPLE check */
- abort ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, foreign, "foreign");
}
}
#undef FUNC_NAME
@@ -160,126 +145,852 @@ SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
(SCM foreign, SCM val),
"Set the foreign value wrapped by @var{foreign}.\n\n"
- "Note that only \"simple\" types may be set by this function.\n"
- "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n"
- "structs or pointers, respectively.")
+ "The value will be set according to its type.")
#define FUNC_NAME s_scm_foreign_set_x
{
- SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
- switch (SCM_FOREIGN_TYPE (foreign))
+ SCM_VALIDATE_FOREIGN (1, foreign);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+ ftype = SCM_FOREIGN_TYPE (foreign);
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ /* FIXME: unaligned access */
+ switch (ftype)
{
+ case SCM_FOREIGN_TYPE_VOID:
+ SCM_SET_CELL_WORD_1 (foreign, scm_to_ulong (val));
+ break;
case SCM_FOREIGN_TYPE_FLOAT:
- SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val));
+ *(float*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
- SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val));
+ *(double*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_UINT8:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val));
+ *(scm_t_uint8*)ptr = scm_to_uint8 (val);
break;
case SCM_FOREIGN_TYPE_INT8:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val));
+ *(scm_t_int8*)ptr = scm_to_int8 (val);
break;
case SCM_FOREIGN_TYPE_UINT16:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val));
+ *(scm_t_uint16*)ptr = scm_to_uint16 (val);
break;
case SCM_FOREIGN_TYPE_INT16:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val));
+ *(scm_t_int16*)ptr = scm_to_int16 (val);
break;
case SCM_FOREIGN_TYPE_UINT32:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val));
+ *(scm_t_uint32*)ptr = scm_to_uint32 (val);
break;
case SCM_FOREIGN_TYPE_INT32:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val));
+ *(scm_t_int32*)ptr = scm_to_int32 (val);
break;
case SCM_FOREIGN_TYPE_UINT64:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val));
+ *(scm_t_uint64*)ptr = scm_to_uint64 (val);
break;
case SCM_FOREIGN_TYPE_INT64:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val));
+ *(scm_t_int64*)ptr = scm_to_int64 (val);
break;
- case SCM_FOREIGN_TYPE_VOID:
- case SCM_FOREIGN_TYPE_STRUCT:
- case SCM_FOREIGN_TYPE_POINTER:
default:
- /* other cases should have been caught by the FOREIGN_SIMPLE check */
- abort ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, val, "foreign");
}
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
+ (SCM foreign, SCM uvec_type, SCM offset, SCM len),
+ "Return a bytevector aliasing the memory pointed to by\n"
+ "@var{foreign}.\n\n"
+ "@var{foreign} must be a void pointer, a foreign whose type is\n"
+ "@var{void}. By default, the resulting bytevector will alias\n"
+ "all of the memory pointed to by @var{foreign}, from beginning\n"
+ "to end, treated as a @code{vu8} array.\n\n"
+ "The user may specify an alternate default interpretation for\n"
+ "the memory by passing the @var{uvec_type} argument, to indicate\n"
+ "that the memory is an array of elements of that type.\n"
+ "@var{uvec_type} should be something that\n"
+ "@code{uniform-vector-element-type} would return, like
@code{f32}\n"
+ "or @code{s16}.\n\n"
+ "Users may also specify that the bytevector should only alias a\n"
+ "subset of the memory, by specifying @var{offset} and @var{len}\n"
+ "arguments.")
+#define FUNC_NAME s_scm_foreign_to_bytevector
+{
+ SCM ret;
+ scm_t_int8 *ptr;
+ size_t boffset, blen;
+ scm_t_array_element_type btype;
+
+ SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
+
+ if (SCM_UNBNDP (uvec_type))
+ btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
+ else
+ {
+ int i;
+ for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
+ if (scm_is_eq (uvec_type, scm_i_array_element_types[i]))
+ break;
+ switch (i)
+ {
+ case SCM_ARRAY_ELEMENT_TYPE_VU8:
+ case SCM_ARRAY_ELEMENT_TYPE_U8:
+ case SCM_ARRAY_ELEMENT_TYPE_S8:
+ case SCM_ARRAY_ELEMENT_TYPE_U16:
+ case SCM_ARRAY_ELEMENT_TYPE_S16:
+ case SCM_ARRAY_ELEMENT_TYPE_U32:
+ case SCM_ARRAY_ELEMENT_TYPE_S32:
+ case SCM_ARRAY_ELEMENT_TYPE_U64:
+ case SCM_ARRAY_ELEMENT_TYPE_S64:
+ case SCM_ARRAY_ELEMENT_TYPE_F32:
+ case SCM_ARRAY_ELEMENT_TYPE_F64:
+ case SCM_ARRAY_ELEMENT_TYPE_C32:
+ case SCM_ARRAY_ELEMENT_TYPE_C64:
+ btype = i;
+ break;
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec_type,
+ "uniform vector type");
+ }
+ }
+
+ if (SCM_UNBNDP (offset))
+ boffset = 0;
+ else if (SCM_FOREIGN_LEN (foreign))
+ boffset = scm_to_unsigned_integer (offset, 0,
+ SCM_FOREIGN_LEN (foreign) - 1);
+ else
+ boffset = scm_to_size_t (offset);
+
+ if (SCM_UNBNDP (len))
+ {
+ if (SCM_FOREIGN_LEN (foreign))
+ blen = SCM_FOREIGN_LEN (foreign) - boffset;
+ else
+ scm_misc_error (FUNC_NAME,
+ "length needed to convert foreign pointer to
bytevector",
+ SCM_EOL);
+ }
+ else
+ {
+ if (SCM_FOREIGN_LEN (foreign))
+ blen = scm_to_unsigned_integer (len, 0,
+ SCM_FOREIGN_LEN (foreign) - boffset);
+ else
+ blen = scm_to_size_t (len);
+ }
+
+ ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
+ register_weak_reference (ret, foreign);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0,
+ (SCM bv, SCM offset, SCM len),
+ "Return a foreign pointer aliasing the memory pointed to by\n"
+ "@var{bv}.\n\n"
+ "The resulting foreign will be a void pointer, a foreign whose\n"
+ "type is @code{void}. By default it will alias all of the\n"
+ "memory pointed to by @var{bv}, from beginning to end.\n\n"
+ "Users may explicily specify that the foreign should only alias
a\n"
+ "subset of the memory, by specifying @var{offset} and @var{len}\n"
+ "arguments.")
+#define FUNC_NAME s_scm_bytevector_to_foreign
+{
+ SCM ret;
+ scm_t_int8 *ptr;
+ size_t boffset, blen;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ ptr = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (SCM_UNBNDP (offset))
+ boffset = 0;
+ else
+ boffset = scm_to_unsigned_integer (offset, 0,
+ SCM_BYTEVECTOR_LENGTH (bv) - 1);
+
+ if (SCM_UNBNDP (len))
+ blen = SCM_BYTEVECTOR_LENGTH (bv) - boffset;
+ else
+ blen = scm_to_unsigned_integer (len, 0,
+ SCM_BYTEVECTOR_LENGTH (bv) - boffset);
+
+ ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen,
+ NULL);
+ register_weak_reference (ret, bv);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
+ (SCM foreign, SCM finalizer),
+ "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
+ "called on the pointer wrapped by @var{foreign} when
@var{foreign}\n"
+ "becomes unreachable. Note: the C procedure should not call into\n"
+ "Scheme. If you need a Scheme finalizer, use guardians.")
+#define FUNC_NAME s_scm_foreign_set_finalizer_x
+{
+ void *c_finalizer;
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+
+ SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
+ SCM_VALIDATE_FOREIGN_TYPED (2, finalizer, VOID);
+
+ c_finalizer = SCM_FOREIGN_POINTER (finalizer, void);
+
+ SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16));
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (foreign),
+ foreign_finalizer_trampoline,
+ c_finalizer,
+ &prev_finalizer,
+ &prev_finalizer_data);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
void
scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
{
scm_puts ("#<foreign ", port);
switch (SCM_FOREIGN_TYPE (foreign))
{
- case SCM_FOREIGN_TYPE_VOID:
- abort ();
case SCM_FOREIGN_TYPE_FLOAT:
scm_puts ("float ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
scm_puts ("double ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_UINT8:
scm_puts ("uint8 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_INT8:
scm_puts ("int8 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_UINT16:
scm_puts ("uint16 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_INT16:
scm_puts ("int16 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_UINT32:
scm_puts ("uint32 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_INT32:
scm_puts ("int32 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_UINT64:
scm_puts ("uint64 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
case SCM_FOREIGN_TYPE_INT64:
scm_puts ("int64 ", port);
- scm_display (scm_foreign_ref (foreign), port);
break;
- case SCM_FOREIGN_TYPE_STRUCT:
- scm_puts ("struct at 0x", port);
- scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port);
+ case SCM_FOREIGN_TYPE_VOID:
+ scm_puts ("pointer ", port);
break;
- case SCM_FOREIGN_TYPE_POINTER:
- scm_puts ("pointer 0x", port);
- scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port);
+ default:
+ scm_wrong_type_arg_msg ("%print-foreign", 1, foreign, "foreign");
+ }
+ scm_display (scm_foreign_ref (foreign), port);
+ scm_putc ('>', port);
+}
+
+
+
+
+#define ROUND_UP(len,align) (align?(((len-1)|(align-1))+1):len)
+
+SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), "")
+#define FUNC_NAME s_scm_alignof
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ return scm_from_size_t (alignof (float));
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ return scm_from_size_t (alignof (double));
+ case SCM_FOREIGN_TYPE_UINT8:
+ return scm_from_size_t (alignof (scm_t_uint8));
+ case SCM_FOREIGN_TYPE_INT8:
+ return scm_from_size_t (alignof (scm_t_int8));
+ case SCM_FOREIGN_TYPE_UINT16:
+ return scm_from_size_t (alignof (scm_t_uint16));
+ case SCM_FOREIGN_TYPE_INT16:
+ return scm_from_size_t (alignof (scm_t_int16));
+ case SCM_FOREIGN_TYPE_UINT32:
+ return scm_from_size_t (alignof (scm_t_uint32));
+ case SCM_FOREIGN_TYPE_INT32:
+ return scm_from_size_t (alignof (scm_t_int32));
+ case SCM_FOREIGN_TYPE_UINT64:
+ return scm_from_size_t (alignof (scm_t_uint64));
+ case SCM_FOREIGN_TYPE_INT64:
+ return scm_from_size_t (alignof (scm_t_int64));
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return scm_from_size_t (alignof (void*));
+ else if (scm_is_pair (type))
+ /* a struct, yo */
+ return scm_alignof (scm_car (type));
+ else
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), "")
+#define FUNC_NAME s_scm_sizeof
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ return scm_from_size_t (sizeof (float));
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ return scm_from_size_t (sizeof (double));
+ case SCM_FOREIGN_TYPE_UINT8:
+ return scm_from_size_t (sizeof (scm_t_uint8));
+ case SCM_FOREIGN_TYPE_INT8:
+ return scm_from_size_t (sizeof (scm_t_int8));
+ case SCM_FOREIGN_TYPE_UINT16:
+ return scm_from_size_t (sizeof (scm_t_uint16));
+ case SCM_FOREIGN_TYPE_INT16:
+ return scm_from_size_t (sizeof (scm_t_int16));
+ case SCM_FOREIGN_TYPE_UINT32:
+ return scm_from_size_t (sizeof (scm_t_uint32));
+ case SCM_FOREIGN_TYPE_INT32:
+ return scm_from_size_t (sizeof (scm_t_int32));
+ case SCM_FOREIGN_TYPE_UINT64:
+ return scm_from_size_t (sizeof (scm_t_uint64));
+ case SCM_FOREIGN_TYPE_INT64:
+ return scm_from_size_t (sizeof (scm_t_int64));
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return scm_from_size_t (sizeof (void*));
+ else if (scm_is_pair (type))
+ {
+ /* a struct */
+ size_t off = 0;
+ while (scm_is_pair (type))
+ {
+ off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
+ off += scm_to_size_t (scm_sizeof (scm_car (type)));
+ type = scm_cdr (type);
+ }
+ return scm_from_size_t (off);
+ }
+ else
+ scm_wrong_type_arg (FUNC_NAME, 1, type);
+}
+#undef FUNC_NAME
+
+
+/* return 1 on success, 0 on failure */
+static int
+parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
+{
+ if (SCM_I_INUMP (type))
+ {
+ if ((SCM_I_INUM (type) < 0 )
+ || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
+ return 0;
+ else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
+ return 0;
+ else
+ return 1;
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ return 1;
+ else
+ {
+ long len;
+
+ len = scm_ilength (type);
+ if (len < 1)
+ return 0;
+ while (len--)
+ {
+ if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
+ return 0;
+ (*n_struct_elts)++;
+ type = scm_cdr (type);
+ }
+ (*n_structs)++;
+ return 1;
+ }
+}
+
+static void
+fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
+ ffi_type **types)
+{
+ if (SCM_I_INUMP (type))
+ {
+ switch (SCM_I_INUM (type))
+ {
+ case SCM_FOREIGN_TYPE_FLOAT:
+ *ftype = ffi_type_float;
+ return;
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ *ftype = ffi_type_double;
+ return;
+ case SCM_FOREIGN_TYPE_UINT8:
+ *ftype = ffi_type_uint8;
+ return;
+ case SCM_FOREIGN_TYPE_INT8:
+ *ftype = ffi_type_sint8;
+ return;
+ case SCM_FOREIGN_TYPE_UINT16:
+ *ftype = ffi_type_uint16;
+ return;
+ case SCM_FOREIGN_TYPE_INT16:
+ *ftype = ffi_type_sint16;
+ return;
+ case SCM_FOREIGN_TYPE_UINT32:
+ *ftype = ffi_type_uint32;
+ return;
+ case SCM_FOREIGN_TYPE_INT32:
+ *ftype = ffi_type_sint32;
+ return;
+ case SCM_FOREIGN_TYPE_UINT64:
+ *ftype = ffi_type_uint64;
+ return;
+ case SCM_FOREIGN_TYPE_INT64:
+ *ftype = ffi_type_sint64;
+ return;
+ case SCM_FOREIGN_TYPE_VOID:
+ *ftype = ffi_type_void;
+ return;
+ default:
+ scm_wrong_type_arg_msg ("make-foreign-function", 0, type,
+ "foreign type");
+ }
+ }
+ else if (scm_is_eq (type, sym_asterisk))
+ /* a pointer */
+ {
+ *ftype = ffi_type_pointer;
+ return;
+ }
+ else
+ {
+ long i, len;
+
+ len = scm_ilength (type);
+
+ ftype->size = 0;
+ ftype->alignment = 0;
+ ftype->type = FFI_TYPE_STRUCT;
+ ftype->elements = *type_ptrs;
+ *type_ptrs += len + 1;
+
+ for (i = 0; i < len; i++)
+ {
+ ftype->elements[i] = *types;
+ *types += 1;
+ fill_ffi_type (scm_car (type), ftype->elements[i],
+ type_ptrs, types);
+ type = scm_cdr (type);
+ }
+ ftype->elements[i] = NULL;
+ }
+}
+
+SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
+ (SCM return_type, SCM func_ptr, SCM arg_types),
+ "foo")
+#define FUNC_NAME s_scm_make_foreign_function
+{
+ SCM walk, scm_cif;
+ long i, nargs, n_structs, n_struct_elts;
+ size_t cif_len;
+ char *mem;
+ ffi_cif *cif;
+ ffi_type **type_ptrs;
+ ffi_type *types;
+
+ SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
+ nargs = scm_ilength (arg_types);
+ SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
+ /* fixme: assert nargs < 1<<32 */
+ n_structs = n_struct_elts = 0;
+
+ /* For want of talloc, we're going to have to do this in two passes: first we
+ figure out how much memory is needed for all types, then we allocate the
+ cif and the types all in one block. */
+ if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
+ scm_wrong_type_arg (FUNC_NAME, 1, return_type);
+ for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
+ if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
+ scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
+
+ /* the memory: with space for the cif itself */
+ cif_len = sizeof (ffi_cif);
+
+ /* then ffi_type pointers: one for each arg, one for each struct
+ element, and one for each struct (for null-termination) */
+ cif_len = (ROUND_UP (cif_len, alignof(void*))
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*));
+
+ /* then the ffi_type structs themselves, one per arg and struct element, and
+ one for the return val */
+ cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
+ + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
+
+ mem = scm_malloc (cif_len);
+ scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, cif_len,
free);
+ cif = (ffi_cif*)mem;
+ /* reuse cif_len to walk through the mem */
+ cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
+ type_ptrs = (ffi_type**)(mem + cif_len);
+ cif_len = ROUND_UP (cif_len
+ + (nargs + n_structs + n_struct_elts)*sizeof(void*),
+ alignof(ffi_type));
+ types = (ffi_type*)(mem + cif_len);
+
+ /* whew. now knit the pointers together. */
+ cif->rtype = types++;
+ fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
+ cif->arg_types = type_ptrs;
+ type_ptrs += nargs;
+ for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
+ {
+ cif->arg_types[i] = types++;
+ fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
+ }
+
+ /* round out the cif, and we're done. */
+ cif->abi = FFI_DEFAULT_ABI;
+ cif->nargs = nargs;
+ cif->bytes = 0;
+ cif->flags = 0;
+
+ if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
+ cif->arg_types))
+ scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);
+
+ return cif_to_procedure (scm_cif, func_ptr);
+}
+#undef FUNC_NAME
+
+
+
+/* Pre-generate trampolines for less than 10 arguments. */
+
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
+#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
+#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+#define CODE(nreq) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function
pointer */ \
+ /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well)
*/ \
+ /* 7 */ scm_op_nop, \
+ /* 8 */ META (3, 7, nreq)
+
+#define META(start, end, nreq) \
+ META_HEADER, \
+ /* 0 */ scm_op_make_eol, /* bindings */ \
+ /* 1 */ scm_op_make_eol, /* sources */ \
+ /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N
to ip N */ \
+ /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
+ /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
+ /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */ \
+ /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
+ /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
+ /* 24 */ scm_op_cons, /* make a pair for the properties */ \
+ /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list
*/ \
+ /* 28 */ scm_op_return, /* and return */ \
+ /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
+ /* 32 */
+
+static const struct
+{
+ scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
+ const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
+ + sizeof (struct scm_objcode) + 32)];
+} raw_bytecode = {
+ 0,
+ {
+ CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
+ CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
+ }
+};
+
+#undef CODE
+#undef META
+#undef OBJCODE_HEADER
+#undef META_HEADER
+
+/*
+ (defun generate-objcode-cells (n)
+ "Generate objcode cells for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (< i n)
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d)
},\n"
+ (* (+ 4 4 8 4 4 32) i)))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq i (1+ i)))))
+*/
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
+{
+ scm_t_uint64 dummy; /* alignment */
+ scm_t_cell cells[10 * 2]; /* 10 double cells */
+} objcode_cells = {
+ 0,
+ /* C-u 1 0 M-x generate-objcode-cells RET */
+ {
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
+ { SCM_BOOL_F, SCM_PACK (0) }
+ }
+};
+
+static const SCM objcode_trampolines[10] = {
+ SCM_PACK (objcode_cells.cells+0),
+ SCM_PACK (objcode_cells.cells+2),
+ SCM_PACK (objcode_cells.cells+4),
+ SCM_PACK (objcode_cells.cells+6),
+ SCM_PACK (objcode_cells.cells+8),
+ SCM_PACK (objcode_cells.cells+10),
+ SCM_PACK (objcode_cells.cells+12),
+ SCM_PACK (objcode_cells.cells+14),
+ SCM_PACK (objcode_cells.cells+16),
+ SCM_PACK (objcode_cells.cells+18),
+};
+
+static SCM
+cif_to_procedure (SCM cif, SCM func_ptr)
+{
+ unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs;
+ SCM objcode, table, ret;
+
+ if (nargs < 10)
+ objcode = objcode_trampolines[nargs];
+ else
+ scm_misc_error ("make-foreign-function", "args >= 10 currently
unimplemented",
+ SCM_EOL);
+
+ table = scm_c_make_vector (2, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
+ SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
+ ret = scm_make_program (objcode, table, SCM_BOOL_F);
+
+ return ret;
+}
+
+static void
+unpack (ffi_type *type, void *loc, SCM x)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_FLOAT:
+ *(float*)loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_DOUBLE:
+ *(double*)loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_UINT8:
+ *(scm_t_uint8*)loc = scm_to_uint8 (x);
+ break;
+ case FFI_TYPE_SINT8:
+ *(scm_t_int8*)loc = scm_to_int8 (x);
+ break;
+ case FFI_TYPE_UINT16:
+ *(scm_t_uint16*)loc = scm_to_uint16 (x);
+ break;
+ case FFI_TYPE_SINT16:
+ *(scm_t_int16*)loc = scm_to_int16 (x);
+ break;
+ case FFI_TYPE_UINT32:
+ *(scm_t_uint32*)loc = scm_to_uint32 (x);
+ break;
+ case FFI_TYPE_SINT32:
+ *(scm_t_int32*)loc = scm_to_int32 (x);
+ break;
+ case FFI_TYPE_UINT64:
+ *(scm_t_uint64*)loc = scm_to_uint64 (x);
+ break;
+ case FFI_TYPE_SINT64:
+ *(scm_t_int64*)loc = scm_to_int64 (x);
+ break;
+ case FFI_TYPE_STRUCT:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ scm_wrong_type_arg_msg ("foreign-call", 0, x,
+ "foreign void pointer");
+ if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
+ scm_wrong_type_arg_msg ("foreign-call", 0, x,
+ "foreign void pointer of correct length");
+ memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
+ break;
+ case FFI_TYPE_POINTER:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ scm_wrong_type_arg_msg ("foreign-call", 0, x,
+ "foreign void pointer");
+ *(void**)loc = SCM_FOREIGN_POINTER (x, void);
break;
default:
abort ();
}
- scm_putc ('>', port);
+}
+
+static SCM
+pack (ffi_type *type, void *loc)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_VOID:
+ return SCM_UNSPECIFIED;
+ case FFI_TYPE_FLOAT:
+ return scm_from_double (*(float*)loc);
+ case FFI_TYPE_DOUBLE:
+ return scm_from_double (*(double*)loc);
+ case FFI_TYPE_UINT8:
+ return scm_from_uint8 (*(scm_t_uint8*)loc);
+ case FFI_TYPE_SINT8:
+ return scm_from_int8 (*(scm_t_int8*)loc);
+ case FFI_TYPE_UINT16:
+ return scm_from_uint16 (*(scm_t_uint16*)loc);
+ case FFI_TYPE_SINT16:
+ return scm_from_int16 (*(scm_t_int16*)loc);
+ case FFI_TYPE_UINT32:
+ return scm_from_uint32 (*(scm_t_uint32*)loc);
+ case FFI_TYPE_SINT32:
+ return scm_from_int32 (*(scm_t_int32*)loc);
+ case FFI_TYPE_UINT64:
+ return scm_from_uint64 (*(scm_t_uint64*)loc);
+ case FFI_TYPE_SINT64:
+ return scm_from_int64 (*(scm_t_int64*)loc);
+ case FFI_TYPE_STRUCT:
+ {
+ void *mem = scm_malloc (type->size);
+ memcpy (mem, loc, type->size);
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ mem, type->size, free);
+ }
+ case FFI_TYPE_POINTER:
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ *(void**)loc, 0, NULL);
+ default:
+ abort ();
+ }
+}
+
+SCM
+scm_i_foreign_call (SCM foreign, SCM *argv)
+{
+ /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
+ objtable. */
+ ffi_cif *cif;
+ void (*func)();
+ scm_t_uint8 *data;
+ void *rvalue;
+ void **args;
+ unsigned i;
+ scm_t_ptrdiff off;
+
+ cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
+ func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
+
+ /* arg pointers */
+ args = alloca (sizeof(void*) * cif->nargs);
+ /* arg values, then return type value */
+ data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
+ + cif->rtype->size);
+ /* unpack argv to native values, setting argv pointers */
+ off = 0;
+ for (i = 0; i < cif->nargs; i++)
+ {
+ off = ROUND_UP (off, cif->arg_types[i]->alignment);
+ args[i] = data + off;
+ unpack (cif->arg_types[i], args[i], argv[i]);
+ off += cif->arg_types[i]->size;
+ }
+ /* prep space for the return value */
+ off = ROUND_UP (off, cif->rtype->alignment);
+ rvalue = data + off;
+
+ /* off we go! */
+ ffi_call (cif, func, rvalue, args);
+
+ return pack (cif->rtype, rvalue);
}
-void
+static void
scm_init_foreign (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/foreign.x"
#endif
+ scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
+ scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
+ scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
+ scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
+ scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
+ scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
+ scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
+ scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
+ scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
+ scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
+ scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
+}
+
+void
+scm_register_foreign (void)
+{
+ scm_c_register_extension ("libguile", "scm_init_foreign",
+ (scm_t_extension_init_func)scm_init_foreign,
+ NULL);
+ foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}
/*
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 954c1c5..b29025d 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -21,10 +21,24 @@
-/* A subset of libffi's types. */
+/* A foreign value is some value that exists outside of Guile. It is
represented
+ by a cell whose second word is a pointer. The first word has the
+ scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
+ lower 16 bits.
+
+ There are numeric types, like uint32 and float, and there is a "generic
+ pointer" type, void. Void pointers also have a length associated with them,
+ in the high bits of the first word of the SCM object, but since they really
+ are pointers out into the wild wooly world of C, perhaps we don't actually
+ know how much memory they take up. In that, most general case, the "len"
+ will be stored as 0.
+
+ The basic idea is that we can help the programmer to avoid cutting herself,
+ but we won't take away her knives.
+*/
typedef enum
{
- SCM_FOREIGN_TYPE_VOID,
+ SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */
SCM_FOREIGN_TYPE_FLOAT,
SCM_FOREIGN_TYPE_DOUBLE,
SCM_FOREIGN_TYPE_UINT8,
@@ -35,8 +49,7 @@ typedef enum
SCM_FOREIGN_TYPE_INT32,
SCM_FOREIGN_TYPE_UINT64,
SCM_FOREIGN_TYPE_INT64,
- SCM_FOREIGN_TYPE_STRUCT,
- SCM_FOREIGN_TYPE_POINTER
+ SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
} scm_t_foreign_type;
@@ -48,12 +61,16 @@ typedef void (*scm_t_foreign_finalizer) (void *);
SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
#define SCM_FOREIGN_TYPE(x) \
((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff))
-#define SCM_FOREIGN_OBJECT(x, ctype) \
- ((ctype*)SCM_CELL_OBJECT_1 (x))
-#define SCM_FOREIGN_OBJECT_REF(x, ctype) \
- (*SCM_FOREIGN_OBJECT (x, ctype))
-#define SCM_FOREIGN_OBJECT_SET(x, ctype, val) \
- (*SCM_FOREIGN_OBJECT (x, ctype) = (val))
+#define SCM_FOREIGN_POINTER(x, ctype) \
+ ((ctype*)SCM_CELL_WORD_1 (x))
+#define SCM_FOREIGN_VALUE_REF(x, ctype) \
+ (*SCM_FOREIGN_POINTER (x, ctype))
+#define SCM_FOREIGN_VALUE_SET(x, ctype, val) \
+ (*SCM_FOREIGN_POINTER (x, ctype) = (val))
+#define SCM_FOREIGN_HAS_FINALIZER(x) \
+ ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
+#define SCM_FOREIGN_LEN(x) \
+ ((size_t)(SCM_CELL_WORD_0 (x) >> 17))
#define SCM_FOREIGN_TYPED_P(x, type) \
(SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
@@ -63,25 +80,52 @@ typedef void (*scm_t_foreign_finalizer) (void *);
"FOREIGN_"#type"_P"); \
} while (0)
-#define SCM_FOREIGN_SIMPLE_P(x) \
- (SCM_FOREIGN_P (x) \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_STRUCT \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_POINTER)
-#define SCM_VALIDATE_FOREIGN_SIMPLE(pos, x) \
- SCM_MAKE_VALIDATE (pos, x, FOREIGN_SIMPLE_P)
+#define SCM_FOREIGN_VALUE_P(x) \
+ (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID)
+#define SCM_VALIDATE_FOREIGN_VALUE(pos, x) \
+ SCM_MAKE_VALIDATE (pos, x, FOREIGN_VALUE_P)
-SCM_API SCM scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t
size,
- scm_t_foreign_finalizer finalizer);
-SCM_API SCM scm_c_take_foreign (scm_t_foreign_type type, void *val,
- scm_t_foreign_finalizer finalizer);
+SCM_API SCM scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr,
+ size_t len,
+ scm_t_foreign_finalizer finalizer);
+SCM_API SCM scm_alignof (SCM type);
+SCM_API SCM scm_sizeof (SCM type);
+SCM_API SCM scm_foreign_type (SCM foreign);
SCM_API SCM scm_foreign_ref (SCM foreign);
SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val);
+SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
+ SCM offset, SCM len);
+SCM_API SCM scm_foreign_set_finalizer_x (SCM foreign, SCM finalizer);
+SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
scm_print_state *pstate);
-SCM_INTERNAL void scm_init_foreign (void);
+
+
+
+/* Foreign functions */
+
+/* The goal is to make it so that calling a foreign function doesn't cause any
+ heap allocation. That means we need native Scheme formats for all kinds of
+ arguments.
+
+ For "value" types like s64 or f32, we just use native Scheme value types.
+ (Note that in both these cases, allocation is possible / likely, as the
+ value might need to be boxed, but perhaps we won't worry about that. Hmm.)
+
+ For everything else, we use foreign pointers. This includes arrays, pointer
+ arguments and return vals, struct args and return vals, and out and in/out
+ arguments.
+ */
+
+SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
+ SCM arg_types);
+SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, SCM *argv);
+
+
+
+SCM_INTERNAL void scm_register_foreign (void);
#endif /* SCM_FOREIGN_H */
diff --git a/libguile/goops.c b/libguile/goops.c
index 33293fe..6fc073b 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1725,10 +1725,10 @@ SCM_DEFINE (scm_enable_primitive_generic_x,
"enable-primitive-generic!", 0, 0, 1
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr)
- = scm_make (scm_list_3 (scm_class_generic,
- k_name,
- SCM_SUBR_NAME (subr)));
+ SCM_SET_SUBR_GENERIC (subr,
+ scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ SCM_SUBR_NAME (subr))));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
@@ -1742,7 +1742,7 @@ SCM_DEFINE (scm_set_primitive_generic_x,
"set-primitive-generic!", 2, 0, 0,
{
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr) = generic;
+ SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index f0c6222..de4bff6 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -794,13 +794,13 @@ create_gsubr (int define, const char *name,
sname = scm_from_locale_symbol (name);
table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0,
- scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
- &fcn, 0, NULL));
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ fcn, 0, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
if (generic_loc)
SCM_SIMPLE_VECTOR_SET (table, 2,
- scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
- &generic_loc, 0, NULL));
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ generic_loc, 0, NULL));
/* make program */
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index a4dc560..e94d0d0 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -43,10 +43,10 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) &&
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
-#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF
(SCM_PROGRAM_OBJTABLE (x), 0), void*)))
+#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF
(SCM_PROGRAM_OBJTABLE (x), 0), void)))
#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
#define SCM_SUBR_GENERIC(x) \
- (SCM_FOREIGN_OBJECT_REF (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x),
2), SCM*))
+ (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2),
SCM))
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
diff --git a/libguile/init.c b/libguile/init.c
index abca490..57fda40 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -452,6 +452,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_bootstrap_objcodes ();
scm_bootstrap_programs ();
scm_bootstrap_vm ();
+ scm_register_foreign ();
scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
@@ -482,7 +483,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_ports ();
scm_init_hash ();
scm_init_hashtab ();
- scm_init_foreign ();
scm_init_deprecation ();
scm_init_objprop ();
scm_init_promises (); /* requires smob_prehistory */
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 717c953..98f6601 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -105,10 +105,8 @@ SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME);
\
SCM_SNARF_HERE(
\
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- static const scm_t_bits scm_i_paste (FNAME, __subr_ptr) = \
- (scm_t_bits) &FNAME; /* the subr */ \
SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
- scm_i_paste (FNAME, __subr_ptr)); \
+ (scm_t_bits) &FNAME); /* the subr */ \
SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
/* FIXME: directly be the foreign */ \
SCM_BOOL_F); \
@@ -363,10 +361,10 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_FOREIGN(c_name, loc) \
+#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, \
- scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \
- &loc)
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
+ ptr)
/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index ef53cdd..a9326c9 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -20,7 +20,7 @@
/* This file is included in vm_engine.c */
-VM_DEFINE_LOADER (82, load_number, "load-number")
+VM_DEFINE_LOADER (101, load_number, "load-number")
{
size_t len;
@@ -33,7 +33,7 @@ VM_DEFINE_LOADER (82, load_number, "load-number")
NEXT;
}
-VM_DEFINE_LOADER (83, load_string, "load-string")
+VM_DEFINE_LOADER (102, load_string, "load-string")
{
size_t len;
char *buf;
@@ -46,7 +46,7 @@ VM_DEFINE_LOADER (83, load_string, "load-string")
NEXT;
}
-VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
+VM_DEFINE_LOADER (103, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
@@ -57,7 +57,7 @@ VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
NEXT;
}
-VM_DEFINE_LOADER (86, load_program, "load-program")
+VM_DEFINE_LOADER (104, load_program, "load-program")
{
scm_t_uint32 len;
SCM objs, objcode;
@@ -78,7 +78,7 @@ VM_DEFINE_LOADER (86, load_program, "load-program")
NEXT;
}
-VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1)
{
SCM what;
POP (what);
@@ -87,7 +87,7 @@ VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
NEXT;
}
-VM_DEFINE_LOADER (89, load_array, "load-array")
+VM_DEFINE_LOADER (106, load_array, "load-array")
{
SCM type, shape;
size_t len;
@@ -100,7 +100,7 @@ VM_DEFINE_LOADER (89, load_array, "load-array")
NEXT;
}
-VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
+VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
{
size_t len;
scm_t_wchar *wbuf;
@@ -124,7 +124,7 @@ VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 79)) (goto-char (point-min))
+ (let ((counter 100)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index e5e73dd..20ec9f6 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -29,43 +29,43 @@
#define RETURN(x) do { *sp = x; NEXT; } while (0)
-VM_DEFINE_FUNCTION (100, not, "not", 1)
+VM_DEFINE_FUNCTION (128, not, "not", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_false_or_nil (x)));
}
-VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
+VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (!scm_is_false_or_nil (x)));
}
-VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
+VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
{
ARGS2 (x, y);
RETURN (scm_from_bool (scm_is_eq (x, y)));
}
-VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
+VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
{
ARGS2 (x, y);
RETURN (scm_from_bool (!scm_is_eq (x, y)));
}
-VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
+VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_null_or_nil (x)));
}
-VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
+VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (!scm_is_null_or_nil (x)));
}
-VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
-VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
+VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
-VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_pair (x)));
}
-VM_DEFINE_FUNCTION (109, listp, "list?", 1)
+VM_DEFINE_FUNCTION (137, listp, "list?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_ilength (x) >= 0));
@@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (109, listp, "list?", 1)
* Basic data
*/
-VM_DEFINE_FUNCTION (110, cons, "cons", 2)
+VM_DEFINE_FUNCTION (138, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (110, cons, "cons", 2)
goto vm_error_not_a_pair; \
}
-VM_DEFINE_FUNCTION (111, car, "car", 1)
+VM_DEFINE_FUNCTION (139, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CAR (x));
}
-VM_DEFINE_FUNCTION (112, cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (140, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CDR (x));
}
-VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (141, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
POP (y);
@@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (142, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
POP (y);
@@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
RETURN (srel (x, y)); \
}
-VM_DEFINE_FUNCTION (115, ee, "ee?", 2)
+VM_DEFINE_FUNCTION (143, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
-VM_DEFINE_FUNCTION (116, lt, "lt?", 2)
+VM_DEFINE_FUNCTION (144, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
-VM_DEFINE_FUNCTION (117, le, "le?", 2)
+VM_DEFINE_FUNCTION (145, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
-VM_DEFINE_FUNCTION (118, gt, "gt?", 2)
+VM_DEFINE_FUNCTION (146, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
-VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
+VM_DEFINE_FUNCTION (147, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@@ -210,12 +210,12 @@ VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
RETURN (SFUNC (x, y)); \
}
-VM_DEFINE_FUNCTION (120, add, "add", 2)
+VM_DEFINE_FUNCTION (148, add, "add", 2)
{
FUNC2 (+, scm_sum);
}
-VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+VM_DEFINE_FUNCTION (149, add1, "add1", 1)
{
ARGS1 (x);
if (SCM_I_INUMP (x))
@@ -228,12 +228,12 @@ VM_DEFINE_FUNCTION (167, add1, "add1", 1)
RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
}
-VM_DEFINE_FUNCTION (121, sub, "sub", 2)
+VM_DEFINE_FUNCTION (150, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
-VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+VM_DEFINE_FUNCTION (151, sub1, "sub1", 1)
{
ARGS1 (x);
if (SCM_I_INUMP (x))
@@ -246,42 +246,42 @@ VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
}
-VM_DEFINE_FUNCTION (122, mul, "mul", 2)
+VM_DEFINE_FUNCTION (152, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
-VM_DEFINE_FUNCTION (123, div, "div", 2)
+VM_DEFINE_FUNCTION (153, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
-VM_DEFINE_FUNCTION (124, quo, "quo", 2)
+VM_DEFINE_FUNCTION (154, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
-VM_DEFINE_FUNCTION (125, rem, "rem", 2)
+VM_DEFINE_FUNCTION (155, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
-VM_DEFINE_FUNCTION (126, mod, "mod", 2)
+VM_DEFINE_FUNCTION (156, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_modulo (x, y));
}
-VM_DEFINE_FUNCTION (170, ash, "ash", 2)
+VM_DEFINE_FUNCTION (157, ash, "ash", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -297,7 +297,7 @@ VM_DEFINE_FUNCTION (170, ash, "ash", 2)
RETURN (scm_ash (x, y));
}
-VM_DEFINE_FUNCTION (171, logand, "logand", 2)
+VM_DEFINE_FUNCTION (158, logand, "logand", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -306,7 +306,7 @@ VM_DEFINE_FUNCTION (171, logand, "logand", 2)
RETURN (scm_logand (x, y));
}
-VM_DEFINE_FUNCTION (172, logior, "logior", 2)
+VM_DEFINE_FUNCTION (159, logior, "logior", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -315,7 +315,7 @@ VM_DEFINE_FUNCTION (172, logior, "logior", 2)
RETURN (scm_logior (x, y));
}
-VM_DEFINE_FUNCTION (173, logxor, "logxor", 2)
+VM_DEFINE_FUNCTION (160, logxor, "logxor", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -326,35 +326,10 @@ VM_DEFINE_FUNCTION (173, logxor, "logxor", 2)
/*
- * GOOPS support
+ * Vectors and arrays
*/
-VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
-{
- ARGS1 (obj);
- RETURN (SCM_INSTANCEP (obj) ? SCM_CLASS_OF (obj) : scm_class_of (obj));
-}
-VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
-{
- size_t slot;
- ARGS2 (instance, idx);
- slot = SCM_I_INUM (idx);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
-}
-
-VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0)
-{
- SCM instance, idx, val;
- size_t slot;
- POP (val);
- POP (idx);
- POP (instance);
- slot = SCM_I_INUM (idx);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
- NEXT;
-}
-
-VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (161, vector_ref, "vector-ref", 2)
{
long i = 0;
ARGS2 (vect, idx);
@@ -370,7 +345,7 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
}
}
-VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (162, vector_set, "vector-set", 0, 3, 0)
{
long i = 0;
SCM vect, idx, val;
@@ -388,6 +363,169 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0,
3, 0)
NEXT;
}
+VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3, -1, 1)
+{
+ scm_t_uint32 len;
+ SCM shape, ret;
+
+ len = FETCH ();
+ len = (len << 8) + FETCH ();
+ len = (len << 8) + FETCH ();
+ POP (shape);
+ SYNC_REGISTER ();
+ ret = scm_from_contiguous_array (shape, sp - len + 1, len);
+ DROPN (len);
+ PUSH (ret);
+ NEXT;
+}
+
+
+/*
+ * Structs
+ */
+#define VM_VALIDATE_STRUCT(obj) \
+ if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
+ { \
+ finish_args = (obj); \
+ goto vm_error_not_a_struct; \
+ }
+
+VM_DEFINE_FUNCTION (164, struct_p, "struct?", 1)
+{
+ ARGS1 (obj);
+ RETURN (scm_from_bool (SCM_STRUCTP (obj)));
+}
+
+VM_DEFINE_FUNCTION (165, struct_vtable, "struct-vtable", 1)
+{
+ ARGS1 (obj);
+ VM_VALIDATE_STRUCT (obj);
+ RETURN (SCM_STRUCT_VTABLE (obj));
+}
+
+VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ scm_t_bits n_args = ((h << 8U) + l);
+ SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
+ const SCM *inits = sp - n_args + 3;
+
+ sp -= n_args - 1;
+
+ if (SCM_LIKELY (SCM_STRUCTP (vtable)
+ && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (n_tail)))
+ {
+ scm_t_bits n_inits, len;
+
+ n_inits = SCM_I_INUM (n_tail) + n_args - 2;
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (n_inits == len))
+ {
+ SCM obj;
+
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits);
+ memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM));
+
+ RETURN (obj);
+ }
+ }
+
+ SYNC_REGISTER ();
+ RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
+ n_args - 2, (scm_t_bits *) inits));
+}
+
+VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2)
+{
+ ARGS2 (obj, pos);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ RETURN (SCM_PACK (data[index]));
+ }
+ }
+
+ RETURN (scm_struct_ref (obj, pos));
+}
+
+VM_DEFINE_FUNCTION (168, struct_set, "struct-set", 3)
+{
+ ARGS3 (obj, pos, val);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE_RW)
+ && SCM_I_INUMP (pos)))
+ {
+ SCM vtable;
+ scm_t_bits index, len;
+
+ index = SCM_I_INUM (pos);
+ vtable = SCM_STRUCT_VTABLE (obj);
+ len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+ if (SCM_LIKELY (index < len))
+ {
+ scm_t_bits *data = SCM_STRUCT_DATA (obj);
+ data[index] = SCM_UNPACK (val);
+ RETURN (val);
+ }
+ }
+
+ RETURN (scm_struct_set_x (obj, pos, val));
+}
+
+
+/*
+ * GOOPS support
+ */
+VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
+{
+ ARGS1 (obj);
+ RETURN (SCM_INSTANCEP (obj) ? SCM_CLASS_OF (obj) : scm_class_of (obj));
+}
+
+VM_DEFINE_FUNCTION (170, slot_ref, "slot-ref", 2)
+{
+ size_t slot;
+ ARGS2 (instance, idx);
+ slot = SCM_I_INUM (idx);
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+}
+
+VM_DEFINE_INSTRUCTION (171, slot_set, "slot-set", 0, 3, 0)
+{
+ SCM instance, idx, val;
+ size_t slot;
+ POP (val);
+ POP (idx);
+ POP (instance);
+ slot = SCM_I_INUM (idx);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
+ NEXT;
+}
+
+
+/*
+ * Bytevectors
+ */
#define VM_VALIDATE_BYTEVECTOR(x) \
if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
{ finish_args = x; \
@@ -406,21 +544,21 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0,
3, 0)
} \
}
-VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (172, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (173, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (174, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (175, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (176, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (177, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (178, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3)
+VM_DEFINE_FUNCTION (179, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
@@ -473,33 +611,33 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \
}
-VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (180, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2)
+VM_DEFINE_FUNCTION (181, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2)
+VM_DEFINE_FUNCTION (182, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
+VM_DEFINE_FUNCTION (183, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
+VM_DEFINE_FUNCTION (184, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
-VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
+VM_DEFINE_FUNCTION (185, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
-VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
+VM_DEFINE_FUNCTION (186, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
+VM_DEFINE_FUNCTION (187, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2)
+VM_DEFINE_FUNCTION (188, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2)
+VM_DEFINE_FUNCTION (189, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
@@ -521,21 +659,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
} \
}
-VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (190, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (191, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (192, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (193, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (194, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (195, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (196, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (197, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
@@ -588,170 +726,45 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (198, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (199, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (200, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (201, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX,
2)
-VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (202, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
-VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (203, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX,
4)
#else
BV_INT_SET (s32, int32, 4)
#endif
-VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (204, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (205, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (206, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (207, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
#undef BV_INT_SET
#undef BV_FLOAT_SET
-#define VM_VALIDATE_STRUCT(obj) \
- if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
- { \
- finish_args = (obj); \
- goto vm_error_not_a_struct; \
- }
-
-VM_DEFINE_FUNCTION (174, struct_p, "struct?", 1)
-{
- ARGS1 (obj);
- RETURN (scm_from_bool (SCM_STRUCTP (obj)));
-}
-
-VM_DEFINE_FUNCTION (175, struct_vtable, "struct-vtable", 1)
-{
- ARGS1 (obj);
- VM_VALIDATE_STRUCT (obj);
- RETURN (SCM_STRUCT_VTABLE (obj));
-}
-
-VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- scm_t_bits n_args = ((h << 8U) + l);
- SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
- const SCM *inits = sp - n_args + 3;
-
- sp -= n_args - 1;
-
- if (SCM_LIKELY (SCM_STRUCTP (vtable)
- && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && SCM_I_INUMP (n_tail)))
- {
- scm_t_bits n_inits, len;
-
- n_inits = SCM_I_INUM (n_tail) + n_args - 2;
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
-
- if (SCM_LIKELY (n_inits == len))
- {
- SCM obj;
-
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits);
- memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM));
-
- RETURN (obj);
- }
- }
-
- SYNC_REGISTER ();
- RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
- n_args - 2, (scm_t_bits *) inits));
-}
-
-VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3, -1, 1)
-{
- scm_t_uint32 len;
- SCM shape, ret;
-
- len = FETCH ();
- len = (len << 8) + FETCH ();
- len = (len << 8) + FETCH ();
- POP (shape);
- SYNC_REGISTER ();
- ret = scm_from_contiguous_array (shape, sp - len + 1, len);
- DROPN (len);
- PUSH (ret);
- NEXT;
-}
-
-VM_DEFINE_FUNCTION (178, struct_ref, "struct-ref", 2)
-{
- ARGS2 (obj, pos);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
-
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- RETURN (SCM_PACK (data[index]));
- }
- }
-
- RETURN (scm_struct_ref (obj, pos));
-}
-
-VM_DEFINE_FUNCTION (179, struct_set, "struct-set", 3)
-{
- ARGS3 (obj, pos, val);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE_RW)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- data[index] = SCM_UNPACK (val);
- RETURN (val);
- }
- }
-
- RETURN (scm_struct_set_x (obj, pos, val));
-}
-
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 99)) (goto-char (point-min))
+ (let ((counter 127)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8297c5b..8c280fd 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -322,7 +322,7 @@ VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0,
1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 1, 1)
{
if (VARIABLE_BOUNDP (*sp))
*sp = SCM_BOOL_T;
@@ -835,14 +835,14 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1,
1)
}
}
-VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
{
SCM foreign, ret;
SCM (*subr)();
nargs = FETCH ();
POP (foreign);
- subr = SCM_FOREIGN_OBJECT_REF (foreign, void*);
+ subr = SCM_FOREIGN_POINTER (foreign, void);
VM_HANDLE_INTERRUPTS;
SYNC_REGISTER ();
@@ -903,7 +903,7 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1,
-1)
}
}
-VM_DEFINE_INSTRUCTION (81, smob_call, "smob-call", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (57, smob_call, "smob-call", 1, -1, -1)
{
SCM smob, ret;
SCM (*subr)();
@@ -950,7 +950,35 @@ VM_DEFINE_INSTRUCTION (81, smob_call, "smob-call", 1, -1,
-1)
}
}
-VM_DEFINE_INSTRUCTION (56, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1)
+{
+ SCM foreign, ret;
+ nargs = FETCH ();
+ POP (foreign);
+
+ VM_HANDLE_INTERRUPTS;
+ SYNC_REGISTER ();
+
+ ret = scm_i_foreign_call (foreign, sp - nargs + 1);
+
+ NULLSTACK_FOR_NONLOCAL_EXIT ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ {
+ /* multiple values returned to continuation */
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ nvalues = scm_ilength (ret);
+ PUSH_LIST (ret, scm_is_null);
+ goto vm_return_values;
+ }
+ else
+ {
+ PUSH (ret);
+ goto vm_return;
+ }
+}
+
+VM_DEFINE_INSTRUCTION (59, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -959,7 +987,7 @@ VM_DEFINE_INSTRUCTION (56, tail_call_nargs,
"tail-call/nargs", 0, 0, 1)
goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (60, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -968,7 +996,7 @@ VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0,
1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
+VM_DEFINE_INSTRUCTION (61, mv_call, "mv-call", 4, -1, 1)
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
@@ -1012,7 +1040,7 @@ VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (62, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -1031,7 +1059,7 @@ VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (60, tail_apply, "tail-apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -1050,7 +1078,7 @@ VM_DEFINE_INSTRUCTION (60, tail_apply, "tail-apply", 1,
-1, 1)
goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1087,7 +1115,7 @@ VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (62, tail_call_cc, "tail-call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1119,7 +1147,7 @@ VM_DEFINE_INSTRUCTION (62, tail_call_cc, "tail-call/cc",
0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1156,7 +1184,7 @@ VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (67, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say.
*/
@@ -1213,7 +1241,7 @@ VM_DEFINE_INSTRUCTION (64, return_values,
"return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (68, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1236,7 +1264,7 @@ VM_DEFINE_INSTRUCTION (65, return_values_star,
"return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (69, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1259,7 +1287,7 @@ VM_DEFINE_INSTRUCTION (66, truncate_values,
"truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (70, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1273,7 +1301,7 @@ VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (71, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1281,7 +1309,7 @@ VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0,
0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (72, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1289,7 +1317,7 @@ VM_DEFINE_INSTRUCTION (69, local_boxed_ref,
"local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (73, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1299,7 +1327,7 @@ VM_DEFINE_INSTRUCTION (70, local_boxed_set,
"local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (74, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1310,7 +1338,7 @@ VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (75, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1321,7 +1349,7 @@ VM_DEFINE_INSTRUCTION (72, free_boxed_ref,
"free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (76, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1333,7 +1361,7 @@ VM_DEFINE_INSTRUCTION (73, free_boxed_set,
"free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (77, make_closure, "make-closure", 2, -1, 1)
{
size_t n, len;
SCM closure;
@@ -1352,7 +1380,7 @@ VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure",
2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (78, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1360,7 +1388,7 @@ VM_DEFINE_INSTRUCTION (75, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, -1, 0)
+VM_DEFINE_INSTRUCTION (79, fix_closure, "fix-closure", 2, -1, 0)
{
SCM x;
unsigned int i = FETCH ();
@@ -1377,7 +1405,7 @@ VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2,
-1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (80, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1389,7 +1417,7 @@ VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (81, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1397,7 +1425,7 @@ VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword",
0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
diff --git a/module/Makefile.am b/module/Makefile.am
index b43cf2e..7b1bbea 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -284,6 +284,7 @@ SYSTEM_SOURCES = \
system/vm/program.scm \
system/vm/trace.scm \
system/vm/vm.scm \
+ system/foreign.scm \
system/xref.scm \
system/repl/repl.scm \
system/repl/common.scm \
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 8a72e93..3bf83a9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -116,6 +116,7 @@
((variable-ref . 1) . variable-ref)
;; nb, *not* variable-set! -- the args are switched
((variable-set . 2) . variable-set)
+ ((variable-bound? . 1) . variable-bound?)
((struct? . 1) . struct?)
((struct-vtable . 1) . struct-vtable)
((struct-ref . 2) . struct-ref)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 83bfc0e..ae4d3b1 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -56,6 +56,7 @@
vector-ref vector-set!
variable-ref variable-set!
+ variable-bound?
;; args of variable-set are switched; it needs special help
struct? struct-vtable make-struct struct-ref struct-set!
diff --git a/module/statprof.scm b/module/statprof.scm
index 5a1315b..2a6cf12 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -214,10 +214,14 @@
(+ accumulated-time 0.0 (- ,stop-time last-start-time))))
(define (get-call-data proc)
- (or (hashq-ref procedure-data proc)
- (let ((call-data (make-call-data proc 0 0 0)))
- (hashq-set! procedure-data proc call-data)
- call-data)))
+ (let ((k (if (or (not (program? proc))
+ (zero? (program-num-free-variables proc)))
+ proc
+ (program-objcode proc))))
+ (or (hashq-ref procedure-data k)
+ (let ((call-data (make-call-data proc 0 0 0)))
+ (hashq-set! procedure-data k call-data)
+ call-data))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SIGPROF handler
@@ -351,7 +355,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
0 0
(car sampling-frequency)
(cdr sampling-frequency)))
- (add-hook! (vm-apply-hook (the-vm)) count-call)
+ (if %count-calls?
+ (add-hook! (vm-apply-hook (the-vm)) count-call))
(set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
#t)))
@@ -366,7 +371,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
(set! gc-time-taken
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
(set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
- (remove-hook! (vm-apply-hook (the-vm)) count-call)
+ (if %count-calls?
+ (remove-hook! (vm-apply-hook (the-vm)) count-call))
;; I believe that we need to do this before getting the time
;; (unless we want to make things even more complicated).
(set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
@@ -571,23 +577,13 @@ to @code{statprof-reset} is true."
stacks)
(define procedure=?
- (if (false-if-exception (resolve-interface '(system base compile)))
- (lambda (a b)
- (cond
- ((eq? a b))
- ((and (program? a) (program? b))
- (eq? (program-objcode a) (program-objcode b)))
- (else
- #f)))
- (lambda (a b)
- (cond
- ((eq? a b))
- ((and (closure? a) (closure? b)
- (procedure-source a) (procedure-source b))
- (and (eq? (procedure-name a) (procedure-name b))
- (equal? (procedure-source a) (procedure-source b))))
- (else
- #f)))))
+ (lambda (a b)
+ (cond
+ ((eq? a b))
+ ((and (program? a) (program? b))
+ (eq? (program-objcode a) (program-objcode b)))
+ (else
+ #f))))
;; tree ::= (car n . tree*)
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
new file mode 100644
index 0000000..2a74332
--- /dev/null
+++ b/module/system/foreign.scm
@@ -0,0 +1,103 @@
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+
+(define-module (system foreign)
+ #:use-module (rnrs bytevector)
+ #:export (void
+ float double
+ int8 uint8
+ uint16 int16
+ uint32 int32
+ uint64 int64
+
+ sizeof alignof
+
+ foreign-ref foreign-set!
+ foreign->bytevector bytevector->foreign
+ foreign-set-finalizer!
+ make-foreign-function
+ make-c-struct parse-c-struct))
+
+(load-extension "libguile" "scm_init_foreign")
+
+(define *writers*
+ `((,float . ,bytevector-ieee-single-native-set!)
+ (,double . ,bytevector-ieee-double-native-set!)
+ (,int8 . ,bytevector-s8-set!)
+ (,uint8 . ,bytevector-u8-set!)
+ (,int16 . ,bytevector-s16-native-set!)
+ (,uint16 . ,bytevector-u16-native-set!)
+ (,int32 . ,bytevector-s32-native-set!)
+ (,uint32 . ,bytevector-u32-native-set!)
+ (,int64 . ,bytevector-s64-native-set!)
+ (,uint64 . ,bytevector-u64-native-set!)))
+
+(define *readers*
+ `((,float . ,bytevector-ieee-single-native-ref)
+ (,double . ,bytevector-ieee-double-native-ref)
+ (,int8 . ,bytevector-s8-ref)
+ (,uint8 . ,bytevector-u8-ref)
+ (,int16 . ,bytevector-s16-native-ref)
+ (,uint16 . ,bytevector-u16-native-ref)
+ (,int32 . ,bytevector-s32-native-ref)
+ (,uint32 . ,bytevector-u32-native-ref)
+ (,int64 . ,bytevector-s64-native-ref)
+ (,uint64 . ,bytevector-u64-native-ref)))
+
+(define (align off alignment)
+ (1+ (logior (1- off) (1- alignment))))
+
+(define (write-c-struct bv offset types vals)
+ (let lp ((offset offset) (types types) (vals vals))
+ (cond
+ ((not (pair? types))
+ (or (null? vals)
+ (error "too many values" vals)))
+ ((not (pair? vals))
+ (error "too few values" types))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof type))))
+ (if (pair? type)
+ (write-c-struct bv offset (car types) (car vals))
+ ((assv-ref *writers* type) bv offset (car vals)))
+ (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
+
+(define (read-c-struct bv offset types)
+ (let lp ((offset offset) (types types) (vals '()))
+ (cond
+ ((not (pair? types))
+ (reverse vals))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof type))))
+ (lp (+ offset (sizeof type)) (cdr types)
+ (cons (if (pair? type)
+ (read-c-struct bv offset (car types))
+ ((assv-ref *readers* type) bv offset))
+ vals)))))))
+
+(define (make-c-struct types vals)
+ (let ((bv (make-bytevector (sizeof types) 0)))
+ (write-c-struct bv 0 types vals)
+ (bytevector->foreign bv)))
+
+(define (parse-c-struct foreign types)
+ (read-c-struct (foreign->bytevector foreign) 0 types))
diff --git a/test-suite/standalone/Makefile.am
b/test-suite/standalone/Makefile.am
index 27fe3c1..46a7759 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009 Software Foundation, Inc.
+## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -87,6 +87,16 @@ BUILT_SOURCES += test-asmobs-lib.x
check_SCRIPTS += test-asmobs
TESTS += test-asmobs
+# test-ffi
+noinst_LTLIBRARIES += libtest-ffi.la
+libtest_ffi_la_SOURCES = test-ffi-lib.c test-ffi-lib.x
+libtest_ffi_la_CFLAGS = ${test_cflags}
+libtest_ffi_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really
build an .so
+libtest_ffi_la_LIBADD = ${top_builddir}/libguile/libguile.la
+BUILT_SOURCES += test-ffi-lib.x
+check_SCRIPTS += test-ffi
+TESTS += test-ffi
+
# test-list
test_list_SOURCES = test-list.c
test_list_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
new file mode 100755
index 0000000..5487625
--- /dev/null
+++ b/test-suite/standalone/test-ffi
@@ -0,0 +1,174 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+(use-modules (system foreign)
+ (rnrs bytevector))
+
+(define lib
+ (dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ exp res)
+ (let ((expected res)
+ (actual exp))
+ (if (not (equal? actual expected))
+ (error "Bad return from expression" 'exp actual expected))))))
+
+;;;
+;;; No args
+;;;
+(define f-v-
+ (make-foreign-function void (dynamic-func "test_ffi_v_" lib) '()))
+(test (f-v-) *unspecified*)
+
+(define f-s8-
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_" lib) '()))
+(test (f-s8-) -100)
+
+(define f-u8-
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_" lib) '()))
+(test (f-u8-) 200)
+
+(define f-s16-
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_" lib) '()))
+(test (f-s16-) -20000)
+
+(define f-u16-
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_" lib) '()))
+(test (f-u16-) 40000)
+
+(define f-s32-
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_" lib) '()))
+(test (f-s32-) -2000000000)
+
+(define f-u32-
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_" lib) '()))
+(test (f-u32-) 4000000000)
+
+(define f-s64-
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_" lib) '()))
+(test (f-s64-) -2000000000)
+
+(define f-u64-
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_" lib) '()))
+(test (f-u64-) 4000000000)
+
+;;;
+;;; One u8 arg
+;;;
+(define f-v-u8
+ (make-foreign-function void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
+(test (f-v-u8 10) *unspecified*)
+
+(define f-s8-u8
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_u8" lib) (list
uint8)))
+(test (f-s8-u8 10) -90)
+
+(define f-u8-u8
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_u8" lib) (list
uint8)))
+(test (f-u8-u8 10) 210)
+
+(define f-s16-u8
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_u8" lib) (list
uint8)))
+(test (f-s16-u8 10) -19990)
+
+(define f-u16-u8
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_u8" lib) (list
uint8)))
+(test (f-u16-u8 10) 40010)
+
+(define f-s32-u8
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_u8" lib) (list
uint8)))
+(test (f-s32-u8 10) -1999999990)
+
+(define f-u32-u8
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_u8" lib) (list
uint8)))
+(test (f-u32-u8 10) 4000000010)
+
+(define f-s64-u8
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_u8" lib) (list
uint8)))
+(test (f-s64-u8 10) -1999999990)
+
+(define f-u64-u8
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_u8" lib) (list
uint8)))
+(test (f-u64-u8 10) 4000000010)
+
+
+;;;
+;;; One s64 arg
+;;;
+(define f-v-s64
+ (make-foreign-function void (dynamic-func "test_ffi_v_s64" lib) (list
int64)))
+(test (f-v-s64 10) *unspecified*)
+
+(define f-s8-s64
+ (make-foreign-function int8 (dynamic-func "test_ffi_s8_s64" lib) (list
int64)))
+(test (f-s8-s64 10) -90)
+
+(define f-u8-s64
+ (make-foreign-function uint8 (dynamic-func "test_ffi_u8_s64" lib) (list
int64)))
+(test (f-u8-s64 10) 210)
+
+(define f-s16-s64
+ (make-foreign-function int16 (dynamic-func "test_ffi_s16_s64" lib) (list
int64)))
+(test (f-s16-s64 10) -19990)
+
+(define f-u16-s64
+ (make-foreign-function uint16 (dynamic-func "test_ffi_u16_s64" lib) (list
int64)))
+(test (f-u16-s64 10) 40010)
+
+(define f-s32-s64
+ (make-foreign-function int32 (dynamic-func "test_ffi_s32_s64" lib) (list
int64)))
+(test (f-s32-s64 10) -1999999990)
+
+(define f-u32-s64
+ (make-foreign-function uint32 (dynamic-func "test_ffi_u32_s64" lib) (list
int64)))
+(test (f-u32-s64 10) 4000000010)
+
+(define f-s64-s64
+ (make-foreign-function int64 (dynamic-func "test_ffi_s64_s64" lib) (list
int64)))
+(test (f-s64-s64 10) -1999999990)
+
+(define f-u64-s64
+ (make-foreign-function uint64 (dynamic-func "test_ffi_u64_s64" lib) (list
int64)))
+(test (f-u64-s64 10) 4000000010)
+
+
+;;
+;; Multiple int args of differing types
+;;
+(define f-sum
+ (make-foreign-function int64 (dynamic-func "test_ffi_sum" lib)
+ (list int8 int16 int32 int64)))
+(test (f-sum -1 2000 -30000 40000000000)
+ (+ -1 2000 -30000 40000000000))
+
+;;
+;; Structs
+;;
+(define f-sum-struct
+ (make-foreign-function int64 (dynamic-func "test_ffi_sum_struct" lib)
+ (list (list int8 int16 int32 int64))))
+(test (f-sum-struct (make-c-struct (list int8 int16 int32 int64)
+ (list -1 2000 -30000 40000000000)))
+ (+ -1 2000 -30000 40000000000))
+;;
+;; Structs
+;;
+(define f-memcpy
+ (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
+ (list '* '* int32)))
+(let* ((src (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
+ (dest (bytevector->foreign (make-bytevector 16 0)))
+ (res (f-memcpy dest src (bytevector-length (foreign->bytevector src)))))
+ (or (= (foreign-ref dest) (foreign-ref res))
+ (error "memcpy res not equal to dest"))
+ (or (equal? (bytevector->u8-list (foreign->bytevector dest))
+ '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
+ (error "unexpected dest")))
+
+
+;; Local Variables:
+;; mode: scheme
+;; End:
\ No newline at end of file
diff --git a/test-suite/standalone/test-ffi-lib.c
b/test-suite/standalone/test-ffi-lib.c
new file mode 100644
index 0000000..8dec3d3
--- /dev/null
+++ b/test-suite/standalone/test-ffi-lib.c
@@ -0,0 +1,215 @@
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+void test_ffi_v_ (void);
+void test_ffi_v_ (void)
+{
+ return;
+}
+
+void test_ffi_v_u8 (scm_t_uint8 a);
+void test_ffi_v_u8 (scm_t_uint8 a)
+{
+ return;
+}
+
+void test_ffi_v_s64 (scm_t_int64 a);
+void test_ffi_v_s64 (scm_t_int64 a)
+{
+ return;
+}
+
+scm_t_int8 test_ffi_s8_ (void);
+scm_t_int8 test_ffi_s8_ (void)
+{
+ return -100;
+}
+scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a);
+scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a)
+{
+ return -100 + a;
+}
+
+scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a);
+scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a)
+{
+ return -100 + a;
+}
+
+scm_t_uint8 test_ffi_u8_ (void);
+scm_t_uint8 test_ffi_u8_ (void)
+{
+ return 200;
+}
+
+scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a);
+scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a)
+{
+ return 200 + a;
+}
+
+scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a);
+scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a)
+{
+ return 200 + a;
+}
+
+scm_t_int16 test_ffi_s16_ (void);
+scm_t_int16 test_ffi_s16_ (void)
+{
+ return -20000;
+}
+
+scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a);
+scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a)
+{
+ return -20000 + a;
+}
+
+scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a);
+scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a)
+{
+ return -20000 + a;
+}
+
+scm_t_uint16 test_ffi_u16_ (void);
+scm_t_uint16 test_ffi_u16_ (void)
+{
+ return 40000;
+}
+
+scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a);
+scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a)
+{
+ return 40000 + a;
+}
+
+scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a);
+scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a)
+{
+ return 40000 + a;
+}
+
+scm_t_int32 test_ffi_s32_ (void);
+scm_t_int32 test_ffi_s32_ (void)
+{
+ return -2000000000;
+}
+
+scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a);
+scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a);
+scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_uint32 test_ffi_u32_ (void);
+scm_t_uint32 test_ffi_u32_ (void)
+{
+ return 4000000000;
+}
+
+scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a);
+scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a)
+{
+ return 4000000000 + a;
+}
+
+scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a);
+scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a)
+{
+ return 4000000000 + a;
+}
+
+/* FIXME: use 64-bit literals */
+scm_t_int64 test_ffi_s64_ (void);
+scm_t_int64 test_ffi_s64_ (void)
+{
+ return -2000000000;
+}
+
+scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a);
+scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a);
+scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a)
+{
+ return -2000000000 + a;
+}
+
+scm_t_uint64 test_ffi_u64_ (void);
+scm_t_uint64 test_ffi_u64_ (void)
+{
+ return 4000000000;
+}
+
+scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a);
+scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a)
+{
+ return 4000000000 + a;
+}
+
+scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a);
+scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a)
+{
+ return 4000000000 + a;
+}
+
+
+scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
+ scm_t_int32 c, scm_t_int64 d);
+scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
+ scm_t_int32 c, scm_t_int64 d)
+{
+ return d + c + b + a;
+}
+
+
+struct foo
+{
+ scm_t_int8 a;
+ scm_t_int16 b;
+ scm_t_int32 c;
+ scm_t_int64 d;
+};
+scm_t_int64 test_ffi_sum_struct (struct foo foo);
+scm_t_int64 test_ffi_sum_struct (struct foo foo)
+{
+ return foo.d + foo.c + foo.b + foo.a;
+}
+
+
+void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n);
+void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n)
+{
+ return memcpy (dest, src, n);
+}
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-7-29-g17d819d,
Andy Wingo <=