FFI: big improvement in bad call diagnosis.

FFI has the problem that when things go wrong in calls, or in
specifications of functions, the diagnostics refer to an
internal function like ffi-call or ffi-make-call-desc, which
is not helpful in identifying the error. We want the
diagnostics to refer to the foreign function, or foreignb
callback wrapper, to which the problem pertains.

The approach taken is to stick the name symbol into the
ffi-call-desc object. Functions which work with a
ffi-call-desc can pull out the name and use it for reporting.

* ffi.c (struct txr_ffi_call_desc): Add name member.
(ffi_call_desc_print_op): Include name in printed
representation.
(ffi_desc_mark_op): Mark the name.
(ffi_make_call_desc): Take new argument to specify the name,
storing it into the structure.  If it is specified,then use
that name for reporting errors, otherwise stick with
ffi-make-call-desc.
(ffi_call_wrap, ffi_closure_dispatch,
ffi_closure_dispatch_safe, ffi_make_closure): Use the name
from the call descriptor, or else the function's own name if
that is nil.
(ffi_init): Update registration of ffi-make-call-desc
intrinsic to five arguments with four required.

* ffi.h (ffi_make_call_desc): Declaration updated.

* share/txr/stdlib/ffi.tl (deffi, deffi-cb-expander): Pass the
name symbol down to ffi-make-call-desc.

* txr.1: Documented.

4 files changed, 34 insertions, 14 deletions

diff --git a/ffi.c b/ffi.c
index 31956a8c..d943f883 100644
--- a/ffi.c
+++ b/ffi.c
@@ -4653,6 +4653,7 @@ struct txr_ffi_call_desc {
   cnum nfixed, ntotal;
   val argtypes;
   val rettype;
+  val name;
 };
 
 static struct txr_ffi_call_desc *ffi_call_desc(val obj)
@@ -4672,7 +4673,8 @@ static void ffi_call_desc_print_op(val obj, val out,
   struct txr_ffi_call_desc *tfcd = ffi_call_desc(obj);
   put_string(lit("#<"), out);
   obj_print_impl(obj->co.cls, out, pretty, ctx);
-  format(out, lit(" ~s ~!~s>"), tfcd->rettype, tfcd->argtypes, nao);
+  format(out, lit("~s ~s ~!~s>"), tfcd->name, tfcd->rettype,
+         tfcd->argtypes, nao);
 }
 
 static void ffi_call_desc_destroy_op(val obj)
@@ -4688,6 +4690,7 @@ static void ffi_call_desc_mark_op(val obj)
   struct txr_ffi_call_desc *tfcd = ffi_call_desc(obj);
   gc_mark(tfcd->argtypes);
   gc_mark(tfcd->rettype);
+  gc_mark(tfcd->name);
 }
 
 static struct cobj_ops ffi_call_desc_ops =
@@ -4697,9 +4700,11 @@ static struct cobj_ops ffi_call_desc_ops =
                 ffi_call_desc_mark_op,
                 cobj_eq_hash_op);
 
-val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
+val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes,
+                       val name_in)
 {
-  val self = lit("ffi-make-call-desc");
+  val name = default_null_arg(name_in);
+  val self = if3(name, name, lit("ffi-make-call-desc"));
   cnum nf = c_num(default_arg(nfixed, zero), self);
   cnum nt = c_num(ntotal, self), i;
   struct txr_ffi_call_desc *tfcd = coerce(struct txr_ffi_call_desc *,
@@ -4714,6 +4719,7 @@ val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
   tfcd->argtypes = argtypes;
   tfcd->rettype = rettype;
   tfcd->args = args;
+  tfcd->name = name;
 
   for (i = 0; i < nt; i++) {
     val type = pop(&argtypes);
@@ -4753,8 +4759,9 @@ val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
 
 val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
 {
-  val self = lit("ffi-call");
-  struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(self, ffi_call_desc);
+  val real_self = lit("ffi-call");
+  struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(real_self, ffi_call_desc);
+  val self = if3(tfcd->name, tfcd->name, real_self);
   mem_t *fp = cptr_get(fptr);
   cnum n = tfcd->ntotal;
   void **values = convert(void **, alloca(sizeof *values * tfcd->ntotal));
@@ -4833,11 +4840,11 @@ val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
 static void ffi_closure_dispatch(ffi_cif *cif, void *cret,
                                  void *cargs[], void *clo)
 {
-  val self = lit("ffi-closure-dispatch");
   val closure = coerce(val, clo);
   struct txr_ffi_closure *tfcl = ffi_closure_struct(closure);
   cnum i, nargs = tfcl->nparam;
   struct txr_ffi_call_desc *tfcd = tfcl->tfcd;
+  val self = if3(tfcd->name, tfcd->name, lit("ffi-closure-dispatch"));
   val types = tfcd->argtypes;
   val rtype = tfcd->rettype;
   struct txr_ffi_type *rtft = ffi_type_struct(rtype);
@@ -4877,11 +4884,11 @@ static void ffi_closure_dispatch(ffi_cif *cif, void *cret,
 static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
                                       void *cargs[], void *clo)
 {
-  val self = lit("ffi-closure-dispatch-safe");
   val closure = coerce(val, clo);
   struct txr_ffi_closure *tfcl = ffi_closure_struct(closure);
   cnum i, nargs = tfcl->nparam;
   struct txr_ffi_call_desc *tfcd = tfcl->tfcd;
+  val self = if3(tfcd->name, tfcd->name, lit("ffi-closure-dispatch-safe"));
   val types = tfcd->argtypes;
   val rtype = tfcd->rettype;
   struct txr_ffi_type *rtft = ffi_type_struct(rtype);
@@ -4953,10 +4960,11 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
 
 val ffi_make_closure(val fun, val call_desc, val safe_p_in, val abort_ret_in)
 {
-  val self = lit("ffi-make-closure");
+  val real_self = lit("ffi-make-closure");
   struct txr_ffi_closure *tfcl = coerce(struct txr_ffi_closure *,
                                         chk_calloc(1, sizeof *tfcl));
-  struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(self, call_desc);
+  struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(real_self, call_desc);
+  val self = if3(tfcd->name, tfcd->name, real_self);
   val obj = cobj(coerce(mem_t *, tfcl), ffi_closure_s, &ffi_closure_ops);
   val safe_p = default_arg_strict(safe_p_in, t);
   ffi_status ffis = FFI_OK;
@@ -6328,7 +6336,7 @@ void ffi_init(void)
   reg_fun(intern(lit("ffi-type-operator-p"), user_package), func_n1(ffi_type_operator_p));
   reg_fun(intern(lit("ffi-type-p"), user_package), func_n1(ffi_type_p));
 #if HAVE_LIBFFI
-  reg_fun(intern(lit("ffi-make-call-desc"), user_package), func_n4(ffi_make_call_desc));
+  reg_fun(intern(lit("ffi-make-call-desc"), user_package), func_n5o(ffi_make_call_desc, 4));
   reg_fun(intern(lit("ffi-call"), user_package), func_n2v(ffi_call_wrap));
   reg_fun(intern(lit("ffi-make-closure"), user_package), func_n4o(ffi_make_closure, 2));
 #endif
diff --git a/ffi.h b/ffi.h
index c420f370..7668d968 100644
--- a/ffi.h
+++ b/ffi.h
@@ -74,7 +74,8 @@ extern val ffi_type_s, ffi_call_desc_s, ffi_closure_s;
 val ffi_type_compile(val syntax);
 val ffi_type_operator_p(val sym);
 val ffi_type_p(val sym);
-val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes);
+val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes,
+                       val name);
 val ffi_make_closure(val fun, val call_desc, val safe_p_in, val abort_ret_in);
 mem_t *ffi_closure_get_fptr(val self, val closure);
 val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args);
diff --git a/share/txr/stdlib/ffi.tl b/share/txr/stdlib/ffi.tl
index 480faf5d..58729ceb 100644
--- a/share/txr/stdlib/ffi.tl
+++ b/share/txr/stdlib/ffi.tl
@@ -81,7 +81,8 @@
            (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes])
            (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic
                                                        ,ret-type-sym
-                                                       ,arg-types-sym))
+                                                       ,arg-types-sym
+                                                       ',name))
            (defvarl ,fun-sym ,fun-ref)
            (defun ,name ,arg-syms
              (ffi-call ,fun-sym ,call-desc-sym ,*arg-syms)))))))
@@ -103,7 +104,8 @@
          (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes])
          (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic
                                                      ,ret-type-sym
-                                                     ,arg-types-sym))
+                                                     ,arg-types-sym
+                                                     ',name))
          (defun ,name (,fun-sym)
            [ffi-make-closure ,fun-sym ,call-desc-sym ,safe-p ,abort-retval])))))
 
diff --git a/txr.1 b/txr.1
index d3e3a769..d4b58266 100644
--- a/txr.1
+++ b/txr.1
@@ -74953,7 +74953,8 @@ a Lisp expression denoting FFI syntax.
 
 .coNP Function @ ffi-make-call-desc
 .synb
-.mets (ffi-make-call-desc < ntotal < nfixed < rettype << argtypes )
+.mets (ffi-make-call-desc < ntotal < nfixed < rettype
+.mets \ \  < argtypes <> [ name ])
 .syne
 .desc
 The
@@ -74992,6 +74993,14 @@ If the function is variadic, then the first
 elements of this list specify the types of the fixed arguments;
 the remaining elements specify the variadic arguments.
 
+The
+.meta name
+argument gives the name of the function for which this description is intended,
+or some other identifying symbol. This symbols is used in diagnostic messages
+related to errors in the construction of the descriptor itself or its
+subsequent use. If this parameter is omitted, then the involved FFI functions
+use their own names in reporting diagnostics.
+
 Note: variadic functions must not be called using a non-variadic
 descriptor, and
 .IR "vice versa" ,