X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=f05a40ea3a691d87d44f6ae7fb0dce1e8aeafab1;hb=60639facf7d4e266d729a9c89f333618c9b2e8e2;hp=42b2ec08049b360f89ba0ba072ad4da9b6fb7b88;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 42b2ec0..f05a40e 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -892,6 +892,28 @@ (slot-boundp *obsoleted* 'a) (assert (= *obsoleted-counter* 1)) +;;; yet another MAKE-INSTANCES-OBSOLETE test, this time from Nikodemus +;;; Siivola. Not all methods for accessing slots are created equal... +(defclass yet-another-obsoletion-super () ((obs :accessor obs-of :initform 0))) +(defclass yet-another-obsoletion-sub (yet-another-obsoletion-super) ()) +(defmethod shared-initialize :after ((i yet-another-obsoletion-super) + slots &rest init) + (incf (obs-of i))) + +(defvar *yao-super* (make-instance 'yet-another-obsoletion-super)) +(defvar *yao-sub* (make-instance 'yet-another-obsoletion-sub)) + +(assert (= (obs-of *yao-super*) 1)) +(assert (= (obs-of *yao-sub*) 1)) +(make-instances-obsolete 'yet-another-obsoletion-super) +(assert (= (obs-of *yao-sub*) 2)) +(assert (= (obs-of *yao-super*) 2)) +(make-instances-obsolete 'yet-another-obsoletion-super) +(assert (= (obs-of *yao-super*) 3)) +(assert (= (obs-of *yao-sub*) 3)) +(assert (= (slot-value *yao-super* 'obs) 3)) +(assert (= (slot-value *yao-sub* 'obs) 3)) + ;;; shared -> local slot transfers of inherited slots, reported by ;;; Bruno Haible (let (i) @@ -1042,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)) @@ -1201,4 +1227,146 @@ (with-test (:name (:ctor :unnamed-after/symbol)) (assert (raises-error? (ctor-unnamed-literal-class2/symbol)))) +;;; classes with slot types shouldn't break if the types don't name +;;; classes (bug #391) +(defclass slot-type-superclass () ((slot :type fixnum))) +(defclass slot-type-subclass (slot-type-superclass) + ((slot :type (integer 1 5)))) +(let ((instance (make-instance 'slot-type-subclass))) + (setf (slot-value instance 'slot) 3)) + +;;; ctors where there's a non-standard SHARED-INITIALIZE method and an +;;; initarg which isn't self-evaluating (kpreid on #lisp 2006-01-29) +(defclass kpreid-enode () + ((slot :initarg not-a-keyword))) +(defmethod shared-initialize ((o kpreid-enode) slots &key &allow-other-keys) + (call-next-method)) +(defun make-kpreid-enode () + (make-instance 'kpreid-enode 'not-a-keyword 3)) +(with-test (:name (:ctor :non-keyword-initarg)) + (let ((x (make-kpreid-enode)) + (y (make-kpreid-enode))) + (= (slot-value x 'slot) (slot-value y 'slot)))) + +;;; defining a class hierarchy shouldn't lead to spurious classoid +;;; errors on TYPEP questions (reported by Tim Moore on #lisp +;;; 2006-03-10) +(defclass backwards-2 (backwards-1) (a b)) +(defclass backwards-3 (backwards-2) ()) +(defun typep-backwards-3 (x) + (typep x 'backwards-3)) +(defclass backwards-1 () (a b)) +(assert (not (typep-backwards-3 1))) +(assert (not (typep-backwards-3 (make-instance 'backwards-2)))) +(assert (typep-backwards-3 (make-instance 'backwards-3))) + +(defgeneric remove-method-1 (x) + (:method ((x integer)) (1+ x))) +(defgeneric remove-method-2 (x) + (:method ((x integer)) (1- x))) +(assert (eq #'remove-method-1 + (remove-method #'remove-method-1 + (find-method #'remove-method-2 + nil + (list (find-class 'integer)))))) +(assert (= (remove-method-1 3) 4)) +(assert (= (remove-method-2 3) 2)) + +;;; ANSI doesn't require these restarts, but now that we have them we +;;; better test them too. +(defclass slot-unbound-restart-test () ((x))) +(let ((test (make-instance 'slot-unbound-restart-test))) + (assert (not (slot-boundp test 'x))) + (assert (= 42 (handler-bind ((unbound-slot (lambda (c) (use-value 42 c)))) + (slot-value test 'x)))) + (assert (not (slot-boundp test 'x))) + (assert (= 13 (handler-bind ((unbound-slot (lambda (c) (store-value 13 c)))) + (slot-value test 'x)))) + (assert (= 13 (slot-value test 'x)))) + +;;; Using class instances as specializers, reported by Pascal Costanza, ref CLHS 7.6.2 +(defclass class-as-specializer-test () + ()) +(eval `(defmethod class-as-specializer-test1 ((x ,(find-class 'class-as-specializer-test))) + 'foo)) +(assert (eq 'foo (class-as-specializer-test1 (make-instance 'class-as-specializer-test)))) +(funcall (compile nil `(lambda () + (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test))) + 'bar)))) +(assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test)))) + +;;; CHANGE-CLASS and tricky allocation. +(defclass foo-to-be-changed () + ((a :allocation :class :initform 1))) +(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-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))) + +;;; another case where precomputing (this time on PRINT-OBJET) and +;;; lazily-finalized classes caused problems. (report from James Y +;;; Knight sbcl-devel 20-07-2006) + +(defclass base-print-object () ()) +;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and +;;; additionally the second specializer (STREAM) changes the cache +;;; structure to require two keys, not just one. +(defmethod print-object ((o base-print-object) (s stream)) + nil) + +;;; unfinalized as yet +(defclass sub-print-object (base-print-object) ()) +;;; the accessor causes an eager finalization +(defclass subsub-print-object (sub-print-object) + ((a :accessor a))) + +;;; triggers a discriminating function (and so cache) recomputation. +;;; The method on BASE-PRINT-OBJECT will cause the system to attempt +;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which +;;; have valid wrappers; however, in the course of doing so, the +;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the +;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a +;;; cache with more than one key, then failure ensues. +(reinitialize-instance #'print-object) + +;;; bug in long-form method combination: if there's an applicable +;;; method not part of any method group, we need to call +;;; INVALID-METHOD-ERROR. (MC27 test case from Bruno Haible) +(define-method-combination mc27 () + ((normal ()) + (ignored (:ignore :unused))) + `(list 'result + ,@(mapcar #'(lambda (method) `(call-method ,method)) normal))) +(defgeneric test-mc27 (x) + (:method-combination mc27) + (:method :ignore ((x number)) (/ 0))) +(assert (raises-error? (test-mc27 7))) + +(define-method-combination mc27prime () + ((normal ()) + (ignored (:ignore))) + `(list 'result ,@(mapcar (lambda (m) `(call-method ,m)) normal))) +(defgeneric test-mc27prime (x) + (:method-combination mc27prime) + (:method :ignore ((x number)) (/ 0))) +(assert (equal '(result) (test-mc27prime 3))) +(assert (raises-error? (test-mc27 t))) ; still no-applicable-method + ;;;; success