>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 address@hidden {Scheme Procedure} pointer->procedure-with-errno return_type func_ptr arg_types @ + [#:return-errno?=#f] address@hidden {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. + address@hidden should be a list of foreign types. address@hidden should be a foreign type. @xref{Foreign Types}, for +more information on foreign types. address@hidden 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