[Guile-commits] 05/05: FFI: Add support for functions that set 'errno'.

[Mark H. Weaver]

mhw pushed a commit to branch stable-2.0
in repository guile.

commit ee3381c94d389d923591dcb610bac9ecfd68e6a4
Author: Mark H Weaver <address@hidden>
Date:   Tue Jan 5 16:30:41 2016 -0500

    FFI: Add support for functions that set 'errno'.
    
    Implements wishlist item <https://debbugs.gnu.org/18592>.
    Requested by Frank Terbeck <address@hidden>.
    Based on a proposed patch by Nala Ginrut <address@hidden>.
    
    * libguile/foreign.c (cif_to_procedure): Add 'return_errno' argument.
      Store its boolean value in the object table of the generated program.
      (scm_i_foreign_call): If the stored 'return_errno' flag is true, then
      clear 'errno' before the call, save it after the call, and return it
      as a second return value.
      (pointer_to_procedure): New static function.
      (scm_pointer_to_procedure_with_errno): New C API function, implemented
      in terms of 'pointer_to_procedure'.
      (scm_pointer_to_procedure): Reimplement in terms of
      'pointer_to_procedure', no longer bound to "pointer->procedure".  See
      below.
      (scm_i_pointer_to_procedure): New C function bound to
      "pointer->procedure" which now accepts the optional #:return-errno?
      keyword argument, implemented in terms of 'pointer_to_procedure'.
      (k_return_errno): New keyword #:return-errno?.
    * libguile/foreign.h (scm_pointer_to_procedure_with_errno): Add prototype.
    * doc/ref/api-foreign.texi (Dynamic FFI): Adjust documentation.
---
 doc/ref/api-foreign.texi |   15 +++++---
 libguile/foreign.c       |   89 ++++++++++++++++++++++++++++++++++++----------
 libguile/foreign.h       |    4 ++-
 3 files changed, 85 insertions(+), 23 deletions(-)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index c2c49ec..25eaabf 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 
2008,
address@hidden   2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, 
Inc.
address@hidden Copyright (C)  1996, 1997, 2000-2004, 2007-2014, 2016
address@hidden   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Foreign Function Interface
@@ -813,8 +813,11 @@ 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.
 
address@hidden {Scheme Procedure} pointer->procedure return_type func_ptr 
arg_types
address@hidden {C Procedure} scm_pointer_to_procedure (return_type, func_ptr, 
arg_types)
address@hidden {Scheme Procedure} pointer->procedure return_type func_ptr 
arg_types @
+                                             [#:return-errno?=#f]
address@hidden {C Function} scm_pointer_to_procedure (return_type, func_ptr, 
arg_types)
address@hidden {C Function} scm_pointer_to_procedure_with_errno (return_type, 
func_ptr, arg_types)
+
 Make a foreign function.
 
 Given the foreign void pointer @var{func_ptr}, its argument and
@@ -825,6 +828,10 @@ and return appropriate values.
 @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.
+
+If @var{return-errno?} is true, or when calling
address@hidden, the returned procedure will
+return two values, with @code{errno} as the second value.
 @end deffn
 
 Here is a better definition of @code{(math bessel)}:
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 29cfc73..f770100 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
@@ -26,6 +26,7 @@
 #include <alignof.h>
 #include <string.h>
 #include <assert.h>
+#include <errno.h>
 
 #include "libguile/_scm.h"
 #include "libguile/bytevectors.h"
@@ -85,7 +86,7 @@ null_pointer_error (const char *func_name)
 }
 
 
-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;
@@ -753,24 +754,58 @@ make_cif (SCM return_type, SCM arg_types, const char 
*caller)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
-            (SCM return_type, SCM func_ptr, SCM arg_types),
+static SCM
+pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types,
+                      SCM return_errno)
+#define FUNC_NAME "pointer->procedure"
+{
+  ffi_cif *cif;
+
+  SCM_VALIDATE_POINTER (2, func_ptr);
+
+  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
+
+SCM
+scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types)
+{
+  return pointer_to_procedure (return_type, func_ptr, arg_types, SCM_BOOL_F);
+}
+
+SCM
+scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr,
+                                     SCM arg_types)
+{
+  return pointer_to_procedure (return_type, func_ptr, arg_types, SCM_BOOL_T);
+}
+
+SCM_KEYWORD (k_return_errno, "return-errno?");
+
+SCM_DEFINE (scm_i_pointer_to_procedure, "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.")
-#define FUNC_NAME s_scm_pointer_to_procedure
+            "@code{return_type} should be a foreign type.\n"
+            "If the @code{#:return-errno?} keyword argument is provided and\n"
+            "its value is true, then the returned procedure will return two\n"
+            "values, with @code{errno} as the second value.")
+#define FUNC_NAME "pointer->procedure"
 {
-  ffi_cif *cif;
+  SCM return_errno = SCM_BOOL_F;
 
-  SCM_VALIDATE_POINTER (2, func_ptr);
-
-  cif = make_cif (return_type, arg_types, FUNC_NAME);
+  scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
+                                k_return_errno, &return_errno,
+                                SCM_UNDEFINED);
 
-  return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr);
+  return pointer_to_procedure (return_type, func_ptr, arg_types, return_errno);
 }
 #undef FUNC_NAME
 
@@ -940,16 +975,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;
 
   c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
   objcode = get_objcode_trampoline (c_cif->nargs);
-  
+
+  /* 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));
+
   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 +1155,11 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
   unsigned i;
   size_t arg_size;
   scm_t_ptrdiff off;
+  SCM return_errno;
 
   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 +1194,22 @@ 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);
+  if (scm_is_true (return_errno))
+    {
+      int errno_save;
+
+      errno = 0;
+      ffi_call (cif, func, rvalue, args);
+      errno_save = errno;
 
-  return pack (cif->rtype, rvalue, 1);
+      return scm_values (scm_list_2 (pack (cif->rtype, rvalue, 1),
+                                     scm_from_int (errno_save)));
+    }
+  else
+    {
+      ffi_call (cif, func, rvalue, args);
+      return pack (cif->rtype, rvalue, 1);
+    }
 }
 
 
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 41c0b65..f8a176b 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
@@ -94,6 +94,8 @@ 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_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_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);