diff options
-rw-r--r-- | doc/ref/api-foreign.texi | 15 | ||||
-rw-r--r-- | libguile/foreign.c | 114 | ||||
-rw-r--r-- | libguile/foreign.h | 7 | ||||
-rw-r--r-- | libguile/vm-engine.c | 29 |
4 files changed, 97 insertions, 68 deletions
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 76614f021..527902209 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, -@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Foreign Function Interface @@ -813,8 +813,11 @@ tightly packed structs and unions by hand. See the code for Of course, the land of C is not all nouns and no verbs: there are functions too, and Guile allows you to call them. -@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types -@deffnx {C Procedure} scm_pointer_to_procedure (return_type, func_ptr, arg_types) +@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types @ + [#:return-errno?=#f] +@deffnx {C Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types) +@deffnx {C Function} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types) + Make a foreign function. Given the foreign void pointer @var{func_ptr}, its argument and @@ -825,6 +828,10 @@ and return appropriate values. @var{arg_types} should be a list of foreign types. @code{return_type} should be a foreign type. @xref{Foreign Types}, for more information on foreign types. + +If @var{return-errno?} is true, or when calling +@code{scm_pointer_to_procedure_with_errno}, the returned procedure will +return two values, with @code{errno} as the second value. @end deffn Here is a better definition of @code{(math bessel)}: 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); } diff --git a/libguile/foreign.h b/libguile/foreign.h index 4c1a19f1f..a0c09cc0f 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -1,7 +1,7 @@ #ifndef SCM_FOREIGN_H #define SCM_FOREIGN_H -/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2010, 2011, 2012, 2013, 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 @@ -97,9 +97,12 @@ union scm_vm_stack_element; SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types); +SCM_API SCM scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr, + SCM arg_types); SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr, SCM arg_types); -SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, +SCM_INTERNAL SCM scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, + int *errno_ret, const union scm_vm_stack_element *argv); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 44068458e..195237ab4 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -791,6 +791,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (X8_C12_C12)) { scm_t_uint16 cif_idx, ptr_idx; + int err = 0; SCM closure, cif, pointer, ret; UNPACK_12_12 (op, cif_idx, ptr_idx); @@ -800,30 +801,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx); SYNC_IP (); - - // FIXME: separate args - ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), sp); - + ret = scm_i_foreign_call (cif, pointer, &err, sp); CACHE_SP (); - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - SCM vals = scm_struct_ref (ret, SCM_INUM0); - long len = scm_ilength (vals); - ALLOC_FRAME (1 + len); - while (len--) - { - SP_SET (len, SCM_CAR (vals)); - vals = SCM_CDR (vals); - } - NEXT (1); - } - else - { - ALLOC_FRAME (2); - SP_SET (0, ret); - NEXT (1); - } + ALLOC_FRAME (3); + SP_SET (1, ret); + SP_SET (0, scm_from_int (err)); + + NEXT (1); } /* continuation-call contregs:24 |