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: Wed, 06 Jan 2016 03:21:41 +0800 Organization: HFG Message-ID: <1452021701.3594.160.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> <1451934872.3594.150.camel@Renee-desktop.suse> <20160105074924.GA23165@tuxteam.de> <1451983123.3594.156.camel@Renee-desktop.suse> <87vb78jc86.fsf@netris.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-ZasfTEdCEpgU4VH3gLZA" X-Trace: ger.gmane.org 1452021747 22514 80.91.229.3 (5 Jan 2016 19:22:27 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 5 Jan 2016 19:22:27 +0000 (UTC) Cc: 18592@debbugs.gnu.org To: Mark H Weaver Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Tue Jan 05 20:22:17 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 1aGXBQ-0006p6-J9 for guile-bugs@m.gmane.org; Tue, 05 Jan 2016 20:22:16 +0100 Original-Received: from localhost ([::1]:51130 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGXBQ-0008Dg-13 for guile-bugs@m.gmane.org; Tue, 05 Jan 2016 14:22:16 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:50687) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGXBG-00085c-4l for bug-guile@gnu.org; Tue, 05 Jan 2016 14:22:11 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aGXBC-0005yz-2T for bug-guile@gnu.org; Tue, 05 Jan 2016 14:22:06 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:50918) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aGXBB-0005yv-V7 for bug-guile@gnu.org; Tue, 05 Jan 2016 14:22:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84) (envelope-from ) id 1aGXBB-0008DM-Ry for bug-guile@gnu.org; Tue, 05 Jan 2016 14:22:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Nala Ginrut Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Tue, 05 Jan 2016 19:22: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.145202171431563 (code B ref 18592); Tue, 05 Jan 2016 19:22:01 +0000 Original-Received: (at 18592) by debbugs.gnu.org; 5 Jan 2016 19:21:54 +0000 Original-Received: from localhost ([127.0.0.1]:39138 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGXB3-0008D1-C4 for submit@debbugs.gnu.org; Tue, 05 Jan 2016 14:21:54 -0500 Original-Received: from mail-pf0-f175.google.com ([209.85.192.175]:35023) by debbugs.gnu.org with esmtp (Exim 4.84) (envelope-from ) id 1aGXB2-0008Cm-3i for 18592@debbugs.gnu.org; Tue, 05 Jan 2016 14:21:52 -0500 Original-Received: by mail-pf0-f175.google.com with SMTP id 78so227490868pfw.2 for <18592@debbugs.gnu.org>; Tue, 05 Jan 2016 11:21:52 -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=BkP7Rk24HNHtzoSVC279qa2UqStTi5IDwWEOB7v9A+M=; b=S5cCBOKW/u7ZGT7uMUYVjUUiQWThqEH/b568eAnpxxeXz85dvQs1VZyxU/4gTNzGN8 uynvoC1zVEf0FztnCgw3EDRYknahHAEQf+XS7QwL2I5T9jQwaSkMYw02niuSTBM5KN9I iOesO1ERAH8y14QrTRsTnVRsK25Dqu1lAxyKUrCIpsVa0Vi/bgRzlHYNTdDZ70JfRHvM t0YMuMW6e+X8+pLXQzo8QC3iKTNdDeeD6fZd1LPKSuSiQV0w37y0DNeJrQPj/pxIHEBf vK4uNA+hZvqxu3IfEHleGzZkOBt4Ys/AlVRsR2ukmOZKVwGudGG1Zo3JfvD9bx8THbV7 H1hA== X-Received: by 10.98.76.72 with SMTP id z69mr136016823pfa.35.1452021706455; Tue, 05 Jan 2016 11:21:46 -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 ix2sm135244628pac.15.2016.01.05.11.21.43 (version=TLSv1/SSLv3 cipher=OTHER); Tue, 05 Jan 2016 11:21:45 -0800 (PST) In-Reply-To: <87vb78jc86.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:7929 Archived-At: --=-ZasfTEdCEpgU4VH3gLZA Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: 7bit Here's updated patch Thanks! On Tue, 2016-01-05 at 10:08 -0500, Mark H Weaver wrote: > More specifically, here's what I'd suggest: > > * A new, static, 'pointer_to_procedure' C function that inherits the > signature and body of 'scm_pointer_to_procedure' but with a new and > required 'return_errno' argument. The other functions below would be > wrappers for this function. > > * A new private 'scm_i_pointer_to_procedure_with_keywords' C function, > defined using SCM_DEFINE and bound to 'pointer->procedure' in Scheme, > that uses 'scm_c_bind_keyword_arguments' and calls > 'pointer_to_procedure'. > > * The C API function 'scm_pointer_to_procedure', which has the same > arguments as in Guile 2.0.11 and calls 'pointer_to_procedure' with > 'return_errno' set to SCM_BOOL_F. > > * A new C API function 'scm_pointer_to_procedure_with_errno', which is > identical to 'scm_pointer_to_procedure' except that it calls > 'pointer_to_procedure' with 'return_errno' set to SCM_BOOL_T. > > The only change to foreign.h would be to add a prototype for > 'scm_pointer_to_procedure_with_errno'. > > What do you think? > > Regards, > Mark --=-ZasfTEdCEpgU4VH3gLZA 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 faa6371c3251a488e4245bf4835529009a1a7b88 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. (pointer_to_procedure): New internal function to 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 | 23 +++++- libguile/foreign.c | 199 +++++++++++++++++++++++++++++++-------------- libguile/foreign.h | 8 +- module/system/foreign.scm | 1 + 4 files changed, 165 insertions(+), 66 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index c2c49ec..52184e2 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -813,14 +813,31 @@ 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 Procedure} scm_pointer_to_procedure (return_type, func_ptr, arg_types, keyword_args) Make a foreign function. 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. +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 + +@deffn {Scheme Procedure} pointer->procedure-with-errno return_type func_ptr arg_types +@deffnx {C Procedure} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types) +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. The @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 diff --git a/libguile/foreign.c b/libguile/foreign.c index 29cfc73..b0fd2dd 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,14 +746,21 @@ 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; } #undef FUNC_NAME -SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, +static SCM pointer_to_procedure (ffi_cif *cif, SCM func_ptr, SCM return_errno); +static SCM pointer_to_procedure (ffi_cif *cif, SCM func_ptr, SCM return_errno) +{ + return cif_to_procedure (scm_from_pointer (cif, NULL), + func_ptr, return_errno); +} + +SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure0", 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" @@ -770,7 +777,61 @@ 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 pointer_to_procedure (cif, func_ptr, SCM_BOOL_F); +} +#undef FUNC_NAME + +SCM_KEYWORD (k_return_errno, "return-errno?"); + +SCM_DEFINE (scm_i_pointer_to_procedure_with_keywords, + "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 @var{#:return-errno?} is true, then the @var{errno} will be\n" + "returned as the second value.") +#define FUNC_NAME s_scm_i_pointer_to_procedure_with_keywords +{ + 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 pointer_to_procedure (cif, func_ptr, return_errno); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_pointer_to_procedure_with_errno, + "pointer->procedure-with-errno", 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" + "The errno will be the second value\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_with_errno +{ + ffi_cif *cif; + + SCM_VALIDATE_POINTER (2, func_ptr); + + cif = make_cif (return_type, arg_types, FUNC_NAME); + + return pointer_to_procedure (cif, func_ptr, SCM_BOOL_T); } #undef FUNC_NAME @@ -940,16 +1001,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 +1181,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 +1221,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..561b9f8 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_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 --=-ZasfTEdCEpgU4VH3gLZA--