diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 354937ea531fd5099a0a7771c9a3f8250c955cf4..eb135a1a4f53f30b29f4f024bfbe7787daca39af 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.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/dump.lisp,v 1.47 1993/01/13 18:09:43 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.47.1.1 1993/01/15 15:30:50 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 374a37f15cd4094089a7bd706ae9fb8b191c31b2..a75a7754f54045190292f4e0786fda5888e40094 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.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/ir1tran.lisp,v 1.83 1992/12/10 16:48:17 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.1 1993/01/15 15:31:34 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -302,10 +302,10 @@ ((array t) (dotimes (i (array-total-size value)) (grovel (row-major-aref value i)))) - (structure + (instance (when (emit-make-load-form value) - (dotimes (i (structure-length value)) - (grovel (structure-ref value i))))) + (dotimes (i (%instance-length value)) + (grovel (%instance-ref value i))))) (t (compiler-error "Cannot dump objects of type ~S into fasl files." @@ -2586,7 +2586,7 @@ form))))) (unless ignore - (funcall #'%proclaim form)) + (%proclaim form)) (if ignore (ir1-convert start cont nil) (ir1-convert start cont `(%proclaim ,what))))) @@ -2596,12 +2596,14 @@ ;;; %Compiler-Defstruct IR1 Convert -- Internal ;;; ;;; This is a frob that DEFMACRO expands into to establish the compiler -;;; semantics. %%COMPILER-DEFSTRUCT does most of the work, we just clear all -;;; of the functions out of *FREE-FUNCTIONS* to keep things in synch. +;;; semantics. %COMPILER-ONLY-DEFSTRUCT and %%COMPILER-DEFSTRUCT do most of +;;; the work, we just clear all of the functions out of *FREE-FUNCTIONS* to +;;; keep things in synch. %%COMPILER-DEFSTRUCT is also called at load-time. ;;; (def-ir1-translator %compiler-defstruct ((info) start cont :kind :function) (let* ((info (eval info))) - (funcall #'%%compiler-defstruct info) + (%compiler-only-defstruct info) + (%%compiler-defstruct info) (dolist (slot (dd-slots info)) (let ((fun (dsd-accessor slot))) (remhash fun *free-functions*) diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index fcf49db2876197ddd85580d56fe8c68c97c34ee2..e291e0fbf1152e4afc695fad2153b0cfe5eeb7b0 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.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/proclaim.lisp,v 1.26 1992/09/15 16:10:16 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.26.1.1 1993/01/15 15:31:55 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -390,189 +390,6 @@ ;;; (setf (symbol-function 'proclaim) #'%proclaim) - -;;; UNDEFINE-STRUCTURE -- Interface -;;; -;;; Blow away all the compiler info for the structure described by Info. -;;; This recursively descends the inheritance hierarchy. -;;; -(defun undefine-structure (info) - (declare (type defstruct-description info)) - (let* ((name (dd-name info)) - (all-types (cons name (dd-included-by info)))) - ;; - ;; Iterate over this type and all subtypes, clearing the compiler structure - ;; type info, and undefining all the associated functions. - (dolist (type all-types) - (let ((this-info (info type structure-info type))) - (setf (info type kind type) nil) - (setf (info type structure-info type) nil) - (setf (info type frozen type) nil) - (undefine-function-name (dd-copier this-info)) - (undefine-function-name (dd-predicate this-info)) - (dolist (slot (dd-slots this-info)) - (let ((fun (dsd-accessor slot))) - (undefine-function-name fun) - (unless (dsd-read-only slot) - (undefine-function-name `(setf ,fun))))))) - ;; - ;; Iterate over all types that include this type, removing this type and - ;; all subtypes from the list of subtypes of the included type. We copy - ;; the DD and included list so that we don't clobber the type in the - ;; compiler's Lisp. - (dolist (include (dd-includes info)) - (let ((new (copy-defstruct-description - (info type structure-info include)))) - (setf (dd-included-by new) - (set-difference (dd-included-by new) all-types)) - (setf (info type structure-info include) new)))) - ;; - ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are - ;; unknown types. - (values-specifier-type-cache-clear) - (undefined-value)) - - -;;; DEFINE-DEFSTRUCT-NAME -- Internal -;;; -;;; Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and -;;; blow away any ASSUMED-TYPE. Also, if the thing is a slot accessor -;;; currently, quietly unaccessorize it. And if there are any undefined -;;; warnings, we nuke them. -;;; -(defun define-defstruct-name (name) - (when name - (when (info function accessor-for name) - (setf (info function accessor-for name) nil)) - (define-function-name name) - (note-name-defined name :function) - (setf (info function where-from name) :declared) - (when (info function assumed-type name) - (setf (info function assumed-type name) nil))) - (undefined-value)) - - -;;; FREEZE-STRUCTURE-TYPE -- Internal -;;; -;;; Freeze the named structure type and all its inferiors. -;;; -(defun freeze-structure-type (name) - (let ((def (info type structure-info name))) - (when def - (setf (info type frozen name) t) - (dolist (incl (dd-included-by def)) - (setf (info type frozen incl) t)))) - (undefined-value)) - - -;;; CHECK-FOR-STRUCTURE-REDEFINITION -- Internal -;;; -;;; Called when we process a DEFSTRUCT for a type that is already defined -;;; for a structure. We check for incompatible redefinition and undefine the -;;; old structure if so. We ignore the structures that DEFSTRUCT is built out -;;; of, since they have to be hackishly defined in type-boot. If the structure -;;; is not incompatibly redefined, then we copy the old INCLUDED-BY into the -;;; new structure. -;;; -(defun check-for-structure-redefinition (info) - (declare (type defstruct-description info)) - (let* ((name (dd-name info)) - (old (info type structure-info name))) - (cond ((member name - '(defstruct-description defstruct-slot-description))) - ((and (equal (dd-includes old) (dd-includes info)) - (equalp (dd-slots old) (dd-slots info))) - (setf (dd-included-by info) (dd-included-by old))) - (t - (compiler-warning - "Incompatibly redefining structure ~S.~@ - Removing the old definition~:[.~;~:* and these subtypes:~% ~S~]" - name (dd-included-by old)) - (undefine-structure old)))) - (undefined-value)) - - -;;; ADD-NEW-SUBTYPE -- Internal -;;; -;;; Add a new subtype NAME to the structure type INC. INFO is INC's current -;;; info. -;;; -(defun add-new-subtype (name inc info) - (let ((new (copy-defstruct-description info))) - (setf (info type structure-info inc) new) - (push name (dd-included-by new)) - (when (info type frozen inc) - (compiler-warning "Adding new subtype ~S to frozen type ~S.~@ - Unfreezing this type and its inferiors.~@ - Previously compiled type tests must be recompiled." - name inc) - (setf (info type frozen inc) nil) - (dolist (subtype (dd-included-by info)) - (setf (info type frozen subtype) nil))))) - - -;;; %%Compiler-Defstruct -- Interface -;;; -;;; This function updates the global compiler information to represent the -;;; definition of the the structure described by Info. In addition to defining -;;; all the functions and slots, we also update the INCLUDED-BY info in the -;;; compiler's environment. Note that at the first time the DEFSTRUCT is -;;; loaded, STRUCTURE-INFO is EQ to DEFINED-STRUCTURE-INFO, so the name will -;;; already be in INCLUDED-BY. When we do update this info, we copy the -;;; defstruct description so that the type definition in the compiler's Lisp -;;; isn't trashed. -;;; -(defun %%compiler-defstruct (info) - (declare (type defstruct-description info)) - (let ((name (dd-name info))) - (ecase (info type kind name) - ((nil)) - (:structure - (check-for-structure-redefinition info)) - (:primitive - (compiler-error "Illegal to redefine standard type ~S." name)) - (:defined - (compiler-warning "Redefining DEFTYPE type to be a DEFSTRUCT: ~S." - name) - (setf (info type expander name) nil))) - - (dolist (inc (dd-includes info)) - (let ((info (info type structure-info inc))) - (unless info - (error "Structure type ~S is included by ~S but not defined." - inc name)) - (unless (member name (dd-included-by info)) - (add-new-subtype name inc info)))) - - (setf (info type kind name) :structure) - (setf (info type structure-info name) info) - (%note-type-defined name) - - (let ((copier (dd-copier info))) - (when copier - (%proclaim `(ftype (function (,name) ,name) ,copier)))) - - (let ((pred (dd-predicate info))) - (when pred - (define-defstruct-name pred) - (setf (info function inlinep pred) :inline) - (setf (info function inline-expansion pred) - `(lambda (x) (typep x ',name)))))) - - (dolist (slot (dd-slots info)) - (let* ((fun (dsd-accessor slot)) - (setf-fun `(setf ,fun))) - (when fun - (define-defstruct-name fun) - (setf (info function accessor-for fun) info) - (unless (dsd-read-only slot) - (define-defstruct-name setf-fun) - (setf (info function accessor-for setf-fun) info))))) - (undefined-value)) - -(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct) - - ;;; %NOTE-TYPE-DEFINED -- Interface ;;; ;;; Note that the type Name has been (re)defined, updating the undefined diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 0b081e9c65f1aa50c490f99db21be119bda5b0a3..5d11343d9cdbca69dac33e667fdf4933d668df78 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.14 1992/04/27 19:46:44 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.14.1.1 1993/01/15 15:32:22 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -337,42 +337,62 @@ `(%typep ,obj ',(type-specifier type))))) -;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP -- Internal +;;; SOURCE-TRANSFORM-INSTANCE-TYPEP -- Internal ;;; -;;; If not currently defined as a structure to the compiler (must have been -;;; undefined) or there is no predicate, then we call STRUCTURE-TYPEP. -;;; Otherwise, we do an EQ test for a direct type match, and if that fails, -;;; deal with inherited types. If the type is frozen, we can inline the -;;; supertype check, otherwise we have to call the predicate. +;;; 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. ;;; -(defun source-transform-structure-typep (obj desc) - (let* ((type (structure-type-name desc)) - (def (info type structure-info type))) +(defun source-transform-instance-typep (obj desc) + (let* ((class (instance-type-class desc)) + (name (class-name class)) + (layout (info type compiler-layout name))) (cond - ((not def) - `(lisp::structure-typep ,obj ',type)) - ((not (eq (dd-type def) 'structure)) - (compiler-error "Structure type has :TYPE specified, so it can't ~ - be used as an argument to TYPEP:~% ~S" - type)) + ((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 - (let ((frozen (info type frozen type)) - (included (dd-included-by def)) - (predicate (dd-predicate def)) - (n-name (gensym))) - (if (or frozen predicate) - (once-only ((object obj)) - `(and (structurep ,object) - (let ((,n-name (structure-ref ,object 0))) - (if (eq ,n-name ',type) - t - ,(if frozen - (when included - `(if (member ,n-name ',included :test #'eq) - t nil)) - `(locally (declare (notinline ,predicate)) - (,predicate ,object))))))) - `(lisp::structure-typep ,obj ',type))))))) + (multiple-value-bind + (pred layout) + (if (funcallable-class-p class) + (values 'funcallable-instance-p 'funcallable-instance-layout) + (values '%instancep '%instance-layout)) + (once-only ((object obj)) + `(and (,pred ,object) + (class-typep (,layout ,object) ',class)))))))) + + +;;; 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 +;;; 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) + (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))) + ,@(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) + (eq (svref (layout-inherits ,n-layout) ,idepth) + ',layout))))))))) ;;; Source-Transform-Typep -- Internal @@ -406,8 +426,8 @@ (source-transform-union-typep object type)) (member-type `(member ,object ',(member-type-members type))) - (structure-type - (source-transform-structure-typep object type)) + (instance-type + (source-transform-instance-typep object type)) (args-type (compiler-warning "Illegal type specifier for Typep: ~S." (cadr spec))