(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)
`(sap+ ,sap (/ ,offset sb!vm:n-byte-bits)))
(define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
- (let ((bits (alien-mem-block-type-bits type)))
- (unless bits
+ (let ((bytes (truncate (alien-mem-block-type-bits type) sb!vm:n-byte-bits)))
+ (unless bytes
(error "can't deposit aliens of type ~S (unknown size)" type))
- `(sb!kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
+ `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes)))
\f
;;;; the ARRAY type
(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
projects / sbcl.git / blobdiff