diff --git a/code/alieneval.lisp b/code/alieneval.lisp index c8b8c04b86302f7e2005e024c2bbe0d43d7f5961..62f2d5d9b1a0cc079b1f7e07be96eb2b257f404c 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.42 1998/01/13 21:16:34 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.43 1998/02/06 19:48:01 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1113,23 +1113,57 @@ (list (alien-record-field-bits field))))) (alien-record-type-fields type))))) -(defun record-fields-match (fields1 fields2) - (declare (type list fields1 fields2)) - (or (eq fields1 fields2) - (and fields1 - fields2 - (let ((field1 (car fields1)) - (field2 (car fields2))) - (declare (type alien-record-field 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)))) - (record-fields-match (cdr fields1) (cdr fields2))))) +;;; 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)))))) (def-alien-type-method (record :type=) (type1 type2) (and (eq (alien-record-type-name type1) @@ -1139,7 +1173,7 @@ (= (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)))) + (alien-record-type-fields type2) 0))) ;;;; The FUNCTION and VALUES types.