Changeset 6223


Ignore:
Timestamp:
Apr 8, 2007, 4:17:04 PM (13 years ago)
Author:
gb
Message:

Foreign-type-ordinals, some of which are canonical.
Straighten out the auxiliary-foreign-types mess a bit.
Intern integer types up to 64 bits.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/foreign-types.lisp

    r6029 r6223  
    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 :value))
     73  (pointer-types (make-hash-table :test #'eq))
     74  (array-types (make-hash-table :test #'equal)))
     75
    6176
    6277
     
    91106      *host-ftd*)
    92107
     108(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*))
     109  (with-lock-grabbed ((ftd-ordinal-lock ftd))
     110    (incf (ftd-ordinal ftd))))
     111
     112
    93113(defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body)
    94114  `(do-dll-nodes  (,dir (ftd-dirlist ,ftd))
     
    177197
    178198  (defvar *foreign-type-classes* (make-hash-table :test #'eq))
    179  
     199
    180200  (defun info-foreign-type-translator (x &optional (ftd *target-ftd*))
    181201    (gethash (make-keyword x) (ftd-translators ftd)))
     
    183203    (setf (gethash (make-keyword x) (ftd-translators ftd)) val))
    184204
     205  (defun note-foreign-type-ordinal (type ftd)
     206    (let* ((ordinal (and type (foreign-type-ordinal type))))
     207      (when (and ordinal (not (eql 0 ordinal)))
     208        (with-lock-grabbed ((ftd-ordinal-lock ftd))
     209          (setf (gethash ordinal (ftd-ordinal-types ftd)) type)))))
     210 
    185211  (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
    186     (if (info-foreign-type-translator x)
     212    (if (info-foreign-type-translator x ftd)
    187213      :primitive
    188214      (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown)))
     
    193219    (gethash (make-keyword x) (ftd-definitions ftd)))
    194220  (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*))
     221    (note-foreign-type-ordinal val ftd)
    195222    (setf (gethash (make-keyword x) (ftd-definitions ftd)) val))
    196223  (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*))
     
    200227    (gethash (make-keyword x) (ftd-struct-definitions ftd)))
    201228  (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*))
     229    (note-foreign-type-ordinal val ftd)
    202230    (setf (gethash (make-keyword x) (ftd-struct-definitions ftd)) val))
    203231
     
    205233    (gethash (make-keyword x) (ftd-union-definitions ftd)))
    206234  (defun (setf info-foreign-type-union) (val x  &optional (ftd *target-ftd*))
     235    (note-foreign-type-ordinal val ftd)
    207236    (setf (gethash (make-keyword x) (ftd-union-definitions ftd)) val))
    208237
     
    210239    (gethash (make-keyword x) (ftd-enum-definitions ftd)))
    211240  (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*))
     241    (note-foreign-type-ordinal val ftd)
    212242    (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val))
    213243
     
    322352
    323353(defstruct (foreign-type
    324             (:constructor make-foreign-type (&key class bits alignment))
     354            (:constructor make-foreign-type (&key class bits alignment ordinal))
    325355            (:print-object
    326356             (lambda (s out)
     
    329359  (class 'root :type symbol)
    330360  (bits nil :type (or null unsigned-byte))
    331   (alignment (guess-alignment bits) :type (or null unsigned-byte)))
     361  (alignment (guess-alignment bits) :type (or null unsigned-byte))
     362  (ordinal (next-foreign-type-ordinal)))
    332363
    333364
     
    392423
    393424(defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*))
    394   (or
    395    (ecase kind
    396      (:struct
    397       (info-foreign-type-struct name ftd))
    398      (:union
    399       (info-foreign-type-union name ftd))
    400      (:enum
    401       (info-foreign-type-enum name ftd)))
    402    (flet ((aux-defn-matches (x)
    403             (and (eq (first x) kind) (eq (second x) name))))
    404      (let ((in-auxiliaries
    405             (or (find-if #'aux-defn-matches *new-auxiliary-types*)
    406                 (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
    407        (if in-auxiliaries
    408          (values (third in-auxiliaries) t))))))
     425  (declare (ignore ftd))
     426  (flet ((aux-defn-matches (x)
     427           (and (eq (first x) kind) (eq (second x) name))))
     428    (let ((in-auxiliaries
     429           (or (find-if #'aux-defn-matches *new-auxiliary-types*)
     430               (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
     431      (if in-auxiliaries
     432        (values (third in-auxiliaries) t)))))
    409433
    410434(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*))
     435  (declare (ignore ftd))
    411436  (flet ((aux-defn-matches (x)
    412437           (and (eq (first x) kind) (eq (second x) name))))
     
    416441      (error "Attempt to shadow definition of ~A ~S." kind name)))
    417442  (push (list kind name defn) *new-auxiliary-types*)
    418   (ecase kind
    419     (:struct
    420      (setf (info-foreign-type-struct name ftd) defn))
    421     (:union
    422      (setf (info-foreign-type-union name ftd) defn))
    423     (:enum
    424      (setf (info-foreign-type-enum name ftd) defn)))
    425443  defn)
    426444
    427445(defsetf auxiliary-foreign-type %set-auxiliary-foreign-type)
    428446
     447
     448(defun ensure-foreign-type (x)
     449  (if (typep x 'foreign-type)
     450    x
     451    (parse-foreign-type x)))
    429452
    430453;;; *record-type-already-unparsed* -- internal
     
    602625;;;; Default methods.
    603626
    604 (defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0))
     627(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0))
    605628
    606629(def-foreign-type-method (root :unparse) (type)
     
    658681
    659682(defvar *unsigned-integer-types*
    660   (let* ((a (make-array 33)))
    661     (dotimes (i 33 a)
     683  (let* ((a (make-array 65)))
     684    (dotimes (i 65 a)
    662685      (setf (svref a i) (make-foreign-integer-type :signed nil
    663686                                                   :bits i
     
    668691
    669692(defvar *signed-integer-types*
    670   (let* ((a (make-array 33)))
    671     (dotimes (i 33 a)
     693  (let* ((a (make-array 65)))
     694    (dotimes (i 65 a)
    672695      (setf (svref a i) (make-foreign-integer-type :signed t
    673696                                                   :bits i
     
    678701         
    679702
    680 (defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwinppc-target t #-darwinppc-target nil))
     703(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil))
    681704
    682705                                                 
     
    891914   `(etypecase ,value
    892915      (null
    893        (int-sap 0))
     916       (%int-to-ptr 0))
    894917      (macptr
    895918       ,value)
     
    9811004  (alt-align nil :type (or unsigned-byte null)))
    9821005
    983 
    984 (defun parse-foreign-record-type (kind name fields)
    985   (if fields
    986     (let* ((old (and name (auxiliary-foreign-type kind name)))
    987            (result (or old
    988                        (make-foreign-record-type :name name :kind kind))))
    989       (when (and name (not (eq old result)))
    990         (setf (auxiliary-foreign-type kind name) result))
    991       (parse-foreign-record-fields result fields)
    992       result)
     1006(defmethod make-load-form ((r foreign-record-type) &optional environment)
     1007  (declare (ignore environment))
     1008  `(parse-foreign-type ',(unparse-foreign-type r)))
     1009
     1010
     1011(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*))
     1012  (let* ((result (if name
     1013                   (or
     1014                    (ecase kind
     1015                      (:struct (info-foreign-type-struct name ftd))
     1016                      (:union (info-foreign-type-union name ftd)))
     1017                    (case kind
     1018                      (:struct (setf (info-foreign-type-struct name ftd)
     1019                                     (make-foreign-record-type :name name :kind :struct)))
     1020                      (:union  (setf (info-foreign-type-union name ftd)
     1021                                     (make-foreign-record-type :name name :kind :union)))))
     1022                   (make-foreign-record-type :kind kind))))
     1023    (when fields
     1024      (multiple-value-bind (parsed-fields alignment bits)
     1025          (parse-field-list fields kind (foreign-record-type-alt-align result))
     1026        (let* ((old-fields (foreign-record-type-fields result)))
     1027          (setf (foreign-record-type-fields result) parsed-fields
     1028                (foreign-record-type-alignment result) alignment
     1029                (foreign-record-type-bits result) bits)
     1030          (when old-fields
     1031            (unless (record-fields-match old-fields parsed-fields 5)
     1032              (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s"
     1033                    kind name parsed-fields old-fields))))))
    9931034    (if name
    994       (or (auxiliary-foreign-type kind name)
    995           (setf (auxiliary-foreign-type kind name)
    996                 (make-foreign-record-type :name name :kind kind)))
    997       (make-foreign-record-type :kind kind))))
     1035      (unless (eq (auxiliary-foreign-type kind name) result)
     1036        (setf (auxiliary-foreign-type kind name) result)))
     1037    result))
    9981038
    9991039;;; PARSE-FOREIGN-RECORD-FIELDS -- internal
     
    10021042;;; types.  RESULT holds the record type we are paring the fields of,
    10031043;;; and FIELDS is the list of field specifications.
    1004 ;;;
     1044;;;
     1045(defun parse-field-list (fields kind &optional alt-alignment)
     1046  (collect ((parsed-fields))
     1047    (let* ((total-bits 0)
     1048           (overall-alignment 1)
     1049           (first-field-p t)
     1050           (attributes (ftd-attributes *target-ftd*))
     1051           (poweropen-alignment (getf attributes :poweropen-alignment)))
     1052         
     1053      (dolist (field fields)
     1054        (destructuring-bind (var type &optional bits) field
     1055          (declare (ignore bits))
     1056          (let* ((field-type (parse-foreign-type type))
     1057                 (bits (ensure-foreign-type-bits field-type))
     1058                 (natural-alignment (foreign-type-alignment field-type))
     1059                 (alignment (if alt-alignment
     1060                              (min natural-alignment alt-alignment)
     1061                              (if poweropen-alignment
     1062                                (if first-field-p
     1063                                  (progn
     1064                                    (setq first-field-p nil)
     1065                                    natural-alignment)
     1066                                  (min 32 natural-alignment))
     1067                                natural-alignment)))
     1068                 (parsed-field
     1069                  (make-foreign-record-field :type field-type
     1070                                             :name var)))
     1071            (parsed-fields parsed-field)
     1072            (when (null bits)
     1073              (error "Unknown size: ~S"
     1074                     (unparse-foreign-type field-type)))
     1075            (when (null alignment)
     1076              (error "Unknown alignment: ~S"
     1077                     (unparse-foreign-type field-type)))
     1078            (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
     1079            (ecase kind
     1080              (:struct
     1081               (let ((offset (align-offset total-bits alignment)))
     1082                 (setf (foreign-record-field-offset parsed-field) offset)
     1083                 (setf (foreign-record-field-bits parsed-field) bits)
     1084                 (setf total-bits (+ offset bits))))
     1085              (:union
     1086               (setf total-bits (max total-bits bits)))))))
     1087      (values (parsed-fields)
     1088              (or alt-alignment overall-alignment)
     1089              (align-offset total-bits (or alt-alignment overall-alignment))))))
     1090           
     1091
     1092
    10051093(defun parse-foreign-record-fields (result fields)
    10061094  (declare (type foreign-record-type result)
    10071095           (type list fields))
    1008   (let* ((total-bits 0)
    1009          (overall-alignment 1)
    1010          (parsed-fields nil)
    1011          (first-field-p t)
    1012          (alt-alignment (foreign-record-type-alt-align result))
    1013          (attributes (ftd-attributes *target-ftd*))
    1014          (poweropen-alignment (getf attributes :poweropen-alignment)))
    1015          
    1016     (dolist (field fields)
    1017       (destructuring-bind (var type &optional bits) field
    1018         (declare (ignore bits))
    1019         (let* ((field-type (parse-foreign-type type))
    1020                (bits (ensure-foreign-type-bits field-type))
    1021                (natural-alignment (foreign-type-alignment field-type))
    1022                (alignment (if alt-alignment
    1023                             (min natural-alignment alt-alignment)
    1024                             (if poweropen-alignment
    1025                               (if first-field-p
    1026                                 (progn
    1027                                   (setq first-field-p nil)
    1028                                   natural-alignment)
    1029                                 (min 32 natural-alignment))
    1030                               natural-alignment)))
    1031                (parsed-field
    1032                 (make-foreign-record-field :type field-type
    1033                                            :name var)))
    1034           (push parsed-field parsed-fields)
    1035           (when (null bits)
    1036             (error "Unknown size: ~S"
    1037                    (unparse-foreign-type field-type)))
    1038           (when (null alignment)
    1039             (error "Unknown alignment: ~S"
    1040                    (unparse-foreign-type field-type)))
    1041           (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
    1042           (ecase (foreign-record-type-kind result)
    1043             (:struct
    1044              (let ((offset (align-offset total-bits alignment)))
    1045                (setf (foreign-record-field-offset parsed-field) offset)
    1046                (setf (foreign-record-field-bits parsed-field) bits)
    1047                (setf total-bits (+ offset bits))))
    1048             (:union
    1049              (setf total-bits (max total-bits bits)))))))
    1050     (let ((new (nreverse parsed-fields)))
    1051       (setf (foreign-record-type-fields result) new))
    1052     (setf (foreign-record-type-alignment result) (or alt-alignment
    1053                                                      overall-alignment))
    1054     (setf (foreign-record-type-bits result)
    1055           (align-offset total-bits (or alt-alignment overall-alignment)))))
     1096  (multiple-value-bind (parsed-fields alignment bits)
     1097      (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result))
     1098    (setf (foreign-record-type-fields result) parsed-fields
     1099          (foreign-record-type-alignment result) alignment
     1100          (foreign-record-type-bits result) bits)))
     1101
    10561102
    10571103(def-foreign-type-method (record :unparse) (type)
     
    13841430           (container (fv.container fv)))
    13851431      (if addr
     1432        #+32-bit-target
    13861433        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
     1434        #+64-bit-target
     1435                (format out " (#x~168,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
    13871436        (format out " {unresolved} "))
    13881437      (when (and container (or (not (typep container 'macptr))
     
    15831632          (accessors field-name))))))
    15841633
     1634;;; Are all (scalar) fields in the field-list FIELDS floats ?'
     1635(defun all-floats-in-field-list (fields)
     1636  (dolist (field fields t)
     1637    (let* ((field-type (foreign-record-field-type field)))
     1638      (cond ((typep field-type 'foreign-record-type)
     1639             (unless (all-floats-in-field-list (foreign-record-type-fields field-type))
     1640                                     (return nil)))
     1641            ((typep field-type 'foreign-array-type)
     1642             (unless (typep (foreign-array-type-element-type field-type) 'foreign-float-type)
     1643               (return nil)))
     1644            (t (unless (typep field-type 'foreign-float-type)
     1645                 (return nil)))))))
     1646
     1647;;; Are any (scalar) fields in the field-list FIELDS floats ?
     1648(defun some-floats-in-field-list (fields)
     1649  (dolist (field fields)
     1650    (let* ((field-type (foreign-record-field-type field)))
     1651      (cond ((typep field-type 'foreign-float-type)
     1652             (return t))
     1653            ((typep field-type 'foreign-record-type)
     1654             (if (some-floats-in-field-list (foreign-record-type-fields field-type))
     1655               (return t)))
     1656            ((typep field-type 'foreign-array-type)
     1657             (if (typep (foreign-array-type-element-type field-type)
     1658                        'foreign-float-type)
     1659               (return t)))))))
     1660
     1661
     1662(defun canonicalize-foreign-type-ordinals (ftd)
     1663  (let* ((canonical-ordinal 0))          ; used for :VOID
     1664    (flet ((canonicalize-foreign-type-ordinal (spec)
     1665             (let* ((new-ordinal (incf canonical-ordinal)))
     1666               (when spec
     1667                 (let* ((type (parse-foreign-type spec))
     1668                        (old-ordinal (foreign-type-ordinal type)))
     1669                   (unless (eql new-ordinal old-ordinal)
     1670                     (remhash old-ordinal (ftd-ordinal-types ftd))
     1671                     (setf (foreign-type-ordinal type) new-ordinal)
     1672                     (note-foreign-type-ordinal type ftd))))
     1673               new-ordinal)))
     1674      (canonicalize-foreign-type-ordinal :signed)
     1675      (canonicalize-foreign-type-ordinal :unsigned)
     1676      (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil)
     1677      (canonicalize-foreign-type-ordinal :address)
     1678      (canonicalize-foreign-type-ordinal #-darwin-target
     1679                                         :<D>l_info
     1680                                         #+darwin-target nil)
     1681      (canonicalize-foreign-type-ordinal '(:struct :timespec))
     1682      (canonicalize-foreign-type-ordinal '(:struct :timeval))
     1683      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
     1684      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
     1685      (canonicalize-foreign-type-ordinal '(:struct :linger))
     1686      (canonicalize-foreign-type-ordinal '(:struct :hostent))
     1687      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
     1688      (canonicalize-foreign-type-ordinal '(:* :char))
     1689      (canonicalize-foreign-type-ordinal '(:struct :stat))
     1690      (canonicalize-foreign-type-ordinal '(:struct :passwd))
     1691      (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil)
     1692      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
     1693      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
     1694      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
     1695      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
     1696      )))
     1697
    15851698(defun install-standard-foreign-types (ftd)
    15861699  (let* ((*target-ftd* ftd)
    15871700         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)))
     1701
    15881702    (def-foreign-type-translator signed (&optional (bits 32))
    1589       (if (<= bits 32)
     1703      (if (<= bits 64)
    15901704        (svref *signed-integer-types* bits)
    15911705        (make-foreign-integer-type :bits bits)))
     
    15931707
    15941708    (def-foreign-type-translator integer (&optional (bits 32))
    1595       (if (<= bits 32)
     1709      (if (<= bits 64)
    15961710        (svref *signed-integer-types* bits)
    15971711        (make-foreign-integer-type :bits bits)))
    15981712
    15991713    (def-foreign-type-translator unsigned (&optional (bits 32))
    1600       (if (<= bits 32)
     1714      (if (<= bits 64)
    16011715        (svref *unsigned-integer-types* bits)
    16021716        (make-foreign-integer-type :bits bits :signed nil)))
     
    16311745                      (parse-foreign-type result-type))
    16321746       :arg-types (mapcar #'parse-foreign-type arg-types)))
     1747
    16331748    (def-foreign-type-translator struct (name &rest fields)
    16341749      (parse-foreign-record-type :struct name fields))
     
    16471762            (error "Dimension is not a non-negative fixnum: ~S" loser))))
    16481763       
    1649       (let ((type (parse-foreign-type ele-type)))
    1650         (make-foreign-array-type
    1651          :element-type type
    1652          :dimensions dims
    1653          :alignment (foreign-type-alignment type)
    1654          :bits (if (and (ensure-foreign-type-bits type)
    1655                         (every #'integerp dims))
    1656                  (* (align-offset (foreign-type-bits type)
    1657                                   (foreign-type-alignment type))
    1658                     (reduce #'* dims))))))
     1764      (let* ((type (parse-foreign-type ele-type))
     1765             (pair (cons type dims)))
     1766        (declare (dynamic-extent pair))
     1767        (ensure-foreign-type-bits type)
     1768        (or (gethash pair (ftd-array-types *target-ftd*))
     1769            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
     1770                 
     1771                  (make-foreign-array-type
     1772                   :element-type type
     1773                   :dimensions dims
     1774                   :alignment (foreign-type-alignment type)
     1775                   :bits (if (and (ensure-foreign-type-bits type)
     1776                                  (every #'integerp dims))
     1777                           (* (align-offset (foreign-type-bits type)
     1778                                            (foreign-type-alignment type))
     1779                              (reduce #'* dims))))))))
     1780
    16591781    (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))
     1782      (let* ((ftd *target-ftd*)
     1783             (to (if (eq to t) *void-foreign-type* (parse-foreign-type to ftd))))
     1784        (or (gethash to (ftd-pointer-types ftd))
     1785            (setf (gethash to (ftd-pointer-types *target-ftd*))
     1786                  (make-foreign-pointer-type
     1787                   :to to
     1788                   :bits natural-word-size)))))
     1789   
    16631790    (def-foreign-type-translator boolean (&optional (bits 32))
    16641791      (make-foreign-boolean-type :bits bits :signed nil))
     1792
    16651793    (def-foreign-type signed-char (signed 8))
    16661794    (def-foreign-type signed-byte (signed 8))
     
    17001828    ;; definitions of them.
    17011829    ;;
    1702     (def-foreign-type nil
    1703         (struct :cdb-datum
    1704                 (:data (* t))
    1705                 (:size (:unsigned 32))))
    1706     (def-foreign-type nil
    1707         (:struct :dbm-constant
    1708                  (:class (:unsigned 32))
    1709                  (:pad (:unsigned 32))
    1710                  (:value
    1711                   (:union nil
    1712                           (:s32 (:signed 32))
    1713                           (:u32 (:unsigned 32))
    1714                           (:single-float :float)
    1715                           (:double-float :double)))))
     1830    ;; Don't use DEF-FOREIGN-TYPE here; this often runs too
     1831    ;; early in the cold load for that to work.
     1832    ;;
     1833    (parse-foreign-type
     1834     '(:struct :cdb-datum
     1835       (:data (* t))
     1836       (:size (:unsigned 32)))
     1837     ftd)
     1838    (parse-foreign-type
     1839     '(:struct :dbm-constant
     1840       (:class (:unsigned 32))
     1841       (:pad (:unsigned 32))
     1842       (:value
     1843        (:union nil
     1844         (:s32 (:signed 32))
     1845         (:u32 (:unsigned 32))
     1846         (:single-float :float)
     1847         (:double-float :double))))
     1848     ftd)
    17161849    ;; This matches the xframe-list struct definition in
    17171850    ;; "ccl:lisp-kernel;constants.h"
    1718     (def-foreign-type nil
    1719         (struct :xframe-list
    1720                 (this (* t #|(struct :ucontext)|#))
    1721                 (prev (* (struct  :xframe-list)))))
    1722     ))
    1723 
    1724 
    1725 (install-standard-foreign-types *host-ftd*)
    1726 
     1851    (parse-foreign-type
     1852     '(:struct :xframe-list
     1853       (:this (:* t #|(struct :ucontext)|#))
     1854       (:prev (:* (:struct  :xframe-list))))
     1855    ftd)
     1856  ))
     1857
     1858
     1859
     1860
     1861
     1862
Note: See TracChangeset for help on using the changeset viewer.