Changeset 5759

Timestamp:

Jan 20, 2007, 10:53:46 PM (18 years ago)

Author:

Gary Byers

Message:

Coerce arg, results when expanding an ff-call.

Location:

trunk/ccl/lib

Files:

• ffi-darwinppc32.lisp (modified) (2 diffs)
• ffi-darwinppc64.lisp (modified) (2 diffs)

trunk/ccl/lib/ffi-darwinppc32.lisp

@@ -57 +57 @@
 ;;; integer argument "type" specifier to denote this.
 
-(defun darwin32::expand-ff-call (callform args)
+(defun darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
   (let* ((result-type-spec (or (car (last args)) :void))
          (enclosing-form nil))
@@ -106 +106 @@
                   (progn
                     (argforms (foreign-type-to-representation-type ftype))
-                    (argforms arg-value-form)))))))
+                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
         (argforms (foreign-type-to-representation-type result-type))
-        (let* ((call `(,@callform ,@(argforms))))
+        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
           (if enclosing-form
             `(,@enclosing-form ,call)

trunk/ccl/lib/ffi-darwinppc64.lisp

@@ -163 +163 @@
                                   
 
-(defun darwin64::expand-ff-call (callform args)
+(defun darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
   (let* ((result-type-spec (or (car (last args)) :void))
          (regbuf nil)
@@ -234 +234 @@
                       (progn
                         (argforms (foreign-type-to-representation-type ftype))
-                        (argforms arg-value-form)))))))
+                        (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
             (argforms (foreign-type-to-representation-type result-type))
-            (let* ((call `(,@callform ,@(argforms))))
+            (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
               (when structure-arg-temp
                 (setq call `(let* ((,structure-arg-temp (%null-ptr)))