(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))
(assert (not (typep-backwards-3 (make-instance 'backwards-2))))
(assert (typep-backwards-3 (make-instance 'backwards-3)))
\f
+(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))))
+\f
+;;; 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))
+\f
+;;; 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*)))
+\f
+;;; 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)))
+\f
+;;; 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)
+\f
;;;; success
projects / sbcl.git / blobdiff