Changeset 7818 for branches

Timestamp:

Dec 4, 2007, 2:07:58 PM (17 years ago)

Author:

R. Matthew Emerson

Message:

Incomplete, mostly worthless.

File:

• branches/ia32/lib/ffi-darwinx8632.lisp (modified) (4 diffs)

branches/ia32/lib/ffi-darwinx8632.lisp

@@ -1 +1 @@
 (in-package "CCL")
 
-;;; On Darwin/IA-32, when a function returns a structure or union
-;;; larger than 8 bytes, the caller passes a pointer to
-;;; appropriate storage as the first argument to the function.
+;;; When a function returns a structure or union larger than 8 bytes,
+;;; the caller passes a pointer to appropriate storage as the first
+;;; argument to the function.
 (defun x86-darwin32::record-type-returns-structure-as-first-arg (rtype)
   (when (and rtype
@@ -13 +13 @@
                     (parse-foreign-type rtype))))
       (> (ensure-foreign-type-bits ftype) 64))))
+
 
 ;;; All arguments are passed on the stack, except for MMX and XMM
@@ -67 +68 @@
           (argforms (foreign-type-to-representation-type result-type))
           (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
-            (format t "~&call = ~s" call)
+            ;;(format t "~&call = ~s" call)
             call)))))
 
@@ -80 +81 @@
 ;;; The byte offset of the foreign return address, relative to STACK-PTR
 
-(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)
+(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
+  (declare (ignore fp-args-ptr))
+  (collect ((lets)
+            (rlets)
+            (inits)
+            (dynamic-extent-names))
+    (let* ((rtype (parse-foreign-type result-spec)))
+      (when (typep rtype 'foreign-record-type)
+        (if (x86-darwin32::record-type-returns-structure-as-first-arg rtype)
+          (setq argvars (cons struct-result-name argvars)
+                argspecs (cons :address argspecs)
+                rtype *void-foreign-type*)
+          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
+      (do* ((argvars argvars (cdr argvars))
+            (argspecs argspecs (cdr argspecs))
+            (delta 4 4)
+            (offset 0 (+ offset delta)))
+           ((null argvars)
+            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4)))))
+        
   (format t "~&in generate-callback-bindings")
   )
 
 (defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
+  (declare (ignore fp-args-ptr))
   (format t "~&in generate-callback-return-value")
-  )
+  (unless (eq return-type *void-foreign-type*)
+    (if (typep return-type 'foreign-record-type)
+      ;; Would have been mapped to :VOID unless record-type was <= 64 bits
+      (format t "~&need to return structure ~s by value" return-type)
+      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
+        `(setf (,
+                (case return-type-keyword
+                  (:address '%get-ptr)
+                  (:signed-doubleword '%%get-signed-longlong)
+                  (:unsigned-doubleword '%%get-unsigned-longlong)
+                  (:double-float '%get-double-float)
+                  (:single-float '%get-single-float)
+                  (:unsigned-fullword '%get-unsigned-long)
+                  (t '%get-signed-long)
+                  ) ,stack-ptr 0) ,result)))))
+