Changeset 6041


Ignore:
Timestamp:
Mar 15, 2007, 6:32:59 AM (13 years ago)
Author:
gb
Message:

Lots of changes for "ordinally" typed pointers; hard to bootstrap.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/lib/foreign-types.lisp

    r6029 r6041  
    3737            (interface-dir-name d)
    3838            (interface-dir-subdir d))))
    39  
     39
     40;;; We can't reference foreign types early in the cold load,
     41;;; but we want things like RLET to be able to set a pointer's
     42;;; type based on the foreign-type's "ordinal".  We therefore
     43;;; seem to have to arrange that certain types have fixed,
     44;;; "canonical" ordinals.  I doubt if we need more than a handful
     45;;; of these, but let's burn 100
     46
     47(defconstant max-canonical-foreign-type-ordinal 100)
     48
    4049;;; This is intended to try to encapsulate foreign type stuff, to
    4150;;; ease cross-compilation (among other things.)
     
    5867  (ff-call-struct-return-by-implicit-arg-function ())
    5968  (callback-bindings-function ())
    60   (callback-return-value-function ()))
     69  (callback-return-value-function ())
     70  (ordinal max-canonical-foreign-type-ordinal)
     71  (ordinal-lock (make-lock))
     72  (ordinal-types (make-hash-table :test #'eq :weak :key))
     73  (pointer-types (make-hash-table :test #'equalp)))
     74
    6175
    6276
     
    91105      *host-ftd*)
    92106
     107(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*))
     108  (with-lock-grabbed ((ftd-ordinal-lock ftd))
     109    (incf (ftd-ordinal ftd))))
     110
     111
    93112(defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body)
    94113  `(do-dll-nodes  (,dir (ftd-dirlist ,ftd))
     
    183202    (setf (gethash (make-keyword x) (ftd-translators ftd)) val))
    184203
     204  (defun note-foreign-type-ordinal (type ftd)
     205    (let* ((ordinal (and type (foreign-type-ordinal type))))
     206      (when (and ordinal (not (eql 0 ordinal)))
     207        (with-lock-grabbed ((ftd-ordinal-lock ftd))
     208          (setf (gethash ordinal (ftd-ordinal-types ftd)) type)))))
     209 
    185210  (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
    186211    (if (info-foreign-type-translator x)
     
    193218    (gethash (make-keyword x) (ftd-definitions ftd)))
    194219  (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*))
     220    (note-foreign-type-ordinal val ftd)
    195221    (setf (gethash (make-keyword x) (ftd-definitions ftd)) val))
    196222  (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*))
     
    200226    (gethash (make-keyword x) (ftd-struct-definitions ftd)))
    201227  (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*))
     228    (note-foreign-type-ordinal val ftd)
    202229    (setf (gethash (make-keyword x) (ftd-struct-definitions ftd)) val))
    203230
     
    205232    (gethash (make-keyword x) (ftd-union-definitions ftd)))
    206233  (defun (setf info-foreign-type-union) (val x  &optional (ftd *target-ftd*))
     234    (note-foreign-type-ordinal val ftd)
    207235    (setf (gethash (make-keyword x) (ftd-union-definitions ftd)) val))
    208236
     
    210238    (gethash (make-keyword x) (ftd-enum-definitions ftd)))
    211239  (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*))
     240    (note-foreign-type-ordinal val ftd)
    212241    (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val))
    213242
     
    322351
    323352(defstruct (foreign-type
    324             (:constructor make-foreign-type (&key class bits alignment))
     353            (:constructor make-foreign-type (&key class bits alignment ordinal))
    325354            (:print-object
    326355             (lambda (s out)
     
    329358  (class 'root :type symbol)
    330359  (bits nil :type (or null unsigned-byte))
    331   (alignment (guess-alignment bits) :type (or null unsigned-byte)))
     360  (alignment (guess-alignment bits) :type (or null unsigned-byte))
     361  (ordinal (next-foreign-type-ordinal)))
    332362
    333363
     
    602632;;;; Default methods.
    603633
    604 (defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0))
     634(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0))
    605635
    606636(def-foreign-type-method (root :unparse) (type)
     
    15831613          (accessors field-name))))))
    15841614
     1615(defun canonicalize-foreign-type-ordinals (ftd)
     1616  (let* ((canonical-ordinal 0))          ; used for :VOID
     1617    (flet ((canonicalize-foreign-type-ordinal (spec)
     1618             (let* ((new-ordinal (incf canonical-ordinal)))
     1619               (when spec
     1620                 (let* ((type (parse-foreign-type spec))
     1621                        (old-ordinal (foreign-type-ordinal type)))
     1622                   (unless (eql new-ordinal old-ordinal)
     1623                     (remhash old-ordinal (ftd-ordinal-types ftd))
     1624                     (setf (foreign-type-ordinal type) new-ordinal)
     1625                     (note-foreign-type-ordinal type ftd))))
     1626               new-ordinal)))
     1627      (canonicalize-foreign-type-ordinal :signed)
     1628      (canonicalize-foreign-type-ordinal :unsigned)
     1629      (canonicalize-foreign-type-ordinal :long)
     1630      (canonicalize-foreign-type-ordinal :address)
     1631      (canonicalize-foreign-type-ordinal #-darwin-target
     1632                                         '(:struct :<D>l_info)
     1633                                         #+darwin-target nil)
     1634      (canonicalize-foreign-type-ordinal '(:struct :timespec))
     1635      (canonicalize-foreign-type-ordinal '(:struct :timeval))
     1636      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
     1637      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
     1638      (canonicalize-foreign-type-ordinal '(:struct :linger))
     1639      (canonicalize-foreign-type-ordinal '(:struct :hostent))
     1640      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
     1641      (canonicalize-foreign-type-ordinal '(:* :char))
     1642      (canonicalize-foreign-type-ordinal '(:struct :stat))
     1643      (canonicalize-foreign-type-ordinal '(:struct :passwd))
     1644      (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil)
     1645      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
     1646      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
     1647      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)))))
     1648                   
    15851649(defun install-standard-foreign-types (ftd)
    15861650  (let* ((*target-ftd* ftd)
     
    16581722                    (reduce #'* dims))))))
    16591723    (def-foreign-type-translator * (to)
    1660       (make-foreign-pointer-type
    1661        :to (if (eq to t) *void-foreign-type* (parse-foreign-type to))
    1662        :bits natural-word-size))
     1724      (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
     1725        (or (gethash to (ftd-pointer-types *target-ftd*))
     1726            (setf (gethash to (ftd-pointer-types *target-ftd*))
     1727                  (make-foreign-pointer-type
     1728                   :to to
     1729                   :bits natural-word-size)))))
    16631730    (def-foreign-type-translator boolean (&optional (bits 32))
    16641731      (make-foreign-boolean-type :bits bits :signed nil))
     
    17201787                (this (* t #|(struct :ucontext)|#))
    17211788                (prev (* (struct  :xframe-list)))))
     1789    (canonicalize-foreign-type-ordinals ftd)
    17221790    ))
    17231791
Note: See TracChangeset for help on using the changeset viewer.