X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=46749be367411614c4ea8e087896411f4042b33f;hb=992e6a70a0cae3f6d43bdbba18f77306fdf10662;hp=f4bacff8373f9c2449cec9e10f98e2118b3448bb;hpb=65a49a98ff0607b9af1931d0517455a8a55b78f0;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index f4bacff..46749be 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -14,7 +14,7 @@ (load "assertoid.lisp") (defpackage "CLOS-IMPURE" - (:use "CL" "ASSERTOID")) + (:use "CL" "ASSERTOID" "TEST-UTIL")) (in-package "CLOS-IMPURE") ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to @@ -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) @@ -1170,13 +1192,104 @@ (assert (null (r-c/c-m-1-gf))) (handler-bind ((warning #'error)) - (eval '(defclass class-for-ctor/class-slot () + (eval '(defclass class-for-ctor/class-slot () ((class-slot :initarg :class-slot :allocation :class)))) (eval '(let ((c1 (make-instance 'class-for-ctor/class-slot)) (c2 (make-instance 'class-for-ctor/class-slot :class-slot 1))) (assert (equal (list (slot-value c1 'class-slot) (slot-value c2 'class-slot)) (list 1 1)))))) + +;;; tests of ctors on anonymous classes +(defparameter *unnamed* (defclass ctor-unnamed-literal-class () ())) +(setf (class-name *unnamed*) nil) +(setf (find-class 'ctor-unnamed-literal-class) nil) +(defparameter *unnamed2* (defclass ctor-unnamed-literal-class2 () ())) +(defun ctor-unnamed-literal-class () + (make-instance '#.*unnamed*)) +(compile 'ctor-unnamed-literal-class) +(defun ctor-unnamed-literal-class2 () + (make-instance '#.(find-class 'ctor-unnamed-literal-class2))) +(compile 'ctor-unnamed-literal-class2) +(defun ctor-unnamed-literal-class2/symbol () + (make-instance 'ctor-unnamed-literal-class2)) +(compile 'ctor-unnamed-literal-class2/symbol) +(setf (class-name *unnamed2*) nil) +(setf (find-class 'ctor-unnamed-literal-class2) nil) +(with-test (:name (:ctor :unnamed-before)) + (assert (typep (ctor-unnamed-literal-class) *unnamed*))) +(with-test (:name (:ctor :unnamed-after)) + (assert (typep (ctor-unnamed-literal-class2) *unnamed2*))) +(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)))) + ;;;; success -(sb-ext:quit :unix-status 104)