X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=a1e22b137b450e70568fb8cad066d971eaf791ae;hb=fb03344c5e8388e0b16512f1cb662d8cf5d13972;hp=a037be3643c7b5d5409300c7dc6a0b1814d8fc6f;hpb=a4640afb239d4de3e348430fd9903fc3a88b9139;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index a037be3..a1e22b1 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)) @@ -1209,4 +1235,89 @@ (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))) + ;;;; success