diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 7e8a76dec7345bbfe874fcdfc8ef866201ce7546..d8503a0dbcb87ae40878e02a28964b3344246459 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.15 1999/05/30 23:13:52 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.16 2000/08/03 16:58:55 pw Exp $") ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -118,11 +118,6 @@ classes))) (defun bootstrap-meta-braid () - (let* ((name 'class) - (predicate-name (make-type-predicate-name name))) - (setf (gdefinition predicate-name) - #'(lambda (x) (declare (ignore x)) t)) - (do-satisfies-deftype name predicate-name)) (let* ((*create-classes-from-internal-structure-definitions-p* nil) std-class-wrapper std-class standard-class-wrapper standard-class diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index d100677f2c61fca3c6ea149394271337c8ca1b63..6acc74e8a74531f54936a8d4fcbedb7daf54a250 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.17 2000/07/01 22:03:03 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.18 2000/08/03 16:58:56 pw Exp $") ;;; (in-package :pcl) @@ -160,7 +160,10 @@ (progn (when (and (eq *boot-state* 'complete) (not (member 'compile *defclass-times*))) - (inform-type-system-about-std-class name)) + (when (eq metaclass 'standard-class) + ;; a funcallable-standard-class metaclass here causes + ;; a compiler crash in construct.lisp + (inform-type-system-about-std-class name))) defclass-form))))))) (defun make-initfunction (initform) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index d2fe7296c50da138df97f7ca9ac37ecc84e1f0f2..d4ecb609d7b006955c7585dc4754372b2ff964de 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -70,7 +70,7 @@ ;;; ;;; If symbol names a function which is traced or advised, redefine ;;; the `real' definition without affecting the advise. -;;; +;; (defun (setf gdefinition) (new-definition name) (c::%%defun name new-definition nil) (c::note-name-defined name :function) @@ -181,22 +181,21 @@ (specializer-type (class-eq-specializer class))) (defun inform-type-system-about-std-class (name) - (let ((predicate-name (make-type-predicate-name name))) - (setf (gdefinition predicate-name) (make-type-predicate name)) - (do-satisfies-deftype name predicate-name))) - -(defun make-type-predicate (name) - (let ((cell (find-class-cell name))) - #'(lambda (x) - (funcall (the function (find-class-cell-predicate cell)) x)))) + ;; This should only be called if metaclass is standard-class. + ;; Compiler problems have been seen if the metaclass is + ;; funcallable-standard-class and this is called from the defclass macro + ;; expander. However, bootstrap-meta-braid calls this for funcallable- + ;; standard-class metaclasses but *boot-state* is not 'complete then. + ;; + ;; The only effect of this code is to ensure a lisp:standard-class class + ;; exists so as to avoid undefined-function compiler warnings. The + ;; skeleton class will be replaced at load-time with the correct object. + ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs. - -;This stuff isn't right. Good thing it isn't used. -;The satisfies predicate has to be a symbol. There is no way to -;construct such a symbol from a class object if class names change. -(defun class-predicate (class) - (when (symbolp class) (setq class (find-class class))) - #'(lambda (object) (memq class (class-precedence-list (class-of object))))) + (when (and (eq *boot-state* 'complete) + (null (lisp:find-class name nil))) + (setf (lisp:find-class name) + (lisp::make-standard-class :name name)))) (defun make-class-eq-predicate (class) (when (symbolp class) (setq class (find-class class))) @@ -272,23 +271,6 @@ (t (subtypep (convert-to-system-type type1) (convert-to-system-type type2)))))))) - -(defun do-satisfies-deftype (name predicate) - (declare (ignore name predicate))) - -(defun make-type-predicate-name (name &optional kind) - (if (symbol-package name) - (intern (format nil - "~@[~A ~]TYPE-PREDICATE ~A ~A" - kind - (package-name (symbol-package name)) - (symbol-name name)) - *the-pcl-package*) - (make-symbol (format nil - "~@[~A ~]TYPE-PREDICATE ~A" - kind - (symbol-name name))))) - (defvar *built-in-class-symbols* ()) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index c9b2fa7dc4679e597e3e2cc7fa7154428bf27180..c6899694489dc5ead0f1090d620859fbbc78b683 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.25 1999/05/30 23:14:08 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.26 2000/08/03 16:58:56 pw Exp $") ;;; (in-package :pcl) @@ -992,9 +992,8 @@ ;;;; inform-type-system-about-class -;;;; make-type-predicate ;;; -;;; These are NOT part of the standard protocol. They are internal mechanism +;;; This is NOT part of the standard protocol. It is an internal mechanism ;;; which PCL uses to *try* and tell the type system about class definitions. ;;; In a more fully integrated implementation of CLOS, the type system would ;;; know about class objects and class names in a more fundamental way and @@ -1002,7 +1001,16 @@ ;;; different. ;;; (defmethod inform-type-system-about-class ((class std-class) name) + ;; Maybe add skeleton lisp:standard-class to avoid undefined-function + ;; compiler warnings. Not otherwise needed in this implementation. (inform-type-system-about-std-class name)) + +(defmethod inform-type-system-about-class + ((class funcallable-standard-class) name) + (declare (ignore name)) + ;; Avoid load-time warning of changing metaclass. + ) + (defmethod compatible-meta-class-change-p (class proto-new-class)