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

[Nala Ginrut <nalaginrut@gmail.com>]

Is there still problem? I'm fine with the patch, and I'm expecting to
merge it ASAP. Anyway, please don't hesitate to tell me if there's still
any problem, I'm glad to help to do it better. I really need it.

Thanks! 

On Fri, 2016-02-19 at 13:02 +0800, Nala Ginrut wrote:
> 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);
>