From b9438fc81fdbeb35d782907cb6ca60a0f2a8c812 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sat, 13 Mar 1993 14:38:11 +0000 Subject: [PATCH] Fix up FIN type testing, and sealed classes in general. --- compiler/typetran.lisp | 83 +++++++++++++++++++++++++----------------- 1 file changed, 50 insertions(+), 33 deletions(-) diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index a147a3482..a004a7c04 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (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 @@ ;;; SOURCE-TRANSFORM-INSTANCE-TYPEP -- Internal ;;; ;;; Transform a type test against some instance type. If not properly -;;; named, error. If a structure, call S-T-STRUCTURE-TYPEP. Otherwise, call -;;; CLASS-TYPEP at run-time with the layout and class object. +;;; named, error. If sealed and has no subclasses, just test for layout-EQ. +;;; 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) (let* ((name (class-name class)) - (layout (info type compiler-layout name))) - (cond - ((not (and name (eq (find-class name) class))) - (compiler-error "Can't compile TYPEP of anonymous or undefined ~ - class:~% ~S" - class)) - ((and (structure-class-p class) - layout - (member (layout-invalid layout) '(:compiler nil))) - (source-transform-structure-typep obj layout)) - (t - (multiple-value-bind - (pred layout) - (if (csubtypep class (specifier-type 'generic-function)) - (values 'funcallable-instance-p 'funcallable-instance-layout) - (values '%instancep '%instance-layout)) + (layout (let ((res (info type compiler-layout name))) + (if (and res + (member (layout-invalid res) '(:compiler nil))) + res + nil)))) + (multiple-value-bind + (pred get-layout) + (if (csubtypep class (specifier-type 'funcallable-instance)) + (values 'funcallable-instance-p '%funcallable-instance-layout) + (values '%instancep '%instance-layout)) + (cond + ((not (and name (eq (find-class name) class))) + (compiler-error "Can't compile TYPEP of anonymous or undefined ~ + class:~% ~S" + class)) + ((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)) `(and (,pred ,object) (class-typep (,layout ,object) ',class)))))))) @@ -369,30 +375,41 @@ ;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP -- Internal ;;; ;;; Transform a call to an actual structure type predicate with the -;;; specified layout. If sealed and has no subclasses, just test for -;;; layout-EQ, otherwise do the EQ test and then a general test based on +;;; specified layout. Do the EQ test and then a general test based on ;;; layout-inherits. If safety is important, then we also check if the layout ;;; 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)) (idepth (layout-inheritance-depth layout)) (n-layout (gensym))) (once-only ((object obj)) - `(and (%instancep ,object) - (let ((,n-layout (%instance-layout ,object))) + `(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 (and (eq (class-state class) :sealed) - (not (class-subclasses class))) - `(eq ,n-layout ',layout) - `(if (eq ,n-layout ',layout) - t - (and (> (layout-inheritance-depth ,n-layout) ,idepth) - (locally (declare (optimize (safety 0))) - (eq (svref (layout-inherits ,n-layout) ,idepth) - ',layout)))))))))) + (if (eq ,n-layout ',layout) + t + (and (> (layout-inheritance-depth ,n-layout) ,idepth) + (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 -- GitLab