Changeset 6052

Timestamp:

Mar 17, 2007, 12:08:56 AM (18 years ago)

Author:

Gary Byers

Message:

Revert out of some of the changes that led to Trac bug #2.

Try hard to preserve identity of named foreign-record-types; check for field
redefinition earlier.

Use PARSE-FOREIGN-TYPE in load form for FOREIGN-RECORD-TYPE, so that we
go through the same interning (of named types) and field compatibility
checking. Move some of the FOREIGN-RECORD-TYPE definitions later in
the load order, since it's never really worked (doesn't enhance cross-compilation
to define them inside INSTALL-STANDARD-FOREIGN-TYPES, and since we now need
to be able to call PARSE-FOREIGN-TYPE, which can't work that early.
(Actually, it might work to call PARSE-FOREIGN-TYPE to define structure types
at load time, rather than dealing with the strange type constants introduced
in the expansion of DEF-FOREIGN-TYPE.)

File:

• branches/objc-gf/ccl/lib/foreign-types.lisp (modified) (21 diffs)

branches/objc-gf/ccl/lib/foreign-types.lisp

@@ -70 +70 @@
   (ordinal max-canonical-foreign-type-ordinal)
   (ordinal-lock (make-lock))
-  (ordinal-types (make-hash-table :test #'eq :weak :key))
-  (pointer-types (make-hash-table :test #'equalp))
-  (array-types (make-hash-table :test #'equalp)))
+  (ordinal-types (make-hash-table :test #'eq :weak :value))
+  (pointer-types (make-hash-table :test #'eq))
+  (array-types (make-hash-table :test #'equal)))
 
 
@@ -197 +197 @@
 
   (defvar *foreign-type-classes* (make-hash-table :test #'eq))
-  
+
   (defun info-foreign-type-translator (x &optional (ftd *target-ftd*))
     (gethash (make-keyword x) (ftd-translators ftd)))
@@ -210 +210 @@
   
   (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
-    (if (info-foreign-type-translator x)
+    (if (info-foreign-type-translator x ftd)
       :primitive
       (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown)))
@@ -423 +423 @@
 
 (defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*))
-  (or
-   (ecase kind
-     (:struct
-      (info-foreign-type-struct name ftd))
-     (:union
-      (info-foreign-type-union name ftd))
-     (:enum
-      (info-foreign-type-enum name ftd)))
-   (flet ((aux-defn-matches (x)
-            (and (eq (first x) kind) (eq (second x) name))))
-     (let ((in-auxiliaries
-            (or (find-if #'aux-defn-matches *new-auxiliary-types*)
-                (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
-       (if in-auxiliaries
-         (values (third in-auxiliaries) t))))))
+  (declare (ignore ftd))
+  (flet ((aux-defn-matches (x)
+           (and (eq (first x) kind) (eq (second x) name))))
+    (let ((in-auxiliaries
+           (or (find-if #'aux-defn-matches *new-auxiliary-types*)
+               (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
+      (if in-auxiliaries
+        (values (third in-auxiliaries) t)))))
 
 (defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*))
+  (declare (ignore ftd))
   (flet ((aux-defn-matches (x)
            (and (eq (first x) kind) (eq (second x) name))))
@@ -447 +441 @@
       (error "Attempt to shadow definition of ~A ~S." kind name)))
   (push (list kind name defn) *new-auxiliary-types*)
-  (ecase kind
-    (:struct
-     (setf (info-foreign-type-struct name ftd) defn))
-    (:union
-     (setf (info-foreign-type-union name ftd) defn))
-    (:enum
-     (setf (info-foreign-type-enum name ftd) defn)))
   defn)
 
@@ -689 +676 @@
 
 (defvar *unsigned-integer-types*
-  (let* ((a (make-array 33)))
-    (dotimes (i 33 a)
+  (let* ((a (make-array 65)))
+    (dotimes (i 65 a)
       (setf (svref a i) (make-foreign-integer-type :signed nil
                                                    :bits i
@@ -699 +686 @@
 
 (defvar *signed-integer-types*
-  (let* ((a (make-array 33)))
-    (dotimes (i 33 a)
+  (let* ((a (make-array 65)))
+    (dotimes (i 65 a)
       (setf (svref a i) (make-foreign-integer-type :signed t
                                                    :bits i
@@ -709 +696 @@
          
 
-(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwinppc-target t #-darwinppc-target nil))
+(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil))
 
                                                   
@@ -922 +909 @@
    `(etypecase ,value
       (null
-       (int-sap 0))
+       (%int-to-ptr 0))
       (macptr
        ,value)
@@ -1012 +999 @@
   (alt-align nil :type (or unsigned-byte null)))
 
-
-(defun parse-foreign-record-type (kind name fields)
-  (if fields
-    (let* ((old (and name (auxiliary-foreign-type kind name)))
-           (result (or old
-                       (make-foreign-record-type :name name :kind kind))))
-      (when (and name (not (eq old result)))
-        (setf (auxiliary-foreign-type kind name) result))
-      (parse-foreign-record-fields result fields)
-      result)
+(defmethod make-load-form ((r foreign-record-type) &optional environment)
+  (declare (ignore environment))
+  `(parse-foreign-type ',(unparse-foreign-type r)))
+
+
+(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*))
+  (let* ((result (if name
+                   (or
+                    (ecase kind
+                      (:struct (info-foreign-type-struct name ftd))
+                      (:union (info-foreign-type-union name ftd)))
+                    (case kind
+                      (:struct (setf (info-foreign-type-struct name ftd)
+                                     (make-foreign-record-type :name name :kind :struct)))
+                      (:union  (setf (info-foreign-type-union name ftd)
+                                     (make-foreign-record-type :name name :kind :union)))))
+                   (make-foreign-record-type :kind kind))))
+    (when fields
+      (multiple-value-bind (parsed-fields alignment bits)
+          (parse-field-list fields kind (foreign-record-type-alt-align result))
+        (let* ((old-fields (foreign-record-type-fields result)))
+          (setf (foreign-record-type-fields result) parsed-fields
+                (foreign-record-type-alignment result) alignment
+                (foreign-record-type-bits result) bits)
+          (when old-fields
+            (unless (record-fields-match old-fields parsed-fields 5)
+              (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s"
+                    kind name parsed-fields old-fields))))))
     (if name
-      (or (auxiliary-foreign-type kind name)
-          (setf (auxiliary-foreign-type kind name)
-                (make-foreign-record-type :name name :kind kind)))
-      (make-foreign-record-type :kind kind))))
+      (unless (eq (auxiliary-foreign-type kind name) result)
+        (setf (auxiliary-foreign-type kind name) result)))
+    result))
 
 ;;; PARSE-FOREIGN-RECORD-FIELDS -- internal
@@ -1033 +1037 @@
 ;;; types.  RESULT holds the record type we are paring the fields of,
 ;;; and FIELDS is the list of field specifications.
-;;; 
+;;;
+(defun parse-field-list (fields kind &optional alt-alignment)
+  (collect ((parsed-fields))
+    (let* ((total-bits 0)
+           (overall-alignment 1)
+           (first-field-p t)
+           (attributes (ftd-attributes *target-ftd*))
+           (poweropen-alignment (getf attributes :poweropen-alignment)))
+          
+      (dolist (field fields)
+        (destructuring-bind (var type &optional bits) field
+          (declare (ignore bits))
+          (let* ((field-type (parse-foreign-type type))
+                 (bits (ensure-foreign-type-bits field-type))
+                 (natural-alignment (foreign-type-alignment field-type))
+                 (alignment (if alt-alignment
+                              (min natural-alignment alt-alignment)
+                              (if poweropen-alignment
+                                (if first-field-p
+                                  (progn
+                                    (setq first-field-p nil)
+                                    natural-alignment)
+                                  (min 32 natural-alignment))
+                                natural-alignment)))
+                 (parsed-field
+                  (make-foreign-record-field :type field-type
+                                             :name var)))
+            (parsed-fields parsed-field)
+            (when (null bits)
+              (error "Unknown size: ~S"
+                     (unparse-foreign-type field-type)))
+            (when (null alignment)
+              (error "Unknown alignment: ~S"
+                     (unparse-foreign-type field-type)))
+            (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
+            (ecase kind
+              (:struct
+               (let ((offset (align-offset total-bits alignment)))
+                 (setf (foreign-record-field-offset parsed-field) offset)
+                 (setf (foreign-record-field-bits parsed-field) bits)
+                 (setf total-bits (+ offset bits))))
+              (:union
+               (setf total-bits (max total-bits bits)))))))
+      (values (parsed-fields)
+              (or alt-alignment overall-alignment)
+              (align-offset total-bits (or alt-alignment overall-alignment))))))
+            
+
+
 (defun parse-foreign-record-fields (result fields)
   (declare (type foreign-record-type result)
            (type list fields))
-  (let* ((total-bits 0)
-         (overall-alignment 1)
-         (parsed-fields nil)
-         (first-field-p t)
-         (alt-alignment (foreign-record-type-alt-align result))
-         (attributes (ftd-attributes *target-ftd*))
-         (poweropen-alignment (getf attributes :poweropen-alignment)))
-          
-    (dolist (field fields)
-      (destructuring-bind (var type &optional bits) field
-        (declare (ignore bits))
-        (let* ((field-type (parse-foreign-type type))
-               (bits (ensure-foreign-type-bits field-type))
-               (natural-alignment (foreign-type-alignment field-type))
-               (alignment (if alt-alignment
-                            (min natural-alignment alt-alignment)
-                            (if poweropen-alignment
-                              (if first-field-p
-                                (progn
-                                  (setq first-field-p nil)
-                                  natural-alignment)
-                                (min 32 natural-alignment))
-                              natural-alignment)))
-               (parsed-field
-                (make-foreign-record-field :type field-type
-                                           :name var)))
-          (push parsed-field parsed-fields)
-          (when (null bits)
-            (error "Unknown size: ~S"
-                   (unparse-foreign-type field-type)))
-          (when (null alignment)
-            (error "Unknown alignment: ~S"
-                   (unparse-foreign-type field-type)))
-          (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
-          (ecase (foreign-record-type-kind result)
-            (:struct
-             (let ((offset (align-offset total-bits alignment)))
-               (setf (foreign-record-field-offset parsed-field) offset)
-               (setf (foreign-record-field-bits parsed-field) bits)
-               (setf total-bits (+ offset bits))))
-            (:union
-             (setf total-bits (max total-bits bits)))))))
-    (let ((new (nreverse parsed-fields)))
-      (setf (foreign-record-type-fields result) new))
-    (setf (foreign-record-type-alignment result) (or alt-alignment
-                                                     overall-alignment))
-    (setf (foreign-record-type-bits result)
-          (align-offset total-bits (or alt-alignment overall-alignment)))))
+  (multiple-value-bind (parsed-fields alignment bits)
+      (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result))
+    (setf (foreign-record-type-fields result) parsed-fields
+          (foreign-record-type-alignment result) alignment
+          (foreign-record-type-bits result) bits)))
+
 
 (def-foreign-type-method (record :unparse) (type)
@@ -1415 +1425 @@
            (container (fv.container fv)))
       (if addr
+        #+32-bit-target
         (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
+        #+64-bit-target
+                (format out " (#x~168,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
         (format out " {unresolved} "))
       (when (and container (or (not (typep container 'macptr))
@@ -1614 +1627 @@
           (accessors field-name))))))
 
+
 (defun canonicalize-foreign-type-ordinals (ftd)
   (let* ((canonical-ordinal 0))          ; used for :VOID
@@ -1631 +1645 @@
       (canonicalize-foreign-type-ordinal :address)
       (canonicalize-foreign-type-ordinal #-darwin-target
-                                         '(:struct :<D>l_info)
+                                         :<D>l_info
                                          #+darwin-target nil)
       (canonicalize-foreign-type-ordinal '(:struct :timespec))
@@ -1646 +1660 @@
       (canonicalize-foreign-type-ordinal '(:struct :in_addr))
       (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
-      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)))))
-                    
+      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
+      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
+      )))
+
 (defun install-standard-foreign-types (ftd)
   (let* ((*target-ftd* ftd)
          (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)))
+
     (def-foreign-type-translator signed (&optional (bits 32))
-      (if (<= bits 32)
+      (if (<= bits 64)
         (svref *signed-integer-types* bits)
         (make-foreign-integer-type :bits bits)))
@@ -1658 +1675 @@
 
     (def-foreign-type-translator integer (&optional (bits 32))
-      (if (<= bits 32)
+      (if (<= bits 64)
         (svref *signed-integer-types* bits)
         (make-foreign-integer-type :bits bits)))
 
     (def-foreign-type-translator unsigned (&optional (bits 32))
-      (if (<= bits 32)
+      (if (<= bits 64)
         (svref *unsigned-integer-types* bits)
         (make-foreign-integer-type :bits bits :signed nil)))
@@ -1696 +1713 @@
                       (parse-foreign-type result-type))
        :arg-types (mapcar #'parse-foreign-type arg-types)))
+
     (def-foreign-type-translator struct (name &rest fields)
       (parse-foreign-record-type :struct name fields))
@@ -1713 +1731 @@
         
       (let* ((type (parse-foreign-type ele-type))
-            (pair (cons type dims)))
+             (pair (cons type dims)))
         (declare (dynamic-extent pair))
+        (ensure-foreign-type-bits type)
         (or (gethash pair (ftd-array-types *target-ftd*))
             (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
@@ -1727 +1746 @@
                                             (foreign-type-alignment type))
                               (reduce #'* dims))))))))
+
     (def-foreign-type-translator * (to)
       (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
+        (ensure-foreign-type-bits to)
         (or (gethash to (ftd-pointer-types *target-ftd*))
             (setf (gethash to (ftd-pointer-types *target-ftd*))
@@ -1734 +1755 @@
                    :to to
                    :bits natural-word-size)))))
+    
     (def-foreign-type-translator boolean (&optional (bits 32))
       (make-foreign-boolean-type :bits bits :signed nil))
+
     (def-foreign-type signed-char (signed 8))
     (def-foreign-type signed-byte (signed 8))
@@ -1768 +1791 @@
       (%def-foreign-type :signed-long signed-long-type ftd)
       (%def-foreign-type :unsigned-long unsigned-long-type ftd))
-    ;;
-    ;; Defining the handful of foreign structures that are used
-    ;; to build OpenMCL here ensures that all backends see appropriate
-    ;; definitions of them.
-    ;;
-    (def-foreign-type nil
-        (struct :cdb-datum
-                (:data (* t))
-                (:size (:unsigned 32))))
-    (def-foreign-type nil
-        (:struct :dbm-constant
-                 (:class (:unsigned 32))
-                 (:pad (:unsigned 32))
-                 (:value
-                  (:union nil
-                          (:s32 (:signed 32))
-                          (:u32 (:unsigned 32))
-                          (:single-float :float)
-                          (:double-float :double)))))
-    ;; This matches the xframe-list struct definition in
-    ;; "ccl:lisp-kernel;constants.h"
-    (def-foreign-type nil
-        (struct :xframe-list
-                (this (* t #|(struct :ucontext)|#))
-                (prev (* (struct  :xframe-list)))))
-    (canonicalize-foreign-type-ordinals ftd)
     ))
 
 
-(install-standard-foreign-types *host-ftd*)
-
+
+
+
+