summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r--libguile/foreign.c114
1 files changed, 74 insertions, 40 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 17a3eedb5..17af10180 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2010-2013 Free Software Foundation, Inc.
+/* Copyright (C) 2010-2016 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
@@ -26,6 +26,7 @@
#include <alignof.h>
#include <string.h>
#include <assert.h>
+#include <errno.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
@@ -75,7 +76,7 @@ null_pointer_error (const char *func_name)
}
-static SCM cif_to_procedure (SCM cif, SCM func_ptr);
+static SCM cif_to_procedure (SCM cif, SCM func_ptr, int with_errno);
static SCM pointer_weak_refs = SCM_BOOL_F;
@@ -740,16 +741,10 @@ make_cif (SCM return_type, SCM arg_types, const char *caller)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
- (SCM return_type, SCM func_ptr, SCM arg_types),
- "Make a foreign function.\n\n"
- "Given the foreign void pointer @var{func_ptr}, its argument and\n"
- "return types @var{arg_types} and @var{return_type}, return a\n"
- "procedure that will pass arguments to the foreign function\n"
- "and return appropriate values.\n\n"
- "@var{arg_types} should be a list of foreign types.\n"
- "@code{return_type} should be a foreign type.")
-#define FUNC_NAME s_scm_pointer_to_procedure
+static SCM
+pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types,
+ int with_errno)
+#define FUNC_NAME "pointer->procedure"
{
ffi_cif *cif;
@@ -757,45 +752,81 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
cif = make_cif (return_type, arg_types, FUNC_NAME);
- return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr);
+ return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr,
+ with_errno);
}
#undef FUNC_NAME
-
+SCM
+scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types)
+{
+ return pointer_to_procedure (return_type, func_ptr, arg_types, 0);
+}
-/* We support calling foreign functions with up to 100 arguments. */
+SCM
+scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr,
+ SCM arg_types)
+{
+ return pointer_to_procedure (return_type, func_ptr, arg_types, 1);
+}
-#define CODE(nreq) \
- SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
- SCM_PACK_OP_12_12 (foreign_call, 0, 1), \
- SCM_PACK_OP_24 (handle_interrupts, 0), \
- SCM_PACK_OP_24 (return_values, 0)
+SCM_KEYWORD (k_return_errno, "return-errno?");
-#define CODE_10(n) \
- CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \
- CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9)
+SCM_INTERNAL SCM scm_i_pointer_to_procedure (SCM, SCM, SCM, SCM);
+SCM_DEFINE (scm_i_pointer_to_procedure, "pointer->procedure", 3, 0, 1,
+ (SCM return_type, SCM func_ptr, SCM arg_types, SCM keyword_args),
+ "Make a foreign function.\n\n"
+ "Given the foreign void pointer @var{func_ptr}, its argument and\n"
+ "return types @var{arg_types} and @var{return_type}, return a\n"
+ "procedure that will pass arguments to the foreign function\n"
+ "and return appropriate values.\n\n"
+ "@var{arg_types} should be a list of foreign types.\n"
+ "@code{return_type} should be a foreign type.\n"
+ "If the @code{#:return-errno?} keyword argument is provided and\n"
+ "its value is true, then the returned procedure will return two\n"
+ "values, with @code{errno} as the second value.")
+#define FUNC_NAME s_scm_i_pointer_to_procedure
+{
+ SCM return_errno = SCM_BOOL_F;
+
+ scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
+ k_return_errno, &return_errno,
+ SCM_UNDEFINED);
-static const scm_t_uint32 foreign_stub_code[] =
- {
- CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40),
- CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90)
- };
+ return pointer_to_procedure (return_type, func_ptr, arg_types,
+ scm_to_bool (return_errno));
+}
+#undef FUNC_NAME
-#undef CODE
-#undef CODE_10
+
static const scm_t_uint32 *
-get_foreign_stub_code (unsigned int nargs)
+get_foreign_stub_code (unsigned int nargs, int with_errno)
{
- if (nargs >= 100)
- scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
- SCM_EOL);
+ size_t i;
+ size_t code_len = with_errno ? 4 : 5;
+ scm_t_uint32 *code;
+
+ code = scm_gc_malloc_pointerless (code_len * sizeof (scm_t_uint32),
+ "foreign code");
+
+ if (nargs >= (1 << 24) + 1)
+ scm_misc_error ("make-foreign-function", "too many arguments: ~a",
+ scm_list_1 (scm_from_uint (nargs)));
+
+ i = 0;
+ code[i++] = SCM_PACK_OP_24 (assert_nargs_ee, nargs + 1);
+ code[i++] = SCM_PACK_OP_12_12 (foreign_call, 0, 1);
+ code[i++] = SCM_PACK_OP_24 (handle_interrupts, 0);
+ if (!with_errno)
+ code[i++] = SCM_PACK_OP_24 (reset_frame, 2);
+ code[i++] = SCM_PACK_OP_24 (return_values, 0);
- return &foreign_stub_code[nargs * 4];
+ return code;
}
static SCM
-cif_to_procedure (SCM cif, SCM func_ptr)
+cif_to_procedure (SCM cif, SCM func_ptr, int with_errno)
{
ffi_cif *c_cif;
SCM ret;
@@ -805,7 +836,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs));
+ SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
@@ -960,7 +991,8 @@ pack (const ffi_type * type, const void *loc, int return_value_p)
SCM
-scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
+scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret,
+ const union scm_vm_stack_element *argv)
{
/* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
objtable. */
@@ -973,8 +1005,8 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
size_t arg_size;
scm_t_ptrdiff off;
- cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
- func = SCM_POINTER_VALUE (SCM_CDR (foreign));
+ cif = SCM_POINTER_VALUE (cif_scm);
+ func = SCM_POINTER_VALUE (pointer_scm);
/* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs);
@@ -1010,7 +1042,9 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
max (sizeof (void *), cif->rtype->alignment));
/* off we go! */
+ errno = 0;
ffi_call (cif, func, rvalue, args);
+ *errno_ret = errno;
return pack (cif->rtype, rvalue, 1);
}