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

[Nala Ginrut <nalaginrut@gmail.com>]

I think it's OK to try this:
(pointer->procedure int (dynamic-func "epoll_create" (dynamic-link)) '()
#:return-errno? #t)

And I'm fine with the patch, could you push it please?

Thank you very much!

On Thu, 2016-02-18 at 08:30 -0500, Mark H Weaver wrote:
> Nala Ginrut <nalaginrut@gmail.com> writes:
> > Is there still any problem with the previous patch?
> 
> Yes.  I'm sorry, but we were failing to communicate and I did not have
> time to continue trying, so instead I made my own patch, attached below.
> 
> Can you try this patch, and tell me if it does what you need?
> 
>      Thanks,
>        Mark
> 
> 
> differences between files attachment
> (0001-PRELIMINARY-Add-support-for-errno-to-Dynamic-FFI.patch),
> "[PATCH] PRELIMINARY: Add support for errno to Dynamic FFI"
> From 17a3ee8c255e06ea7ee805401c94853fb48cbf12 Mon Sep 17 00:00:00 2001
> From: Mark H Weaver <mhw@netris.org>
> Date: Tue, 5 Jan 2016 16:30:41 -0500
> Subject: [PATCH] PRELIMINARY: Add support for errno to Dynamic FFI.
> 
> ---
>  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.
> -@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008,
> -@c   2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
> +@c Copyright (C)  1996, 1997, 2000-2004, 2007-2014, 2016
> +@c   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.
>  
> -@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 Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types)
> +@deffnx {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
> +@code{scm_pointer_to_procedure_with_errno}, 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)
>  }
>  
>  \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;
> @@ -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);
> +    }
>  }
>  
>  \f
> 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);