Index: /branches/objc-gf/ccl/lib/foreign-types.lisp =================================================================== --- /branches/objc-gf/ccl/lib/foreign-types.lisp (revision 6040) +++ /branches/objc-gf/ccl/lib/foreign-types.lisp (revision 6041) @@ -37,5 +37,14 @@ (interface-dir-name d) (interface-dir-subdir d)))) - + +;;; We can't reference foreign types early in the cold load, +;;; but we want things like RLET to be able to set a pointer's +;;; type based on the foreign-type's "ordinal". We therefore +;;; seem to have to arrange that certain types have fixed, +;;; "canonical" ordinals. I doubt if we need more than a handful +;;; of these, but let's burn 100 + +(defconstant max-canonical-foreign-type-ordinal 100) + ;;; This is intended to try to encapsulate foreign type stuff, to ;;; ease cross-compilation (among other things.) @@ -58,5 +67,10 @@ (ff-call-struct-return-by-implicit-arg-function ()) (callback-bindings-function ()) - (callback-return-value-function ())) + (callback-return-value-function ()) + (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))) + @@ -91,4 +105,9 @@ *host-ftd*) +(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*)) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (incf (ftd-ordinal ftd)))) + + (defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body) `(do-dll-nodes (,dir (ftd-dirlist ,ftd)) @@ -183,4 +202,10 @@ (setf (gethash (make-keyword x) (ftd-translators ftd)) val)) + (defun note-foreign-type-ordinal (type ftd) + (let* ((ordinal (and type (foreign-type-ordinal type)))) + (when (and ordinal (not (eql 0 ordinal))) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (setf (gethash ordinal (ftd-ordinal-types ftd)) type))))) + (defun info-foreign-type-kind (x &optional (ftd *target-ftd*)) (if (info-foreign-type-translator x) @@ -193,4 +218,5 @@ (gethash (make-keyword x) (ftd-definitions ftd))) (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) (setf (gethash (make-keyword x) (ftd-definitions ftd)) val)) (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*)) @@ -200,4 +226,5 @@ (gethash (make-keyword x) (ftd-struct-definitions ftd))) (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) (setf (gethash (make-keyword x) (ftd-struct-definitions ftd)) val)) @@ -205,4 +232,5 @@ (gethash (make-keyword x) (ftd-union-definitions ftd))) (defun (setf info-foreign-type-union) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) (setf (gethash (make-keyword x) (ftd-union-definitions ftd)) val)) @@ -210,4 +238,5 @@ (gethash (make-keyword x) (ftd-enum-definitions ftd))) (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val)) @@ -322,5 +351,5 @@ (defstruct (foreign-type - (:constructor make-foreign-type (&key class bits alignment)) + (:constructor make-foreign-type (&key class bits alignment ordinal)) (:print-object (lambda (s out) @@ -329,5 +358,6 @@ (class 'root :type symbol) (bits nil :type (or null unsigned-byte)) - (alignment (guess-alignment bits) :type (or null unsigned-byte))) + (alignment (guess-alignment bits) :type (or null unsigned-byte)) + (ordinal (next-foreign-type-ordinal))) @@ -602,5 +632,5 @@ ;;;; Default methods. -(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0)) +(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0)) (def-foreign-type-method (root :unparse) (type) @@ -1583,4 +1613,38 @@ (accessors field-name)))))) +(defun canonicalize-foreign-type-ordinals (ftd) + (let* ((canonical-ordinal 0)) ; used for :VOID + (flet ((canonicalize-foreign-type-ordinal (spec) + (let* ((new-ordinal (incf canonical-ordinal))) + (when spec + (let* ((type (parse-foreign-type spec)) + (old-ordinal (foreign-type-ordinal type))) + (unless (eql new-ordinal old-ordinal) + (remhash old-ordinal (ftd-ordinal-types ftd)) + (setf (foreign-type-ordinal type) new-ordinal) + (note-foreign-type-ordinal type ftd)))) + new-ordinal))) + (canonicalize-foreign-type-ordinal :signed) + (canonicalize-foreign-type-ordinal :unsigned) + (canonicalize-foreign-type-ordinal :long) + (canonicalize-foreign-type-ordinal :address) + (canonicalize-foreign-type-ordinal #-darwin-target + '(:struct :l_info) + #+darwin-target nil) + (canonicalize-foreign-type-ordinal '(:struct :timespec)) + (canonicalize-foreign-type-ordinal '(:struct :timeval)) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in)) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un)) + (canonicalize-foreign-type-ordinal '(:struct :linger)) + (canonicalize-foreign-type-ordinal '(:struct :hostent)) + (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3)) + (canonicalize-foreign-type-ordinal '(:* :char)) + (canonicalize-foreign-type-ordinal '(:struct :stat)) + (canonicalize-foreign-type-ordinal '(:struct :passwd)) + (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil) + (canonicalize-foreign-type-ordinal '(:struct :in_addr)) + (canonicalize-foreign-type-ordinal '(:struct :cdb-datum)) + (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))))) + (defun install-standard-foreign-types (ftd) (let* ((*target-ftd* ftd) @@ -1658,7 +1722,10 @@ (reduce #'* dims)))))) (def-foreign-type-translator * (to) - (make-foreign-pointer-type - :to (if (eq to t) *void-foreign-type* (parse-foreign-type to)) - :bits natural-word-size)) + (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to)))) + (or (gethash to (ftd-pointer-types *target-ftd*)) + (setf (gethash to (ftd-pointer-types *target-ftd*)) + (make-foreign-pointer-type + :to to + :bits natural-word-size))))) (def-foreign-type-translator boolean (&optional (bits 32)) (make-foreign-boolean-type :bits bits :signed nil)) @@ -1720,4 +1787,5 @@ (this (* t #|(struct :ucontext)|#)) (prev (* (struct :xframe-list))))) + (canonicalize-foreign-type-ordinals ftd) ))