From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Nala Ginrut Newsgroups: gmane.lisp.guile.bugs Subject: bug#18592: FFI should have portable access to =?UTF-8?Q?=E2=80=98errno=E2=80=99?= Date: Tue, 05 Jan 2016 03:14:32 +0800 Organization: HFG Message-ID: <1451934872.3594.150.camel@Renee-desktop.suse> References: <87fvf8oocf.fsf@ft.bewatermyfriend.org> <87h9vmy0zw.fsf@gnu.org> <87twzgeh3c.fsf@yeeloong.lan> <87r3uko4c9.fsf@gnu.org> <1451565229.3594.59.camel@Renee-desktop.suse> <1451909046.3594.135.camel@Renee-desktop.suse> <8760z9gw7o.fsf@netris.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-wDd7srkmZIS3ETp3klHQ" X-Trace: ger.gmane.org 1451934927 32171 80.91.229.3 (4 Jan 2016 19:15:27 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 4 Jan 2016 19:15:27 +0000 (UTC) Cc: 18592@debbugs.gnu.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= , Chaos Eternal To: Mark H Weaver Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Mon Jan 04 20:15:14 2016 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1aGAb3-0007KB-NH for guile-bugs@m.gmane.org; Mon, 04 Jan 2016 20:15:14 +0100 Original-Received: from localhost ([::1]:46785 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGAb2-00065x-UU for guile-bugs@m.gmane.org; Mon, 04 Jan 2016 14:15:12 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:59358) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGAax-00065k-3I for bug-guile@gnu.org; Mon, 04 Jan 2016 14:15:09 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aGAas-0003mU-SX for bug-guile@gnu.org; Mon, 04 Jan 2016 14:15:06 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:49643) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGAas-0003mG-OQ for bug-guile@gnu.org; Mon, 04 Jan 2016 14:15:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84) (envelope-from ) id 1aGAas-0002QO-1c for bug-guile@gnu.org; Mon, 04 Jan 2016 14:15:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Nala Ginrut Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Mon, 04 Jan 2016 19:15:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 18592 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 18592-submit@debbugs.gnu.org id=B18592.14519348879282 (code B ref 18592); Mon, 04 Jan 2016 19:15:01 +0000 Original-Received: (at 18592) by debbugs.gnu.org; 4 Jan 2016 19:14:47 +0000 Original-Received: from localhost ([127.0.0.1]:37863 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGAac-0002Pe-JM for submit@debbugs.gnu.org; Mon, 04 Jan 2016 14:14:47 -0500 Original-Received: from mail-pa0-f66.google.com ([209.85.220.66]:34952) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGAaZ-0002PQ-Ub for 18592@debbugs.gnu.org; Mon, 04 Jan 2016 14:14:44 -0500 Original-Received: by mail-pa0-f66.google.com with SMTP id gi1so22820656pac.2 for <18592@debbugs.gnu.org>; Mon, 04 Jan 2016 11:14:43 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=message-id:subject:from:to:cc:date:in-reply-to:references :organization:content-type:mime-version; bh=2JDB1Rz54jdHPorhsi7p9FGmhpnB+zFkDs8sVVLMNNg=; b=jyQt2DsJVkdxJHRJj7SIAmUlFDmD+FT8vhjlZw5T040ZQlLWywWRR1DexzJjkn3NBP jeG1dnFIoXAGE9kGhAUqg/3OOcBuQyv9gtcEqfrH7BeUoWJvkmKTyzFWYrsvZgu39R1Z Vh4YQbZc1jMvIO9TMGhGw0wHNjvOS65ZgyO9KQhqRM0L2UzPAXTEXbrbtMvF63lJjlu2 T4/aov0FVs1tuDjRZZmSq7o022oMN4bM2CVUoFzSu5MvArmI4ash6ksWa+Mf3IzVw/Ka 9KF+9CtkkaWzRKgaZRWyV0fNrDw4AwFUFBfBtcDfWlWp1932llrQwnXucNO1czRw+no1 aSTw== X-Received: by 10.66.164.70 with SMTP id yo6mr128988005pab.36.1451934878221; Mon, 04 Jan 2016 11:14:38 -0800 (PST) Original-Received: from [127.0.0.1] (li88-185.members.linode.com. [74.207.246.185]) by smtp.gmail.com with ESMTPSA id v16sm68887855pfa.49.2016.01.04.11.14.34 (version=TLSv1/SSLv3 cipher=OTHER); Mon, 04 Jan 2016 11:14:37 -0800 (PST) In-Reply-To: <8760z9gw7o.fsf@netris.org> X-Mailer: Evolution 3.4.4 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.bugs:7923 Archived-At: --=-wDd7srkmZIS3ETp3klHQ Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: 7bit Hi Mark! Thanks for all the advices. Here's the new patch according to your advices. Include: 1. Added new procedure pointer->procedure-with-errno with #:return-errno? Question: Should we make #:return-errno? true in default? This would make the name *-with-errno more reasonable. At present, it's false in default. 2. Used scm_cons2 3. Store errno to a local var after ffi_call immediately. 4. Set errno=0 only when #:return-errno? is true. 5. Merged all modifications into one patch. Comments please. Best regards. --=-wDd7srkmZIS3ETp3klHQ Content-Disposition: attachment; filename*0=0001-Added-new-function-pointer-procedure-with-errno-to-r.pat; filename*1=ch Content-Type: text/x-patch; name="0001-Added-new-function-pointer-procedure-with-errno-to-r.patch"; charset="UTF-8" Content-Transfer-Encoding: 7bit >From 500b8b1f5079a56e3cd5c0a8386b3f880f396e01 Mon Sep 17 00:00:00 2001 From: Nala Ginrut Date: Tue, 5 Jan 2016 03:04:47 +0800 Subject: [PATCH] Added new function pointer->procedure-with-errno to return errno properly * doc/ref/api-foreign.texi (Dynamic FFI): Update documentation. * libguile/foreign.c (scm_pointer_to_procedure_with_errno): New API function to return errno properly after calling foreign function. (cif_to_procedure): Support return_errno option. * libguile/foreign.h (scm_pointer_to_procedure_with_errno): Add prototypes. * module/system/foreign.scm: Export pointer->procedure-with-errno. --- doc/ref/api-foreign.texi | 17 +++++ libguile/foreign.c | 168 +++++++++++++++++++++++++++++---------------- libguile/foreign.h | 8 ++- module/system/foreign.scm | 1 + 4 files changed, 132 insertions(+), 62 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index c2c49ec..a7e9fc1 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -827,6 +827,23 @@ and return appropriate values. more information on foreign types. @end deffn +@deffn {Scheme Procedure} pointer->procedure-with-errno return_type func_ptr arg_types @ + [#:return-errno?=#f] +@deffnx {C Procedure} scm_pointer_to_procedure_with_errno (return_type, func_ptr, @ + keyword_args) +Make a foreign function with errno. + +Given the foreign void pointer @var{func_ptr}, its argument and +return types @var{arg_types} and @var{return_type}, return a +procedure that will pass arguments to the foreign function +and return appropriate values. If @var{#:return-errno?} is true, then @code{errno} will be +returned as the second return value. + +@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. +@end deffn + Here is a better definition of @code{(math bessel)}: @example diff --git a/libguile/foreign.c b/libguile/foreign.c index 29cfc73..137c34d 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2010-2015 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 @@ -81,11 +81,11 @@ static void null_pointer_error (const char *func_name) { scm_error (sym_null_pointer_error, func_name, - "null pointer dereference", SCM_EOL, SCM_EOL); + "null pointer dereference", SCM_EOL, SCM_EOL); } -static SCM cif_to_procedure (SCM cif, SCM func_ptr); +static SCM cif_to_procedure (SCM cif, SCM func_ptr, SCM return_errno); static SCM pointer_weak_refs = SCM_BOOL_F; @@ -108,9 +108,9 @@ pointer_finalizer_trampoline (void *ptr, void *data) } SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a pointer object, " - "@code{#f} otherwise.\n") + (SCM obj), + "Return @code{#t} if @var{obj} is a pointer object, " + "@code{#f} otherwise.\n") #define FUNC_NAME s_scm_pointer_p { return scm_from_bool (SCM_POINTER_P (obj)); @@ -118,11 +118,11 @@ SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0, - (SCM address, SCM finalizer), - "Return a foreign pointer object pointing to @var{address}. " - "If @var{finalizer} is passed, it should be a pointer to a " - "one-argument C function that will be called when the pointer " - "object becomes unreachable.") + (SCM address, SCM finalizer), + "Return a foreign pointer object pointing to @var{address}. " + "If @var{finalizer} is passed, it should be a pointer to a " + "one-argument C function that will be called when the pointer " + "object becomes unreachable.") #define FUNC_NAME s_scm_make_pointer { void *c_finalizer; @@ -170,8 +170,8 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer) } SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, - (SCM pointer), - "Return the numerical value of @var{pointer}.") + (SCM pointer), + "Return the numerical value of @var{pointer}.") #define FUNC_NAME s_scm_pointer_address { SCM_VALIDATE_POINTER (1, pointer); @@ -181,9 +181,9 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0, - (SCM pointer), - "Unsafely cast @var{pointer} to a Scheme object.\n" - "Cross your fingers!") + (SCM pointer), + "Unsafely cast @var{pointer} to a Scheme object.\n" + "Cross your fingers!") #define FUNC_NAME s_scm_pointer_to_scm { SCM_VALIDATE_POINTER (1, pointer); @@ -193,8 +193,8 @@ SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, - (SCM scm), - "Return a foreign pointer object with the @code{object-address}\n" + (SCM scm), + "Return a foreign pointer object with the @code{object-address}\n" "of @var{scm}.") #define FUNC_NAME s_scm_scm_to_pointer { @@ -209,18 +209,18 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, - (SCM pointer, SCM len, SCM offset, SCM uvec_type), - "Return a bytevector aliasing the @var{len} bytes pointed\n" - "to by @var{pointer}.\n\n" + (SCM pointer, SCM len, SCM offset, SCM uvec_type), + "Return a bytevector aliasing the @var{len} bytes pointed\n" + "to by @var{pointer}.\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" - "When @var{offset} is passed, it specifies the offset in bytes\n" - "relative to @var{pointer} of the memory region aliased by the\n" - "returned bytevector.") + "When @var{offset} is passed, it specifies the offset in bytes\n" + "relative to @var{pointer} of the memory region aliased by the\n" + "returned bytevector.") #define FUNC_NAME s_scm_pointer_to_bytevector { SCM ret; @@ -273,17 +273,17 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, blen = scm_to_size_t (len); ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset, - blen, btype); + blen, btype); register_weak_reference (ret, pointer); return ret; } #undef FUNC_NAME SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0, - (SCM bv, SCM offset), - "Return a pointer pointer aliasing the memory pointed to by\n" + (SCM bv, SCM offset), + "Return a pointer pointer aliasing the memory pointed to by\n" "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n" - "is passed.") + "is passed.") #define FUNC_NAME s_scm_bytevector_to_pointer { SCM ret; @@ -337,9 +337,9 @@ scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) (heap allocation overhead, Scheme/C round trips, etc.) */ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, - (SCM pointer), - "Assuming @var{pointer} points to a memory region that\n" - "holds a pointer, return this pointer.") + (SCM pointer), + "Assuming @var{pointer} points to a memory region that\n" + "holds a pointer, return this pointer.") #define FUNC_NAME s_scm_dereference_pointer { void **ptr; @@ -355,9 +355,9 @@ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0, - (SCM string, SCM encoding), - "Return a foreign pointer to a nul-terminated copy of\n" - "@var{string} in the given @var{encoding}, defaulting to\n" + (SCM string, SCM encoding), + "Return a foreign pointer to a nul-terminated copy of\n" + "@var{string} in the given @var{encoding}, defaulting to\n" "the current locale encoding. The C string is freed when\n" "the returned foreign pointer becomes unreachable.\n\n" "This is the Scheme equivalent of @code{scm_to_stringn}.") @@ -394,14 +394,14 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0, #undef FUNC_NAME SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0, - (SCM pointer, SCM length, SCM encoding), - "Return the string representing the C string pointed to by\n" + (SCM pointer, SCM length, SCM encoding), + "Return the string representing the C string pointed to by\n" "@var{pointer}. If @var{length} is omitted or @code{-1}, the\n" "string is assumed to be nul-terminated. Otherwise\n" "@var{length} is the number of bytes in memory pointed to by\n" "@var{pointer}. The C string is assumed to be in the given\n" "@var{encoding}, defaulting to the current locale encoding.\n\n" - "This is the Scheme equivalent of @code{scm_from_stringn}.") + "This is the Scheme equivalent of @code{scm_from_stringn}.") #define FUNC_NAME s_scm_pointer_to_string { size_t len; @@ -482,19 +482,19 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), else if (scm_is_pair (type)) { /* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC, - and SPARC P.S. of the System V ABI all say: "Aggregates - (structures and arrays) and unions assume the alignment of - their most strictly aligned component." */ + and SPARC P.S. of the System V ABI all say: "Aggregates + (structures and arrays) and unions assume the alignment of + their most strictly aligned component." */ size_t max; for (max = 0; scm_is_pair (type); type = SCM_CDR (type)) - { - size_t align; + { + size_t align; - align = scm_to_size_t (scm_alignof (SCM_CAR (type))); - if (align > max) - max = align; - } + align = scm_to_size_t (scm_alignof (SCM_CAR (type))); + if (align > max) + max = align; + } return scm_from_size_t (max); } @@ -708,12 +708,12 @@ make_cif (SCM return_type, SCM arg_types, const char *caller) /* 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_type (void *)) - + (nargs + n_structs + n_struct_elts)*sizeof(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_type (ffi_type)) - + (nargs + n_struct_elts + 1)*sizeof(ffi_type)); + + (nargs + n_struct_elts + 1)*sizeof(ffi_type)); mem = scm_gc_malloc_pointerless (cif_len, "foreign"); /* ensure all the memory is initialized, even the holes */ @@ -724,8 +724,8 @@ make_cif (SCM return_type, SCM arg_types, const char *caller) cif_len = ROUND_UP (sizeof (ffi_cif), alignof_type (void *)); type_ptrs = (ffi_type**)(mem + cif_len); cif_len = ROUND_UP (cif_len - + (nargs + n_structs + n_struct_elts)*sizeof(void*), - alignof_type (ffi_type)); + + (nargs + n_structs + n_struct_elts)*sizeof(void*), + alignof_type (ffi_type)); types = (ffi_type*)(mem + cif_len); /* whew. now knit the pointers together. */ @@ -746,7 +746,7 @@ make_cif (SCM return_type, SCM arg_types, const char *caller) cif->flags = 0; if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype, - cif->arg_types)) + cif->arg_types)) SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL); return cif; @@ -770,7 +770,39 @@ 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, SCM_BOOL_F); +} +#undef FUNC_NAME + +SCM_KEYWORD (k_return_errno, "return-errno?"); + +SCM_DEFINE (scm_pointer_to_procedure_with_errno, + "pointer->procedure-with-errno", 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 @var{#:return-errno?} is true, then the @var{errno} will be\n" + "returned as the second value.") +#define FUNC_NAME s_scm_pointer_to_procedure_with_errno +{ + ffi_cif *cif; + SCM return_errno = SCM_BOOL_F; + + SCM_VALIDATE_POINTER (2, func_ptr); + + scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0, + k_return_errno, &return_errno, + SCM_UNDEFINED); + + cif = make_cif (return_type, arg_types, FUNC_NAME); + + return cif_to_procedure (scm_from_pointer (cif, NULL), + func_ptr, return_errno); } #undef FUNC_NAME @@ -940,16 +972,20 @@ get_objcode_trampoline (unsigned int nargs) } static SCM -cif_to_procedure (SCM cif, SCM func_ptr) +cif_to_procedure (SCM cif, SCM func_ptr, SCM return_errno) { ffi_cif *c_cif; SCM objcode, table, ret; + /* Convert 'return_errno' to a simple boolean, to avoid retaining + references to non-boolean objects. */ + return_errno = scm_from_bool (scm_is_true (return_errno)); + c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); objcode = get_objcode_trampoline (c_cif->nargs); table = scm_c_make_vector (2, SCM_UNDEFINED); - SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr)); + SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons2 (cif, func_ptr, return_errno)); SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */ ret = scm_make_program (objcode, table, SCM_BOOL_F); @@ -1116,9 +1152,12 @@ scm_i_foreign_call (SCM foreign, const SCM *argv) unsigned i; size_t arg_size; scm_t_ptrdiff off; + SCM return_errno; + int reterr; cif = SCM_POINTER_VALUE (SCM_CAR (foreign)); - func = SCM_POINTER_VALUE (SCM_CDR (foreign)); + func = SCM_POINTER_VALUE (SCM_CADR (foreign)); + return_errno = SCM_CDDR (foreign); /* Argument pointers. */ args = alloca (sizeof (void *) * cif->nargs); @@ -1153,10 +1192,21 @@ scm_i_foreign_call (SCM foreign, const SCM *argv) rvalue = (void *) ROUND_UP ((scm_t_uintptr) data + off, max (sizeof (void *), cif->rtype->alignment)); - /* off we go! */ - ffi_call (cif, func, rvalue, args); - - return pack (cif->rtype, rvalue, 1); + if (scm_is_true (return_errno)) + { + errno = 0; + /* off we go! */ + ffi_call (cif, func, rvalue, args); + reterr = errno; + return scm_values (scm_list_2 (pack (cif->rtype, rvalue, 1), + scm_from_int (reterr))); + } + else + { + /* off we go! */ + ffi_call (cif, func, rvalue, args); + return pack (cif->rtype, rvalue, 1); + } } diff --git a/libguile/foreign.h b/libguile/foreign.h index 41c0b65..060bd24 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 Free Software Foundation, Inc. +/* Copyright (C) 2010, 2011, 2012, 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 @@ -93,9 +93,11 @@ SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer, SCM length, SCM encoding); */ SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr, - SCM arg_types); + SCM arg_types); +SCM_API SCM scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr, + SCM arg_types, SCM keyword_args); SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr, - SCM arg_types); + SCM arg_types); SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv); diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 55ab014..4436f1f 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -50,6 +50,7 @@ pointer->string pointer->procedure + pointer->procedure-with-errno ;; procedure->pointer (see below) make-c-struct parse-c-struct -- 1.7.10.4 --=-wDd7srkmZIS3ETp3klHQ--