From: Christophe R. <cr...@us...> - 2006-07-17 12:28:25
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv25585/src/pcl Modified Files: boot.lisp braid.lisp cache.lisp dfun.lisp fsc.lisp macros.lisp methods.lisp std-class.lisp Log Message: 0.9.14.21: Allow "anonymous" (in the sense of AMOP pp.67-69) classes ... names not necessarily symbols. This entails a great big rearrangement of class finalization and various associated activities; (setf class-name) and (setf find-class) (and their sb-kernel:classoid equivalents) are now slightly less tangled, but the coupling is still non-intuitive: classoids need proper names earlier than classes, as they are used in the compiler transform for TYPEP / DECLARE TYPE, so the ideal of strictly parallel CLASSOID / CLASS is not present, and left for future work. Add tests, both of the new functionality and also for various things that broke along the way, detected by gcl/ansi-tests and from emergent properties of our own test suite. Index: boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v retrieving revision 1.113 retrieving revision 1.114 diff -u -d -r1.113 -r1.114 --- boot.lisp 18 Jun 2006 23:47:58 -0000 1.113 +++ boot.lisp 17 Jul 2006 12:28:13 -0000 1.114 @@ -2025,6 +2025,12 @@ (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ class nor a symbol that names a class." ,gf-class))) + (unless (class-finalized-p ,gf-class) + (if (class-has-a-forward-referenced-superclass-p ,gf-class) + ;; FIXME: reference MOP documentation -- this is an + ;; additional requirement on our users + (error "The generic function class ~S is not finalizeable" ,gf-class) + (finalize-inheritance ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) Index: braid.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v retrieving revision 1.57 retrieving revision 1.58 diff -u -d -r1.57 -r1.58 --- braid.lisp 16 Mar 2006 18:57:18 -0000 1.57 +++ braid.lisp 17 Jul 2006 12:28:13 -0000 1.58 @@ -613,38 +613,43 @@ ;;; Set the inherits from CPL, and register the layout. This actually ;;; installs the class in the Lisp type system. (defun update-lisp-class-layout (class layout) - (let ((lclass (layout-classoid layout))) - (unless (eq (classoid-layout lclass) layout) + (let ((classoid (layout-classoid layout)) + (olayout (class-wrapper class))) + (unless (eq (classoid-layout classoid) layout) (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest (class-precedence-list class)))))) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest (class-precedence-list class)))))) (register-layout layout :invalidate t) - ;; Subclasses of formerly forward-referenced-class may be - ;; unknown to CL:FIND-CLASS and also anonymous. This - ;; functionality moved here from (SETF FIND-CLASS). + ;; FIXME: I don't think this should be necessary, but without it + ;; we are unable to compile (TYPEP foo '<class-name>) in the + ;; same file as the class is defined. If we had environments, + ;; then I think the classsoid whould only be associated with the + ;; name in that environment... Alternatively, fix the compiler + ;; so that TYPEP foo '<class-name> is slow but compileable. (let ((name (class-name class))) - (setf (find-classoid name) lclass - (classoid-name lclass) name))))) + (when (and name (symbolp name) (eq name (classoid-name classoid))) + (setf (find-classoid name) classoid)))))) -(defun set-class-type-translation (class name) - (let ((classoid (find-classoid name nil))) - (etypecase classoid - (null) - (built-in-classoid - (let ((translation (built-in-classoid-translation classoid))) - (cond - (translation - (aver (ctype-p translation)) - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) translation))) - (t - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) - (classoid - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) +(defun set-class-type-translation (class classoid) + (when (not (typep classoid 'classoid)) + (setq classoid (find-classoid classoid nil))) + (etypecase classoid + (null) + (built-in-classoid + (let ((translation (built-in-classoid-translation classoid))) + (cond + (translation + (aver (ctype-p translation)) + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) translation))) + (t + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) + (classoid + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid))))) (clrhash *find-class*) (!bootstrap-meta-braid) Index: cache.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- cache.lisp 18 Jun 2006 23:47:58 -0000 1.40 +++ cache.lisp 17 Jul 2006 12:28:13 -0000 1.41 @@ -268,7 +268,9 @@ (aver (eq (classoid-pcl-class found) class)) found)) (t - (make-standard-classoid :pcl-class class)))) + (let ((name (slot-value class 'name))) + (make-standard-classoid :pcl-class class + :name (and (symbolp name) name)))))) (t (make-random-pcl-classoid :pcl-class class)))))) (t Index: dfun.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- dfun.lisp 18 Jun 2006 23:47:58 -0000 1.48 +++ dfun.lisp 17 Jul 2006 12:28:13 -0000 1.49 @@ -1509,21 +1509,30 @@ (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) - ;; KLUDGE: why not use (slot-boundp class - ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is - ;; used within COMPUTE-APPLICABLE-METHODS, including for - ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for - ;; breaking such nasty cycles in effective method computation - ;; only works for readers and writers, not boundps. It might - ;; not be too hard to make it work for BOUNDP accessors, but in - ;; the meantime we use an extra slot for exactly the result of - ;; the SLOT-BOUNDP that we want. (We cannot use - ;; CLASS-FINALIZED-P, because in the process of class - ;; finalization we need to use the CPL which has been computed - ;; to cache effective methods for slot accessors.) -- CSR, - ;; 2004-09-19. - (when (cpl-available-p class) - (class-precedence-list class)) + (progn + ;; KLUDGE: why not use (slot-boundp class + ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is + ;; used within COMPUTE-APPLICABLE-METHODS, including for + ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for + ;; breaking such nasty cycles in effective method computation + ;; only works for readers and writers, not boundps. It might + ;; not be too hard to make it work for BOUNDP accessors, but in + ;; the meantime we use an extra slot for exactly the result of + ;; the SLOT-BOUNDP that we want. (We cannot use + ;; CLASS-FINALIZED-P, because in the process of class + ;; finalization we need to use the CPL which has been computed + ;; to cache effective methods for slot accessors.) -- CSR, + ;; 2004-09-19. + + (when (cpl-available-p class) + (return-from cpl-or-nil (class-precedence-list class))) + + ;; if we can finalize an unfinalized class, then do so + (when (and (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (class-precedence-list class))) + (early-class-precedence-list class))) (defun saut-and (specl type) Index: fsc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/fsc.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- fsc.lisp 9 Sep 2005 17:43:45 -0000 1.4 +++ fsc.lisp 17 Jul 2006 12:28:13 -0000 1.5 @@ -45,7 +45,8 @@ (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) - (unless (class-finalized-p class) (finalize-inheritance class)) + (unless (class-finalized-p class) + (finalize-inheritance class)) (allocate-funcallable-instance (class-wrapper class))) (defmethod make-reader-method-function ((class funcallable-standard-class) Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v retrieving revision 1.26 retrieving revision 1.27 diff -u -d -r1.26 -r1.27 --- macros.lisp 27 Feb 2006 13:12:35 -0000 1.26 +++ macros.lisp 17 Jul 2006 12:28:14 -0000 1.27 @@ -157,10 +157,33 @@ (with-single-package-locked-error (:symbol name "using ~A as the class-name argument in ~ (SETF FIND-CLASS)")) - (let ((cell (find-class-cell name))) + (let* ((cell (find-class-cell name)) + (class (find-class-cell-class cell))) (setf (find-class-cell-class cell) new-value) - (when (and (eq *boot-state* 'complete) (null new-value)) - (setf (find-classoid name) nil)) + (when (eq *boot-state* 'complete) + (if (null new-value) + (progn + (setf (find-classoid name) new-value) + (when class + ;; KLUDGE: This horror comes about essentially + ;; because we use the proper name of a classoid + ;; to do TYPEP, which needs to be available + ;; early, and also to determine whether TYPE-OF + ;; should return the name or the class (using + ;; CLASSOID-PROPER-NAME). So if we are removing + ;; proper nameness, arrange for + ;; CLASSOID-PROPER-NAME to do the right thing + ;; too. (This is almost certainly not the right + ;; solution; instead, CLASSOID-NAME and + ;; FIND-CLASSOID should be direct parallels to + ;; CLASS-NAME and FIND-CLASS, and TYPEP on + ;; not-yet-final classes should be compileable. + (let ((classoid (layout-classoid (slot-value class 'wrapper)))) + (setf (classoid-name classoid) nil)))) + + (let ((classoid (layout-classoid (slot-value new-value 'wrapper)))) + (setf (find-classoid name) classoid) + (set-class-type-translation new-value classoid)))) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) (update-ctors 'setf-find-class :class new-value :name name)) @@ -168,11 +191,6 @@ (t (error "~S is not a legal class name." name)))) -(/show "pcl/macros.lisp 230") - -(defun find-wrapper (symbol) - (class-wrapper (find-class symbol))) - (/show "pcl/macros.lisp 241") (defmacro function-funcall (form &rest args) Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.56 retrieving revision 1.57 diff -u -d -r1.56 -r1.57 --- methods.lisp 28 May 2006 11:02:02 -0000 1.56 +++ methods.lisp 17 Jul 2006 12:28:14 -0000 1.57 @@ -974,19 +974,20 @@ (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) - (unless (invalid-wrapper-p (class-wrapper (specializer-class spec))) - (cons (specializer-class spec) - (and (classp spec) - precompute-p - (not (or (eq spec *the-class-t*) - (eq spec *the-class-slot-object*) - (eq spec *the-class-standard-object*) - (eq spec *the-class-structure-object*))) - (let ((sc (class-direct-subclasses spec))) - (when sc - (mapcan (lambda (class) - (mec-all-classes-internal class precompute-p)) - sc))))))) + (let ((wrapper (class-wrapper (specializer-class spec)))) + (unless (or (not wrapper) (invalid-wrapper-p wrapper)) + (cons (specializer-class spec) + (and (classp spec) + precompute-p + (not (or (eq spec *the-class-t*) + (eq spec *the-class-slot-object*) + (eq spec *the-class-standard-object*) + (eq spec *the-class-structure-object*))) + (let ((sc (class-direct-subclasses spec))) + (when sc + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) + sc)))))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) @@ -1023,17 +1024,22 @@ (default '(default))) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) - (let ((wrappers (get-wrappers-from-classes - nkeys wrappers classes metatypes))) - (when (and wrappers - (eq default (probe-cache cache wrappers default))) + (let ((%wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (and %wrappers + (eq default (probe-cache cache %wrappers default))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) ((eq valuep :constant-value) (value-for-caching generic-function classes))))) - (setq cache (fill-cache cache wrappers value)))))))) + ;; need to get them again, as finalization might + ;; have happened in between, which would + ;; invalidate wrappers. + (let ((wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (setq cache (fill-cache cache wrappers value))))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) @@ -1590,7 +1596,9 @@ (defmethod (setf class-name) (new-value class) (let ((classoid (%wrapper-classoid (class-wrapper class)))) - (setf (classoid-name classoid) new-value)) + (if (and new-value (symbolp new-value)) + (setf (classoid-name classoid) new-value) + (setf (classoid-name classoid) nil))) (reinitialize-instance class :name new-value) new-value) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.96 retrieving revision 1.97 diff -u -d -r1.96 -r1.97 --- std-class.lisp 13 Jul 2006 10:03:38 -0000 1.96 +++ std-class.lisp 17 Jul 2006 12:28:14 -0000 1.97 @@ -310,6 +310,7 @@ (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) + #+nil (set-class-type-translation (class-prototype meta) name) (setf class (apply #'make-instance meta :name name initargs)) (without-package-locks @@ -334,8 +335,7 @@ (error "~S is not a class or a legal class name." s)) (t (or (find-class s nil) - (make-instance 'forward-referenced-class - :name s))))) + (ensure-class s :metaclass 'forward-referenced-class))))) (defun ensure-class-values (class initargs) (let (metaclass metaclassp reversed-plist) @@ -450,19 +450,18 @@ (without-package-locks (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))) + (let ((classoid (or (let ((layout (slot-value class 'wrapper))) + (when layout (layout-classoid layout))) + #+nil + (find-classoid name nil) + (make-standard-classoid + :name (if (symbolp name) name nil)))) + (layout (make-wrapper 0 class))) (setf (layout-classoid layout) classoid) (setf (classoid-pcl-class classoid) class) (setf (slot-value class 'wrapper) layout) @@ -472,8 +471,8 @@ (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)))))))) + (setf (classoid-layout classoid) layout)))) + (mapc #'make-preliminary-layout (class-direct-subclasses class))))) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -784,35 +783,17 @@ ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) - ;; Comment from Gerd Moellmann: - ;; - ;; Note that we can't simply delay the finalization when CLASS has - ;; no forward referenced superclasses because that causes bootstrap - ;; problems. (without-package-locks - (when (and (not finalizep) - (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) - (finalize-inheritance class) - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil)) - (return-from update-class)) - (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) - (setf (find-class (class-name class)) class) + (when (or finalizep (class-finalized-p class)) (update-cpl class (compute-class-precedence-list class)) ;; This invocation of UPDATE-SLOTS, in practice, finalizes the - ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE - ;; is called at finalization, so that MOP programmers can hook - ;; into the system as described in "Class Finalization Protocol" - ;; (section 5.5.2 of AMOP). + ;; class. (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil))))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) (define-condition cpl-protocol-violation (reference-condition error) ((class :initarg :class :reader cpl-protocol-violation-class) @@ -1276,15 +1257,19 @@ (let* ((owrapper (class-wrapper class)) (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock + (unless (class-finalized-p class) + (if (class-has-a-forward-referenced-superclass-p class) + (return-from make-instances-obsolete class) + (update-cpl class (compute-class-precedence-list class)))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (with-pcl-lock (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) - class))) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class)) @@ -1430,6 +1415,8 @@ (defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) + (unless (class-finalized-p new-class) + (finalize-inheritance new-class)) (let ((cpl (class-precedence-list new-class))) (dolist (class cpl) (macrolet |