(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun %def-auxiliary-alien-types (types)
(dolist (info types)
+ ;; Clear up the type we're about to define from the toplevel
+ ;; *new-auxiliary-types* (local scopes take care of themselves).
+ ;; Unless this is done we never actually get back the full type
+ ;; from INFO, since the *new-auxiliary-types* have precendence.
+ (setf *new-auxiliary-types*
+ (remove info *new-auxiliary-types*
+ :test (lambda (a b)
+ (and (eq (first a) (first b))
+ (eq (second a) (second b))))))
(destructuring-bind (kind name defn) info
(macrolet ((frob (kind)
`(let ((old (info :alien-type ,kind name)))
(define-alien-type-class (enum :include (integer (bits 32))
:include-args (signed))
name ; name of this enum (if any)
- from ; alist from keywords to integers
- to ; alist or vector from integers to keywords
+ from ; alist from symbols to integers
+ to ; alist or vector from integers to symbols
kind ; kind of from mapping, :VECTOR or :ALIST
offset) ; offset to add to value for :VECTOR from mapping
(values (first el) (second el))
(values el (1+ prev)))
(setf prev val)
- (unless (keywordp sym)
- (error "The enumeration element ~S is not a keyword." sym))
+ (unless (symbolp sym)
+ (error "The enumeration element ~S is not a symbol." sym))
(unless (integerp val)
(error "The element value ~S is not an integer." val))
(unless (and max (> max val)) (setq max val))
;; If range is at least 20% dense, use vector mapping. Crossover
;; point solely on basis of space would be 25%. Vector mapping
;; is always faster, so give the benefit of the doubt.
- ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
+ ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min)))))
;; If offset is small and ignorable, ignore it to save time.
(when (< 0 min 10) (setq min 0))
(let ((to (make-array (1+ (- max min)))))
(:alist
`(ecase ,alien
,@(mapcar (lambda (mapping)
- `(,(car mapping) ,(cdr mapping)))
+ `(,(car mapping) ',(cdr mapping)))
(alien-enum-type-to type))))))
(define-alien-type-method (enum :deport-gen) (type value)
(define-alien-type-translator union (name &rest fields &environment env)
(parse-alien-record-type :union name fields env))
+;;; FIXME: This is really pretty horrible: we avoid creating new
+;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the
+;;; system already. This way forwrd-references sans fields get get
+;;; "updated" for free to contain the field info. Maybe rename
+;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use
+;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729
(defun parse-alien-record-type (kind name fields env)
(declare (type (or sb!kernel:lexenv null) env))
(cond (fields
(let* ((old (and name (auxiliary-alien-type kind name env)))
(old-fields (and old (alien-record-type-fields old))))
- (cond (old-fields
- ;; KLUDGE: We can't easily compare the new fields
- ;; against the old fields, since the old fields have
- ;; already been parsed into an internal
- ;; representation, so we just punt, assuming that
- ;; they're consistent. -- WHN 200000505
- #|
- (unless (equal fields old-fields)
- ;; FIXME: Perhaps this should be a warning, and we
- ;; should overwrite the old definition and proceed?
- (error "mismatch in fields for ~S~% old ~S~% new ~S"
- name old-fields fields))
- |#
- old)
- (t
- (let ((new (make-alien-record-type :name name
- :kind kind)))
- (when name
- (setf (auxiliary-alien-type kind name env) new))
- (parse-alien-record-fields new fields env)
- new)))))
+ ;; KLUDGE: We can't easily compare the new fields
+ ;; against the old fields, since the old fields have
+ ;; already been parsed into an internal
+ ;; representation, so we just punt, assuming that
+ ;; they're consistent. -- WHN 200000505
+ #|
+ (unless (equal fields old-fields)
+ ;; FIXME: Perhaps this should be a warning, and we
+ ;; should overwrite the old definition and proceed?
+ (error "mismatch in fields for ~S~% old ~S~% new ~S"
+ name old-fields fields))
+ |#
+ (if old-fields
+ old
+ (let ((type (or old (make-alien-record-type :name name :kind kind))))
+ (when (and name (not old))
+ (setf (auxiliary-alien-type kind name env) type))
+ (parse-alien-record-fields type fields env)
+ type))))
(name
(or (auxiliary-alien-type kind name env)
(setf (auxiliary-alien-type kind name env)
(list (alien-record-field-bits field)))))
(alien-record-type-fields type)))))
-;;; Test the record fields. The depth is limiting in case of cyclic
-;;; pointers.
-(defun record-fields-match (fields1 fields2 depth)
- (declare (type list fields1 fields2)
- (type (mod 64) depth))
- (labels ((record-type-= (type1 type2 depth)
- (and (eq (alien-record-type-name type1)
- (alien-record-type-name type2))
- (eq (alien-record-type-kind type1)
- (alien-record-type-kind type2))
- (= (length (alien-record-type-fields type1))
- (length (alien-record-type-fields type2)))
- (record-fields-match (alien-record-type-fields type1)
- (alien-record-type-fields type2)
- (1+ depth))))
- (pointer-type-= (type1 type2 depth)
- (let ((to1 (alien-pointer-type-to type1))
- (to2 (alien-pointer-type-to type2)))
- (if to1
- (if to2
- (type-= to1 to2 (1+ depth))
- nil)
- (null to2))))
- (type-= (type1 type2 depth)
- (cond ((and (alien-pointer-type-p type1)
- (alien-pointer-type-p type2))
- (or (> depth 10)
- (pointer-type-= type1 type2 depth)))
- ((and (alien-record-type-p type1)
- (alien-record-type-p type2))
- (record-type-= type1 type2 depth))
- (t
- (alien-type-= type1 type2)))))
- (do ((fields1-rem fields1 (rest fields1-rem))
- (fields2-rem fields2 (rest fields2-rem)))
- ((or (eq fields1-rem fields2-rem)
- (endp fields1-rem) (endp fields2-rem))
- (eq fields1-rem fields2-rem))
- (let ((field1 (first fields1-rem))
- (field2 (first fields2-rem)))
- (declare (type alien-record-field field1 field2))
- (unless (and (eq (alien-record-field-name field1)
- (alien-record-field-name field2))
- (eql (alien-record-field-bits field1)
- (alien-record-field-bits field2))
- (eql (alien-record-field-offset field1)
- (alien-record-field-offset field2))
- (let ((field1 (alien-record-field-type field1))
- (field2 (alien-record-field-type field2)))
- (type-= field1 field2 (1+ depth))))
- (return nil))))))
+;;; Test the record fields. Keep a hashtable table of already compared
+;;; types to detect cycles.
+(defun record-fields-match-p (field1 field2)
+ (and (eq (alien-record-field-name field1)
+ (alien-record-field-name field2))
+ (eql (alien-record-field-bits field1)
+ (alien-record-field-bits field2))
+ (eql (alien-record-field-offset field1)
+ (alien-record-field-offset field2))
+ (alien-type-= (alien-record-field-type field1)
+ (alien-record-field-type field2))))
+
+(defvar *alien-type-matches* nil
+ "A hashtable used to detect cycles while comparing record types.")
(define-alien-type-method (record :type=) (type1 type2)
(and (eq (alien-record-type-name type1)
(alien-record-type-name type2))
(eq (alien-record-type-kind type1)
(alien-record-type-kind type2))
- (= (length (alien-record-type-fields type1))
- (length (alien-record-type-fields type2)))
- (record-fields-match (alien-record-type-fields type1)
- (alien-record-type-fields type2) 0)))
+ (eql (alien-type-bits type1)
+ (alien-type-bits type2))
+ (eql (alien-type-alignment type1)
+ (alien-type-alignment type2))
+ (flet ((match-fields (&optional old)
+ (setf (gethash type1 *alien-type-matches*) (cons type2 old))
+ (every #'record-fields-match-p
+ (alien-record-type-fields type1)
+ (alien-record-type-fields type2))))
+ (if *alien-type-matches*
+ (let ((types (gethash type1 *alien-type-matches*)))
+ (or (memq type2 types) (match-fields types)))
+ (let ((*alien-type-matches* (make-hash-table :test #'eq)))
+ (match-fields))))))
\f
;;;; the FUNCTION and VALUES alien types