- (cond
- ((csubtypep class (specifier-type 'funcallable-instance))
- (values 'funcallable-instance-p '%funcallable-instance-layout))
- ((csubtypep class (specifier-type 'instance))
- (values '%instancep '%instance-layout))
- (t
- (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
- (/noshow pred get-layout)
- (cond
- ((and (eq (class-state class) :sealed) layout
- (not (class-subclasses class)))
- ;; Sealed and has no subclasses.
- (/noshow "sealed and has no subclasses")
- (let ((n-layout (gensym)))
- `(and (,pred object)
- (let ((,n-layout (,get-layout object)))
- ,@(when (policy nil (>= safety speed))
- `((when (layout-invalid ,n-layout)
- (%layout-invalid-error object ',layout))))
- (eq ,n-layout ',layout)))))
- ((and (typep class 'basic-structure-class) layout)
- (/noshow "structure type tests; hierarchical layout depths")
- ;; structure type tests; hierarchical layout depths
- (let ((depthoid (layout-depthoid layout))
- (n-layout (gensym)))
- `(and (,pred object)
- (let ((,n-layout (,get-layout object)))
- ,@(when (policy nil (>= safety speed))
- `((when (layout-invalid ,n-layout)
- (%layout-invalid-error object ',layout))))
- (if (eq ,n-layout ',layout)
- t
- (and (> (layout-depthoid ,n-layout)
- ,depthoid)
- (locally (declare (optimize (safety 0)))
- (eq (svref (layout-inherits ,n-layout)
- ,depthoid)
- ',layout))))))))
- (t
- (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
- `(and (,pred object)
- (class-cell-typep (,get-layout object)
- ',(find-class-cell name)
- object)))))))))
-
-#|
-;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
-;;; which corresponds to the value returned by
-;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
-;;; result might change when we encounter a DEFTYPE.
-(declaim (maybe-inline upgraded-array-element-ctype-2))
-(defun upgraded-array-element-ctype-2 (spec)
- (let ((ctype (specifier-type `(array ,spec))))
- (values (array-type-specialized-element-type
- (specifier-type `(array ,spec)))
- (not (unknown-type-p (array-type-element-type ctype))))))
-|#
+ (cond
+ ((csubtypep class (specifier-type 'funcallable-instance))
+ (values 'funcallable-instance-p '%funcallable-instance-layout))
+ ((csubtypep class (specifier-type 'instance))
+ (values '%instancep '%instance-layout))
+ (t
+ (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
+ (cond
+ ((and (eq (classoid-state class) :sealed) layout
+ (not (classoid-subclasses class)))
+ ;; Sealed and has no subclasses.
+ (let ((n-layout (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ ,@(when (policy *lexenv* (>= safety speed))
+ `((when (layout-invalid ,n-layout)
+ (%layout-invalid-error object ',layout))))
+ (eq ,n-layout ',layout)))))
+ ((and (typep class 'structure-classoid) layout)
+ ;; structure type tests; hierarchical layout depths
+ (let ((depthoid (layout-depthoid layout))
+ (n-layout (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ ;; we used to check for invalid layouts here,
+ ;; but in fact that's both unnecessary and
+ ;; wrong; it's unnecessary because structure
+ ;; classes can't be redefined, and it's wrong
+ ;; because it is quite legitimate to pass an
+ ;; object with an invalid layout to a structure
+ ;; type test.
+ (if (eq ,n-layout ',layout)
+ t
+ (and (> (layout-depthoid ,n-layout)
+ ,depthoid)
+ (locally (declare (optimize (safety 0)))
+ ;; Use DATA-VECTOR-REF directly,
+ ;; since that's what SVREF in a
+ ;; SAFETY 0 lexenv will eventually be
+ ;; transformed to. This can give a
+ ;; large compilation speedup, since
+ ;; %INSTANCE-TYPEPs are frequently
+ ;; created during GENERATE-TYPE-CHECKS,
+ ;; and the normal aref transformation path
+ ;; is pretty heavy.
+ (eq (data-vector-ref (layout-inherits ,n-layout)
+ ,depthoid)
+ ',layout))))))))
+ ((and layout (>= (layout-depthoid layout) 0))
+ ;; hierarchical layout depths for other things (e.g.
+ ;; CONDITION, STREAM)
+ (let ((depthoid (layout-depthoid layout))
+ (n-layout (gensym))
+ (n-inherits (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ (when (layout-invalid ,n-layout)
+ (setq ,n-layout (update-object-layout-or-invalid
+ object ',layout)))
+ (if (eq ,n-layout ',layout)
+ t
+ (let ((,n-inherits (layout-inherits ,n-layout)))
+ (declare (optimize (safety 0)))
+ (and (> (length ,n-inherits) ,depthoid)
+ ;; See above.
+ (eq (data-vector-ref ,n-inherits ,depthoid)
+ ',layout))))))))
+ (t
+ (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
+ `(and (,pred object)
+ (classoid-cell-typep (,get-layout object)
+ ',(find-classoid-cell name :create t)
+ object)))))))))