From: Christophe Rhodes Date: Mon, 17 Jul 2006 12:28:13 +0000 (+0000) Subject: 0.9.14.21: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fb03344c5e8388e0b16512f1cb662d8cf5d13972;p=sbcl.git 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. --- diff --git a/src/code/class.lisp b/src/code/class.lisp index eb35177..dcd40fe 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -772,7 +772,18 @@ NIL is returned when no such class exists." (remhash name *forward-referenced-layouts*) (%note-type-defined name) - (setf (info :type :kind name) :instance) + ;; we need to handle things like + ;; (setf (find-class 'foo) (find-class 'integer)) + ;; and + ;; (setf (find-class 'integer) (find-class 'integer)) + (cond + ((built-in-classoid-p new-value) + (setf (info :type :kind name) (or (info :type :kind name) :defined)) + (let ((translation (built-in-classoid-translation new-value))) + (when translation + (setf (info :type :translator name) + (lambda (c) (declare (ignore c)) translation))))) + (t (setf (info :type :kind name) :instance))) (setf (classoid-cell-classoid (find-classoid-cell name)) new-value) (unless (eq (info :type :compiler-layout name) (classoid-layout new-value)) @@ -809,6 +820,33 @@ NIL is returned when no such class exists." (!define-type-class classoid) +;;; We might be passed classoids with invalid layouts; in any pairwise +;;; class comparison, we must ensure that both are valid before +;;; proceeding. +(defun ensure-classoid-valid (classoid layout) + (aver (eq classoid (layout-classoid layout))) + (when (layout-invalid layout) + (if (typep classoid 'standard-classoid) + (let ((class (classoid-pcl-class classoid))) + (cond + ((sb!pcl:class-finalized-p class) + (sb!pcl::force-cache-flushes class)) + ((sb!pcl::class-has-a-forward-referenced-superclass-p class) + (error "Invalid, unfinalizeable class ~S (classoid ~S)." + class classoid)) + (t (sb!pcl:finalize-inheritance class)))) + (error "Don't know how to ensure validity of ~S (not ~ + a STANDARD-CLASSOID)." classoid)))) + +(defun ensure-both-classoids-valid (class1 class2) + (do ((layout1 (classoid-layout class1) (classoid-layout class1)) + (layout2 (classoid-layout class2) (classoid-layout class2)) + (i 0 (+ i 1))) + ((and (not (layout-invalid layout1)) (not (layout-invalid layout2)))) + (aver (< i 2)) + (ensure-classoid-valid class1 layout1) + (ensure-classoid-valid class2 layout2))) + ;;; Simple methods for TYPE= and SUBTYPEP should never be called when ;;; the two classes are equal, since there are EQ checks in those ;;; operations. @@ -818,6 +856,7 @@ NIL is returned when no such class exists." (!define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq class1 class2))) + (ensure-both-classoids-valid class1 class2) (let ((subclasses (classoid-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) (values t t) @@ -841,6 +880,7 @@ NIL is returned when no such class exists." (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid class1 class2)) + (ensure-both-classoids-valid class1 class2) (cond ((eq class1 class2) class1) ;; If one is a subclass of the other, then that is the diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 49b3964..36e776a 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -176,21 +176,23 @@ ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID. (defun classoid-typep (obj-layout classoid object) (declare (optimize speed)) - (when (layout-invalid obj-layout) - (if (and (typep (classoid-of object) 'standard-classoid) object) - (setq obj-layout (sb!pcl::check-wrapper-validity object)) - (error "TYPEP was called on an obsolete object (was class ~S)." - (classoid-proper-name (layout-classoid obj-layout))))) - (let ((layout (classoid-layout classoid)) - (obj-inherits (layout-inherits obj-layout))) - (when (layout-invalid layout) - (error "The class ~S is currently invalid." classoid)) - (or (eq obj-layout layout) - (dotimes (i (length obj-inherits) nil) - (when (eq (svref obj-inherits i) layout) - (return t)))))) - -;;; This implementation is a placeholder to use until PCL is set up, -;;; at which time it will be overwritten by a real implementation. -(defun sb!pcl::check-wrapper-validity (object) - object) + (multiple-value-bind (obj-layout layout) + (do ((layout (classoid-layout classoid) (classoid-layout classoid)) + (i 0 (+ i 1)) + (obj-layout obj-layout)) + ((and (not (layout-invalid obj-layout)) + (not (layout-invalid layout))) + (values obj-layout layout)) + (aver (< i 2)) + (when (layout-invalid obj-layout) + (if (typep (classoid-of object) 'standard-classoid) + (setq obj-layout (sb!pcl::check-wrapper-validity object)) + (error "~S was called on an obsolete object (classoid ~S)." + 'typep + (classoid-proper-name (layout-classoid obj-layout))))) + (ensure-classoid-valid classoid layout)) + (let ((obj-inherits (layout-inherits obj-layout))) + (or (eq obj-layout layout) + (dotimes (i (length obj-inherits) nil) + (when (eq (svref obj-inherits i) layout) + (return t))))))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8ffba53..a1d2644 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2025,6 +2025,12 @@ bootstrapping. (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.))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 4b587fc..e18daee 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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 ') 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 ' is slow but compileable. (let ((name (class-name class))) - (setf (find-classoid name) lclass - (classoid-name lclass) name))))) - -(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)))))) + (when (and name (symbolp name) (eq name (classoid-name classoid))) + (setf (find-classoid name) 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) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 5eb5930..7465081 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -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 diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3983779..d6f2d08 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1509,21 +1509,30 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) diff --git a/src/pcl/fsc.lisp b/src/pcl/fsc.lisp index 46f6944..8739040 100644 --- a/src/pcl/fsc.lisp +++ b/src/pcl/fsc.lisp @@ -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) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 3060a06..ad4e24f 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -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) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f61386e..04f8dd5 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 80f7719..553e17d 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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 diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 864e0b6..a1e22b1 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1064,14 +1064,18 @@ (load "package-ctor-bug.lisp") (assert (= (package-ctor-bug:test) 3)) -(deftype defined-type () 'integer) -(assert (raises-error? - (defmethod method-on-defined-type ((x defined-type)) x))) -(deftype defined-type-and-class () 'integer) -(setf (find-class 'defined-type-and-class) (find-class 'integer)) -(defmethod method-on-defined-type-and-class ((x defined-type-and-class)) - (1+ x)) -(assert (= (method-on-defined-type-and-class 3) 4)) +(with-test (:name (:defmethod (setf find-class) integer)) + (mapcar #'eval + '( + (deftype defined-type () 'integer) + (assert (raises-error? + (defmethod method-on-defined-type ((x defined-type)) x))) + (deftype defined-type-and-class () 'integer) + (setf (find-class 'defined-type-and-class) (find-class 'integer)) + (defmethod method-on-defined-type-and-class + ((x defined-type-and-class)) + (1+ x)) + (assert (= (method-on-defined-type-and-class 3) 4))))) ;; bug 281 (let ((sb-pcl::*max-emf-precomputation-methods* 0)) @@ -1292,13 +1296,28 @@ (assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test)))) ;;; CHANGE-CLASS and tricky allocation. -(defclass foo () +(defclass foo-to-be-changed () ((a :allocation :class :initform 1))) -(defclass bar (foo) ()) -(defvar *bar* (make-instance 'bar)) -(defclass baz () +(defclass bar-to-be-changed (foo-to-be-changed) ()) +(defvar *bar-to-be-changed* (make-instance 'bar-to-be-changed)) +(defclass baz-to-be-changed () ((a :allocation :instance :initform 2))) -(change-class *bar* 'baz) -(assert (= (slot-value *bar* 'a) 1)) +(change-class *bar-to-be-changed* 'baz-to-be-changed) +(assert (= (slot-value *bar-to-be-changed* 'a) 1)) + +;;; proper name and class redefinition +(defvar *to-be-renamed1* (defclass to-be-renamed1 () ())) +(defvar *to-be-renamed2* (defclass to-be-renamed2 () ())) +(setf (find-class 'to-be-renamed1) (find-class 'to-be-renamed2)) +(defvar *renamed1* (defclass to-be-renamed1 () ())) +(assert (not (eq *to-be-renamed1* *to-be-renamed2*))) +(assert (not (eq *to-be-renamed1* *renamed1*))) +(assert (not (eq *to-be-renamed2* *renamed1*))) + +;;; CLASS-NAME (and various other standardized generic functions) have +;;; their effective methods precomputed; in the process of rearranging +;;; (SETF FIND-CLASS) and FINALIZE-INHERITANCE, this broke. +(defclass class-with-odd-class-name-method () + ((a :accessor class-name))) ;;;; success diff --git a/tests/mop-17.impure-cload.lisp b/tests/mop-17.impure-cload.lisp new file mode 100644 index 0000000..77ed157 --- /dev/null +++ b/tests/mop-17.impure-cload.lisp @@ -0,0 +1,60 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; this file tests the programmatic class example from pp.67-69 of +;;; AMOP. + +(defpackage "MOP-17" + (:use "CL" "SB-MOP")) + +(in-package "MOP-17") + +(defun make-programmatic-instance (superclass-names &rest initargs) + (apply #'make-instance + (find-programmatic-class + (mapcar #'find-class superclass-names)) + initargs)) + +(defun find-programmatic-class (superclasses) + (let ((class (find-if + (lambda (class) + (equal superclasses + (class-direct-superclasses class))) + (class-direct-subclasses (car superclasses))))) + (or class + (make-programmatic-class superclasses)))) + +(defun make-programmatic-class (superclasses) + (make-instance 'standard-class + :name (mapcar #'class-name superclasses) + :direct-superclasses superclasses + :direct-slots '())) + +(defclass shape () ()) +(defclass circle (shape) ()) +(defclass color () ()) +(defclass orange (color) ()) +(defclass magenta (color) ()) +(defclass label-type () ()) +(defclass top-labeled (label-type) ()) +(defclass bottom-labeled (label-type) ()) + +(assert (null (class-direct-subclasses (find-class 'circle)))) + +(defvar *i1* (make-programmatic-instance '(circle orange top-labeled))) +(defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled))) +(defvar *i3* (make-programmatic-instance '(circle orange top-labeled))) + +(assert (not (eq *i1* *i3*))) + +(assert (= (length (class-direct-subclasses (find-class 'circle))) 2)) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 8b18720..e69a1ea 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -480,5 +480,10 @@ () (:metaclass funcallable-standard-class)) (make-instance 'bad-funcallable-standard-class)))) - + +;;; we should be able to make classes with silly names +(make-instance 'standard-class :name 3) +(defclass foo () ()) +(reinitialize-instance (find-class 'foo) :name '(a b)) + ;;;; success diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index d5edc2e..1ab5a2c 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -486,5 +486,18 @@ (assert-t-t (subtypep `(and (member ,misc-629c) sb-kernel:instance) nil))) - + +;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the +;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the +;;; subclass, so SUBTYPEP must be prepared to deal with +(defclass ansi-tests-defclass1 () ()) +(defclass ansi-tests-defclass3 (ansi-tests-defclass1) ()) +(make-instance 'ansi-tests-defclass1) +(assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object)) + +;;; so was this +(let ((class (eval '(defclass to-be-type-ofed () ())))) + (setf (find-class 'to-be-type-ofed) nil) + (assert (eq (type-of (make-instance class)) class))) + ;;; success