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

[Nala Ginrut <nalaginrut@gmail.com>]

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

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.


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

From 500b8b1f5079a56e3cd5c0a8386b3f880f396e01 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.

  (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);
 }
 
 \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,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);
+    }
 }
 
 \f
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);
 
 \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