#!+sb-doc
"Return a copy of STRUCTURE with the same (EQL) slot values."
(declare (type structure-object structure))
- (let* ((len (%instance-length structure))
- (res (%make-instance len))
- (layout (%instance-layout structure))
+ (let* ((layout (%instance-layout structure))
+ (res (%make-instance (%instance-length structure)))
+ (len (layout-length layout))
(nuntagged (layout-n-untagged-slots layout)))
(declare (type index len))
;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but
;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP
;; but have different bit patterns. -- JES, 2007-08-21
- (loop with i = -1
- for dsd in (dd-slots (layout-info layout))
+ (loop for dsd in (dd-slots (layout-info layout))
for raw-type = (dsd-raw-type dsd)
- for rsd = (when raw-type
+ for rsd = (unless (eql raw-type t)
(find raw-type
*raw-slot-data-list*
:key 'raw-slot-data-raw-type))
- for accessor = (when rsd
- (raw-slot-data-accessor-name rsd))
- always (or (not accessor)
- (progn
- (incf i)
- (equalp (funcall accessor x i)
- (funcall accessor y i))))))
+ always (or (not rsd)
+ (funcall (raw-slot-data-comparer rsd) (dsd-index dsd) x y))))
\f
;;; default PRINT-OBJECT method
(/nohexstr obj)
(/nohexstr layout)
(when (layout-invalid layout)
- (error "An obsolete structure accessor function was called."))
+ (error "An obsolete structure typecheck function was called."))
(/noshow0 "back from testing LAYOUT-INVALID LAYOUT")
(and (%instancep obj)
(let ((obj-layout (%instance-layout obj)))
- (cond ((eq obj-layout layout)
- ;; (In this case OBJ-LAYOUT can't be invalid, because
- ;; we determined LAYOUT is valid in the test above.)
- (/noshow0 "EQ case")
- t)
- ((layout-invalid obj-layout)
- (/noshow0 "LAYOUT-INVALID case")
- (error 'layout-invalid
- :expected-type (layout-classoid obj-layout)
- :datum obj))
- (t
- (let ((depthoid (layout-depthoid layout)))
- (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
- (/nohexstr depthoid)
- (/nohexstr layout-inherits)
- (and (> (layout-depthoid obj-layout) depthoid)
- (eq (svref (layout-inherits obj-layout) depthoid)
- layout))))))))
+ (when (eq obj-layout layout)
+ ;; (In this case OBJ-LAYOUT can't be invalid, because
+ ;; we determined LAYOUT is valid in the test above.)
+ (/noshow0 "EQ case")
+ (return-from typep-to-layout t))
+ (when (layout-invalid obj-layout)
+ (/noshow0 "LAYOUT-INVALID case")
+ (setf obj-layout (update-object-layout-or-invalid obj layout)))
+ (let ((depthoid (layout-depthoid layout)))
+ (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
+ (/nohexstr depthoid)
+ (/nohexstr layout-inherits)
+ (and (> (layout-depthoid obj-layout) depthoid)
+ (eq (svref (layout-inherits obj-layout) depthoid)
+ layout))))))
\f
;;;; checking structure types