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.

1 files changed, 18 insertions, 10 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