Changeset 5743

Timestamp:

Jan 20, 2007, 6:17:40 PM (18 years ago)

Author:

Gary Byers

Message:

ftd's :ff-call-expand-function is os::expand-ff-call.

Canonicalize the :void type a bit better.

File:

• trunk/ccl/lib/foreign-types.lisp (modified) (4 diffs)

trunk/ccl/lib/foreign-types.lisp

@@ -75 +75 @@
                       :prepend-underscores #+darwinppc-target t #-darwinppc-target nil)
                     :ff-call-expand-function
-                    #+(and darwinppc-target 32-bit-target) 'ppc32::darwin-expand-ff-call
-                    #+(and darwinppc-target 64-bit-target) 'ppc64::darwin-expand-ff-call
-                    #+(and linuxppc-target 32-bit-target) 'ppc32::linux-expand-ff-call
-                    #+(and linuxppc-target 64-bit-target) 'ppc64::linux-expand-ff-call
-                    #+linuxx8664-target 'x8664::linux-expand-ff-call
-                    #+darwinx8664-target 'x8664:::darwin-expand-ff-call
-                    #+freebsdx8664-target 'x8664:::freebsd-expand-ff-call 
-  
+                    'os::expand-ff-call 
                     ))
                     
@@ -332 +325 @@
 
 (defmethod make-load-form ((s foreign-type) &optional env)
-  (make-load-form-saving-slots s :environment env))
+  (if (eq s *void-foreign-type*)
+    '*void-foreign-type*
+    (make-load-form-saving-slots s :environment env)))
 
 
@@ -1523 +1518 @@
           (typep f 'unsigned-byte))
     f
-    (let* ((ftype (parse-foreign-type f)))
+    (let* ((ftype (if (typep f 'foreign-type)
+                    f
+                    (parse-foreign-type f))))
       (or
        (and (eq (foreign-type-class ftype) 'root) :void)         
        (typecase ftype
-         (foreign-pointer-type :address)
+         ((or foreign-pointer-type foreign-array-type) :address)
          (foreign-double-float-type :double-float)
          (foreign-single-float-type :single-float)
@@ -1550 +1547 @@
                     (if (<= bits 64)
                       :unsigned-doubleword)))))))
-         ((or foreign-record-type foreign-array-type)
+         (foreign-record-type
           (if (getf (ftd-attributes *target-ftd*)
                   :struct-by-value)