Ignore:
Timestamp:
Oct 14, 2008, 6:30:00 PM (13 years ago)
Author:
gz
Message:

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/db-io.lisp

    r9915 r11089  
    9292  ;;; Open the file specified by PATHNAME for input and return a
    9393  ;;; file id.
     94  #-windows-target
    9495  (defun fid-open-input (pathname)
    9596    (let* ((id (fd-open (cdb-native-namestring pathname) #$O_RDONLY)))
     
    9798        (%errno-disp id pathname)
    9899        id)))
    99  
     100  ;; On Windows, open() can't open the same file twice, which breaks
     101  ;; bootstrapping.  Use CreateFile instead, and tell it to share.
     102  #+windows-target
     103  (defun fid-open-input (pathname)
     104    (with-filename-cstrs ((name (cdb-native-namestring pathname)))
     105      (let* ((handle (#_CreateFileW
     106                                   name
     107                                   #$GENERIC_READ
     108                                   #$FILE_SHARE_READ
     109                                   (%null-ptr)
     110                                   #$OPEN_EXISTING
     111                                   #$FILE_ATTRIBUTE_NORMAL
     112                                   (%null-ptr))))
     113        (if (eql handle *windows-invalid-handle*)
     114          (error "Error opening CDB database ~S" pathname)
     115          (%ptr-to-int handle)))))
     116
    100117  ;;; Read N octets from FID into BUF.  Return #of octets read or error.
    101118  (defun fid-read (fid buf n)
     
    506523
    507524
     525(defstruct (ffi-transparent-union (:include ffi-mem-block)
     526                                  (:constructor
     527                                   make-ffi-transparent-union (&key
     528                                                               string name
     529                                                               &aux
     530                                                               (anon-global-id
     531                                                                (unless name
     532                                                                  (concatenate 'string
     533                                                                               *ffi-prefix*
     534                                                                               "-" string)))))))
    508535(defstruct (ffi-struct (:include ffi-mem-block)
    509536                       (:constructor
     
    541568(defun ffi-union-reference (u)
    542569  (or (ffi-union-name u) (ffi-union-anon-global-id u)))
     570
     571(defun ffi-transparent-union-reference (u)
     572  (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u)))
    543573
    544574(defstruct (ffi-function (:include ffi-type))
     
    591621                          (if (eql ch #\u)
    592622                            `(:union ,name)
    593                             name)))
     623                            (if (eql ch #\U)
     624                              `(:transparent-union ,name)
     625                              name))))
    594626                      (cdr (assoc ch *arg-spec-encoding*)))))
    595627          (if result
     
    850882         (let* ((fv (%load-var sym query)))
    851883           (values (if query
    852                        fv
    853                        (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
    854                                              (fv.type fv)
    855                                              0
    856                                              nil))
     884                     fv
     885                     (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
     886                                           (fv.type fv)
     887                                           0
     888                                           nil))
    857889                   source)))))))
    858890
     
    11031135  (defconstant encoded-type-anon-union-ref 17) ; <tag>
    11041136  (defconstant encoded-type-bitfield-marker 18) ; <nbits>
     1137  (defconstant encoded-type-named-transparent-union-ref 19) ; <name>
     1138  (defconstant encoded-type-anon-transparent-union-ref 20)  ;<tag>
    11051139  )
    11061140
     
    11481182        ,@(encode-ffi-field-list (ffi-union-fields u)))
    11491183      `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask)
     1184        ,@(encode-ffi-field-list (ffi-union-fields u))))))
     1185
     1186(defun encode-ffi-transparent-union (u)
     1187  (let* ((name (ffi-transparent-union-name u))
     1188         (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u)
     1189                                           0)
     1190                                       (- 5 3))))
     1191    (if name
     1192      `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask)
     1193        ,@(encode-name name)
     1194        ,@(encode-ffi-field-list (ffi-union-fields u)))
     1195      `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask)
    11501196        ,@(encode-ffi-field-list (ffi-union-fields u))))))
    11511197
     
    12921338             (logior encoded-type-anon-union-ref alt-align-bytes-mask))
    12931339        ,@(encode-name (ffi-union-reference u)))))
     1340     (:transparent-union
     1341      (let* ((u (cadr spec))
     1342             (name (ffi-transparent-union-name u))
     1343             (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
     1344                                            0)
     1345                                        (- 5 3)))            )
     1346      `(,(if name
     1347             (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask)
     1348             (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask))
     1349        ,@(encode-name (ffi-transparent-union-reference u)))))
    12941350     (:typedef
    12951351      `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec)))))
     
    13431399                      `(#\l)
    13441400                      '(#\?)))))))))))
    1345     ((:struct :union)
    1346      `(,(if (eq (car spec) :struct)
    1347                 #\r
    1348                 #\u)
     1401    ((:struct :union :transparent-union)
     1402     `(,(ecase (car spec)
     1403          (:struct #\r)
     1404          (:union #\u)
     1405          (:transparent-union #\U))
    13491406           ,@(encode-name (ffi-struct-reference (cadr spec)))))
    13501407    (:typedef
     
    14431500  (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u)))
    14441501
     1502(defun save-ffi-transparent-union (cdbm u)
     1503  (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u)))
    14451504
    14461505
     
    16341693                                                     :name name)))
    16351694                 qq)))
    1636       ((#.encoded-type-anon-struct-ref #.encoded-type-anon-union-ref)
     1695      (#.encoded-type-named-transparent-union-ref
     1696       (multiple-value-bind (name qq) (%decode-name buf q)
     1697         (let* ((already (info-foreign-type-union name)))
     1698           (when already
     1699             (setf (foreign-record-type-kind already) :transparent-union))
     1700           (values (or already
     1701                     (setf (info-foreign-type-union name)
     1702                           (make-foreign-record-type :kind :transparent-union
     1703                                                     :name name)))
     1704                 qq))))
     1705      ((#.encoded-type-anon-struct-ref
     1706        #.encoded-type-anon-union-ref
     1707        #.encoded-type-anon-transparent-union-ref)
    16371708       (multiple-value-bind (tag qq) (%decode-name buf q t)
    16381709         (values (load-record tag) qq))))))
     
    17201791                       (setf (foreign-record-field-offset field) offset))
    17211792                     (setq total-bits (+ offset bits))))
    1722           (:union (setq total-bits (max total-bits bits))))))
     1793          ((:union :transparent-union) (setq total-bits (max total-bits bits))))))
    17231794    (setf (foreign-record-type-fields rtype) parsed-fields
    17241795          (foreign-record-type-alignment rtype) (or
     
    17411812    (multiple-value-bind (name q)
    17421813        (case rcode
    1743           ((#.encoded-type-anon-struct-ref #.encoded-type-anon-union-ref)
     1814          ((#.encoded-type-anon-struct-ref
     1815            #.encoded-type-anon-union-ref
     1816            #.encoded-type-anon-transparent-union-ref)
    17441817           (values nil (1+ p)))
    17451818          (t
     
    17541827               (or (info-foreign-type-union name)
    17551828                   (setf (info-foreign-type-union name)
    1756                          (make-foreign-record-type :kind :union :name name))))
     1829                         (make-foreign-record-type :kind
     1830                                                   (if (eql rcode encoded-type-named-union-ref)
     1831                                                     :union
     1832                                                     :transparent-union)
     1833                                                   :name name))))
    17571834             (make-foreign-record-type
    17581835              :kind (if (eql rcode encoded-type-anon-struct-ref)
    17591836                      :struct
    1760                       :union)
     1837                      (if (eql rcode encoded-type-anon-union-ref)
     1838                        :union
     1839                        :transparent-union))
    17611840              :name name)))
    17621841       (%decode-field-list buf q ftd)
     
    17891868                      (info-foreign-type-union name ftd)))
    17901869         (name (unescape-foreign-name name)))
    1791     (do-interface-dirs (d)
     1870    (do-interface-dirs (d ftd)
    17921871      (let* ((r (%load-foreign-record (db-records d) name ftd already)))
    17931872        (when r (return r))))))
Note: See TracChangeset for help on using the changeset viewer.