Skip to content
Snippets Groups Projects
Commit b9438fc8 authored by ram's avatar ram
Browse files

Fix up FIN type testing, and sealed classes in general.

parent b072052c
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.15 1993/02/26 08:39:29 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.16 1993/03/13 14:38:11 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -340,27 +340,33 @@ ...@@ -340,27 +340,33 @@
;;; SOURCE-TRANSFORM-INSTANCE-TYPEP -- Internal ;;; SOURCE-TRANSFORM-INSTANCE-TYPEP -- Internal
;;; ;;;
;;; Transform a type test against some instance type. If not properly ;;; Transform a type test against some instance type. If not properly
;;; named, error. If a structure, call S-T-STRUCTURE-TYPEP. Otherwise, call ;;; named, error. If sealed and has no subclasses, just test for layout-EQ.
;;; CLASS-TYPEP at run-time with the layout and class object. ;;; If a structure, call S-T-STRUCTURE-TYPEP. Otherwise, call CLASS-TYPEP at
;;; run-time with the layout and class object.
;;; ;;;
(defun source-transform-instance-typep (obj class) (defun source-transform-instance-typep (obj class)
(let* ((name (class-name class)) (let* ((name (class-name class))
(layout (info type compiler-layout name))) (layout (let ((res (info type compiler-layout name)))
(cond (if (and res
((not (and name (eq (find-class name) class))) (member (layout-invalid res) '(:compiler nil)))
(compiler-error "Can't compile TYPEP of anonymous or undefined ~ res
class:~% ~S" nil))))
class)) (multiple-value-bind
((and (structure-class-p class) (pred get-layout)
layout (if (csubtypep class (specifier-type 'funcallable-instance))
(member (layout-invalid layout) '(:compiler nil))) (values 'funcallable-instance-p '%funcallable-instance-layout)
(source-transform-structure-typep obj layout)) (values '%instancep '%instance-layout))
(t (cond
(multiple-value-bind ((not (and name (eq (find-class name) class)))
(pred layout) (compiler-error "Can't compile TYPEP of anonymous or undefined ~
(if (csubtypep class (specifier-type 'generic-function)) class:~% ~S"
(values 'funcallable-instance-p 'funcallable-instance-layout) class))
(values '%instancep '%instance-layout)) ((and (eq (class-state class) :sealed) layout
(not (class-subclasses class)))
(source-transform-sealed-typep obj layout pred get-layout))
((and (typep class 'basic-structure-class) layout)
(source-transform-structure-typep obj layout pred get-layout))
(t
(once-only ((object obj)) (once-only ((object obj))
`(and (,pred ,object) `(and (,pred ,object)
(class-typep (,layout ,object) ',class)))))))) (class-typep (,layout ,object) ',class))))))))
...@@ -369,30 +375,41 @@ ...@@ -369,30 +375,41 @@
;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP -- Internal ;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP -- Internal
;;; ;;;
;;; Transform a call to an actual structure type predicate with the ;;; Transform a call to an actual structure type predicate with the
;;; specified layout. If sealed and has no subclasses, just test for ;;; specified layout. Do the EQ test and then a general test based on
;;; layout-EQ, otherwise do the EQ test and then a general test based on
;;; layout-inherits. If safety is important, then we also check if the layout ;;; layout-inherits. If safety is important, then we also check if the layout
;;; for the object is invalid and signal an error if so. ;;; for the object is invalid and signal an error if so.
;;; ;;;
(defun source-transform-structure-typep (obj layout) (defun source-transform-structure-typep (obj layout pred get-layout)
(let ((class (layout-class layout)) (let ((class (layout-class layout))
(idepth (layout-inheritance-depth layout)) (idepth (layout-inheritance-depth layout))
(n-layout (gensym))) (n-layout (gensym)))
(once-only ((object obj)) (once-only ((object obj))
`(and (%instancep ,object) `(and (,pred ,object)
(let ((,n-layout (%instance-layout ,object))) (let ((,n-layout (,get-layout ,object)))
,@(when (policy nil (>= safety speed)) ,@(when (policy nil (>= safety speed))
`((when (layout-invalid ,n-layout) `((when (layout-invalid ,n-layout)
(%layout-invalid-error ,object ',layout)))) (%layout-invalid-error ,object ',layout))))
,(if (and (eq (class-state class) :sealed) (if (eq ,n-layout ',layout)
(not (class-subclasses class))) t
`(eq ,n-layout ',layout) (and (> (layout-inheritance-depth ,n-layout) ,idepth)
`(if (eq ,n-layout ',layout) (locally (declare (optimize (safety 0)))
t (eq (svref (layout-inherits ,n-layout) ,idepth)
(and (> (layout-inheritance-depth ,n-layout) ,idepth) ',layout)))))))))
(locally (declare (optimize (safety 0)))
(eq (svref (layout-inherits ,n-layout) ,idepth)
',layout)))))))))) ;;; SOURCE-TRANSFORM-SEALED-TYPEP -- Internal
;;;
;;; Transform a typep test of any sealed class w/ no subclasses.
;;;
(defun source-transform-sealed-typep (obj layout pred get-layout)
(let ((n-layout (gensym)))
(once-only ((object obj))
`(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))))))
;;; Source-Transform-Typep -- Internal ;;; Source-Transform-Typep -- Internal
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment