Restructure foreign-funcall-form and ffcall-body-libffi

Restructure foreign-funcall-form and ffcall-body-libffi so that the
fsbvp split is made first in the former, and the translate-objects is
called separately for the cases non-fsbvp, and fsbvp in the latter.
This should result in the same macroexpansion, but facilitates further
changes that will fix the macroexpansion so that translation of the
foreign object occurs before exiting the with-foreign-objects that
created it.

libffi/functions.lisp

@@ -74,32 +74,35 @@
       foreign-function-name)))
 
 (defun ffcall-body-libffi
-    (function symbols return-type argument-types &optional pointerp (abi :default-abi))
+    (function function-arguments symbols types return-type argument-types &optional pointerp (abi :default-abi))
   "A body of foreign-funcall calling the libffi function #'call (ffi_call)."
-  (let ((number-of-arguments (length argument-types)))
-    `(with-foreign-objects
-         ((argvalues :pointer ,number-of-arguments)
-          ,@(unless (eql return-type :void)
-              `((result ',return-type))))
-       (loop :for arg :in (list ,@symbols)
-             :for count :from 0
-             :do (setf (mem-aref argvalues :pointer count) arg))
-       (call
-        (prepare-function ,function ',return-type ',argument-types ',abi)
-        ,(if pointerp
-             function
-             `(foreign-symbol-pointer ,function))
-        ,(if (eql return-type :void) '(null-pointer) 'result)
-        argvalues)
-       ,(if (eql return-type :void)
-            '(values)
-            (if (typep (parse-type return-type) 'translatable-foreign-type)
-                ;; just return the pointer so that expand-from-foreign
-                ;; can apply translate-from-foreign
-                'result
-                ;; built-in types won't be translated by
-                ;; expand-from-foreign, we have to do it here
-                `(mem-aref result ',return-type))))))
+  (translate-objects
+   symbols function-arguments types return-type
+   (let ((number-of-arguments (length argument-types)))
+     `(with-foreign-objects
+          ((argvalues :pointer ,number-of-arguments)
+           ,@(unless (eql return-type :void)
+               `((result ',return-type))))
+        (loop :for arg :in (list ,@symbols)
+              :for count :from 0
+              :do (setf (mem-aref argvalues :pointer count) arg))
+        (call
+         (prepare-function ,function ',return-type ',argument-types ',abi)
+         ,(if pointerp
+              function
+              `(foreign-symbol-pointer ,function))
+         ,(if (eql return-type :void) '(null-pointer) 'result)
+         argvalues)
+        ,(if (eql return-type :void)
+             '(values)
+             (if (typep (parse-type return-type) 'translatable-foreign-type)
+                 ;; just return the pointer so that expand-from-foreign
+                 ;; can apply translate-from-foreign
+                 'result
+                 ;; built-in types won't be translated by
+                 ;; expand-from-foreign, we have to do it here
+                 `(mem-aref result ',return-type)))))
+   t))
 
 (setf *foreign-structures-by-value* 'ffcall-body-libffi)
 

src/functions.lisp

@@ -54,7 +54,7 @@
        (parse-type (car types)))))
 
 (defun parse-args-and-types (args)
-  "Returns 4 values. Types, canonicalized types, args and return type."
+  "Returns 4 values: types, canonicalized types, args and return type."
   (let* ((len (length args))
          (return-type (if (oddp len) (lastcar args) :void)))
     (loop repeat (floor len 2)
@@ -114,23 +114,24 @@
       (parse-args-and-types args)
     (let ((syms (make-gensym-list (length fargs)))
           (fsbvp (fn-call-by-value-p ctypes rettype)))
-      (translate-objects
-       syms fargs types rettype
-       (if fsbvp
-           ;; Structures by value call through *foreign-structures-by-value*
-           (funcall *foreign-structures-by-value*
-                    thing
-                    syms
-                    rettype
-                    ctypes
-                    pointerp)
+      (if fsbvp
+          ;; Structures by value call through *foreign-structures-by-value*
+          (funcall *foreign-structures-by-value*
+                   thing
+                   fargs
+                   syms
+                   types
+                   rettype
+                   ctypes
+                   pointerp)
+          (translate-objects
+           syms fargs types rettype
            `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
              ;; No structures by value, direct call
              ,thing
              (,@(mapcan #'list ctypes syms)
               ,(canonicalize-foreign-type rettype))
-             ,@(parse-function-options options :pointer pointerp)))
-       fsbvp))))
+             ,@(parse-function-options options :pointer pointerp)))))))
 
 (defmacro foreign-funcall (name-and-options &rest args)
   "Wrapper around %FOREIGN-FUNCALL that translates its arguments."