From: Christophe Rhodes Date: Sat, 19 Apr 2003 13:14:45 +0000 (+0000) Subject: 0.pre8.74: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=015c86a5eaaa3d2490d221ae56ffec36d2007529;p=sbcl.git 0.pre8.74: Couple the classes and type systems some more ... forward-referenced-classes are now valid types. Note: this fix follows the cmucl fix perhaps slightly too closely. It creates CLASSOIDs for forward-referenced-classes slightly eagerly, where previously no such CLASSOID was generated. This may have some as-yet unnoticed effect. --- diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 87fded0..bd6e0ef 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -261,6 +261,7 @@ (set-slot (slot-name value) (!bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) + (set-slot 'finalized-p t) (set-slot 'source source) (set-slot 'type (if (eq class (find-class t)) t diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index fc92326..d53c674 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -241,35 +241,36 @@ ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects. (defun make-wrapper (length class) (cond - ((typep class 'std-class) - (make-wrapper-internal - :length length - :classoid - (let ((owrap (class-wrapper class))) - (cond (owrap - (layout-classoid owrap)) - ((*subtypep (class-of class) - *the-class-standard-class*) - (cond ((and *pcl-class-boot* - (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (find-classoid - (slot-value class 'name)))) - (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) - (aver (eq (classoid-pcl-class found) class)) - found)) - (t - (make-standard-classoid :pcl-class class)))) - (t - (make-random-pcl-classoid :pcl-class class)))))) - (t - (let* ((found (find-classoid (slot-value class 'name))) - (layout (classoid-layout found))) - (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) - (aver (eq (classoid-pcl-class found) class)) - (aver layout) - layout)))) + ((or (typep class 'std-class) + (typep class 'forward-referenced-class)) + (make-wrapper-internal + :length length + :classoid + (let ((owrap (class-wrapper class))) + (cond (owrap + (layout-classoid owrap)) + ((or (*subtypep (class-of class) *the-class-standard-class*) + (typep class 'forward-referenced-class)) + (cond ((and *pcl-class-boot* + (eq (slot-value class 'name) *pcl-class-boot*)) + (let ((found (find-classoid + (slot-value class 'name)))) + (unless (classoid-pcl-class found) + (setf (classoid-pcl-class found) class)) + (aver (eq (classoid-pcl-class found) class)) + found)) + (t + (make-standard-classoid :pcl-class class)))) + (t + (make-random-pcl-classoid :pcl-class class)))))) + (t + (let* ((found (find-classoid (slot-value class 'name))) + (layout (classoid-layout found))) + (unless (classoid-pcl-class found) + (setf (classoid-pcl-class found) class)) + (aver (eq (classoid-pcl-class found) class)) + (aver layout) + layout)))) (defconstant +first-wrapper-cache-number-index+ 0) diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp index f64d72a..fd09bfd 100644 --- a/src/pcl/cpl.lisp +++ b/src/pcl/cpl.lisp @@ -96,7 +96,8 @@ ((and (null supers) (not (forward-referenced-class-p class))) (list class)) - ((and (null (cdr supers)) + ((and (car supers) + (null (cdr supers)) (not (forward-referenced-class-p (car supers)))) (cons class (compute-std-cpl (car supers) @@ -119,7 +120,9 @@ (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) - (if (forward-referenced-class-p c) + (declare (special *allow-forward-referenced-classes-in-cpl-p*)) + (if (and (forward-referenced-class-p c) + (not *allow-forward-referenced-classes-in-cpl-p*)) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 515a222..f11ff95 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -516,7 +516,10 @@ :initform (cons nil nil)) (predicate-name :initform nil - :reader class-predicate-name))) + :reader class-predicate-name) + (finalized-p + :initform nil + :reader class-finalized-p))) (def!method make-load-form ((class class) &optional env) ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 8dd2df7..44c4127 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -87,9 +87,6 @@ (defmacro find-class-cell-predicate (cell) `(cadr ,cell)) -(defmacro find-class-cell-make-instance-function-keys (cell) - `(cddr ,cell)) - (defmacro make-find-class-cell (class-name) (declare (ignore class-name)) '(list* nil #'constantly-nil nil)) @@ -165,18 +162,21 @@ (find-class-from-cell ',symbol ,class-cell nil)))))) form)) -(defun (setf find-class) (new-value symbol) - (if (legal-class-name-p symbol) - (let ((cell (find-class-cell symbol))) +(defun (setf find-class) (new-value name &optional errorp environment) + (declare (ignore errorp environment)) + (if (legal-class-name-p name) + (let ((cell (find-class-cell name))) (setf (find-class-cell-class cell) new-value) + (when (and (eq *boot-state* 'complete) (null new-value)) + (setf (find-classoid name) nil)) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) (when (and new-value (class-wrapper new-value)) (setf (find-class-cell-predicate cell) (fdefinition (class-predicate-name new-value)))) - (update-ctors 'setf-find-class :class new-value :name symbol)) + (update-ctors 'setf-find-class :class new-value :name name)) new-value) - (error "~S is not a legal class name." symbol))) + (error "~S is not a legal class name." name))) (/show "pcl/macros.lisp 230") diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 06d0779..34a1d5a 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -151,10 +151,6 @@ ;;;; various class accessors that are a little more complicated than can be ;;;; done with automatically generated reader methods -(defmethod class-finalized-p ((class pcl-class)) - (with-slots (wrapper) class - (not (null wrapper)))) - (defmethod class-prototype ((class std-class)) (with-slots (prototype) class (or prototype (setq prototype (allocate-instance class))))) @@ -354,12 +350,11 @@ (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) + (error "~S is not a class or a legal class name." s)) (t - (or (find-class s nil) - (setf (find-class s) - (make-instance 'forward-referenced-class - :name s)))))) + (or (find-class s nil) + (make-instance 'forward-referenced-class + :name s))))) (defun ensure-class-values (class args) (let* ((initargs (copy-list args)) @@ -510,7 +505,49 @@ (add-direct-subclasses class direct-superclasses) (make-class-predicate class predicate-name) (update-class class nil) - (add-slot-accessors class direct-slots)) + (add-slot-accessors class direct-slots) + (make-preliminary-layout class)) + +(defmethod shared-initialize :after ((class forward-referenced-class) + slot-names &key &allow-other-keys) + (declare (ignore slot-names)) + (make-preliminary-layout class)) + +(defvar *allow-forward-referenced-classes-in-cpl-p* nil) + +;;; Give CLASS a preliminary layout if it doesn't have one already, to +;;; make it known to the type system. +(defun make-preliminary-layout (class) + (flet ((compute-preliminary-cpl (root) + (let ((*allow-forward-referenced-classes-in-cpl-p* t)) + (compute-class-precedence-list root)))) + (unless (class-finalized-p class) + (let ((name (class-name class))) + (setf (find-class name) class) + ;; KLUDGE: This is fairly horrible. We need to make a + ;; full-fledged CLASSOID here, not just tell the compiler that + ;; some class is forthcoming, because there are legitimate + ;; questions one can ask of the type system, implemented in + ;; terms of CLASSOIDs, involving forward-referenced classes. So. + (when (and (eq *boot-state* 'complete) + (null (find-classoid name nil))) + (setf (find-classoid name) + (make-standard-classoid :name name))) + (set-class-type-translation class name) + (let ((layout (make-wrapper 0 class)) + (classoid (find-classoid name))) + (setf (layout-classoid layout) classoid) + (setf (classoid-pcl-class classoid) class) + (setf (slot-value class 'wrapper) layout) + (let ((cpl (compute-preliminary-cpl class))) + (setf (layout-inherits layout) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) + (register-layout layout :invalidate t) + (setf (classoid-layout classoid) layout) + (mapc #'make-preliminary-layout (class-direct-subclasses class))))))) + (defmethod shared-initialize :before ((class class) slot-names &key name) (declare (ignore slot-names name)) @@ -538,6 +575,7 @@ (with-slots (wrapper class-precedence-list prototype predicate-name (direct-supers direct-superclasses)) class + (setf (slot-value class 'finalized-p) t) (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) @@ -660,6 +698,7 @@ (let ((lclass (find-classoid (class-name class)))) (setf (classoid-pcl-class lclass) class) (setf (slot-value class 'wrapper) (classoid-layout lclass))) + (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) @@ -794,8 +833,10 @@ :key #'slot-definition-location))) (nslots (length nlayout)) (nwrapper-class-slots (compute-class-slots class-slots)) - (owrapper (class-wrapper class)) - (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) + (owrapper (when (class-finalized-p class) + (class-wrapper class))) + (olayout (when owrapper + (wrapper-instance-slots-layout owrapper))) (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) (nwrapper (cond ((null owrapper) @@ -822,7 +863,7 @@ (wrapper-class-slots nwrapper) nwrapper-class-slots (wrapper-no-of-instance-slots nwrapper) nslots wrapper nwrapper)) - + (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) (update-pv-table-cache-info class))))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 22dc62b..b437d76 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -588,5 +588,15 @@ (assert (= (something-that-specializes (make-instance 'other-name-for-class)) 2)) +;;; more forward referenced classes stuff +(defclass frc-1 (frc-2) ()) +(assert (subtypep 'frc-1 (find-class 'frc-2))) +(assert (subtypep (find-class 'frc-1) 'frc-2)) +(assert (not (subtypep (find-class 'frc-2) 'frc-1))) +(defclass frc-2 (frc-3) ((a :initarg :a))) +(assert (subtypep 'frc-1 (find-class 'frc-3))) +(defclass frc-3 () ()) +(assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1))) +(assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2))) ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 07c9d6b..4f508fa 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.73" +"0.pre8.74"