bug#18592: FFI should have portable access to ‘errno’

[Nala Ginrut <nalaginrut@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1174 bytes --]

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


[-- Attachment #2: 0001-Added-new-function-pointer-procedure-with-errno-to-r.patch --]
[-- Type: text/x-patch, Size: 19848 bytes --]

From faa6371c3251a488e4245bf4835529009a1a7b88 Mon Sep 17 00:00:00 2001
From: Nala Ginrut <nalaginrut@gmail.com>
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);
 }
 
 \f
-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);
+    }
 }
 
 \f
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);
 
 \f
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