+(defclass redefinition-of-accessor-class ()
+ ((slot :accessor new-name)))
+
+\f
+
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
+(delete-package "PACKAGE-CTOR-BUG")
+(load "package-ctor-bug.lisp")
+(assert (= (package-ctor-bug:test) 3))
+
+(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))
+ (eval '(defgeneric bug-281 (x)
+ (:method-combination +)
+ (:method ((x symbol)) 1)
+ (:method + ((x number)) x)))
+ (assert (= 1 (bug-281 1)))
+ (assert (= 4.2 (bug-281 4.2)))
+ (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol))
+ (assert (not val))
+ (assert (typep err 'error))))
+\f
+;;; RESTART-CASE and CALL-METHOD
+
+;;; from Bruno Haible
+
+(defun rc-cm/prompt-for-new-values ()
+ (format *debug-io* "~&New values: ")
+ (finish-output *debug-io*)
+ (list (read *debug-io*)))
+
+(defun rc-cm/add-method-restarts (form method)
+ (let ((block (gensym))
+ (tag (gensym)))
+ `(block ,block
+ (tagbody
+ ,tag
+ (return-from ,block
+ (restart-case ,form
+ (method-redo ()
+ :report (lambda (stream)
+ (format stream "Try calling ~S again." ,method))
+ (go ,tag))
+ (method-return (l)
+ :report (lambda (stream)
+ (format stream "Specify return values for ~S call."
+ ,method))
+ :interactive (lambda () (rc-cm/prompt-for-new-values))
+ (return-from ,block (values-list l)))))))))
+
+(defun rc-cm/convert-effective-method (efm)
+ (if (consp efm)
+ (if (eq (car efm) 'call-method)
+ (let ((method-list (third efm)))
+ (if (or (typep (first method-list) 'method) (rest method-list))
+ ;; Reduce the case of multiple methods to a single one.
+ ;; Make the call to the next-method explicit.
+ (rc-cm/convert-effective-method
+ `(call-method ,(second efm)
+ ((make-method
+ (call-method ,(first method-list) ,(rest method-list))))))
+ ;; Now the case of at most one method.
+ (if (typep (second efm) 'method)
+ ;; Wrap the method call in a RESTART-CASE.
+ (rc-cm/add-method-restarts
+ (cons (rc-cm/convert-effective-method (car efm))
+ (rc-cm/convert-effective-method (cdr efm)))
+ (second efm))
+ ;; Normal recursive processing.
+ (cons (rc-cm/convert-effective-method (car efm))
+ (rc-cm/convert-effective-method (cdr efm))))))
+ (cons (rc-cm/convert-effective-method (car efm))
+ (rc-cm/convert-effective-method (cdr efm))))
+ efm))
+
+(define-method-combination standard-with-restarts ()
+ ((around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+ (flet ((call-methods-sequentially (methods)
+ (mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods)))
+ (let ((form (if (or before after (rest primary))
+ `(multiple-value-prog1
+ (progn
+ ,@(call-methods-sequentially before)
+ (call-method ,(first primary) ,(rest primary)))
+ ,@(call-methods-sequentially (reverse after)))
+ `(call-method ,(first primary)))))
+ (when around
+ (setq form
+ `(call-method ,(first around)
+ (,@(rest around) (make-method ,form)))))
+ (rc-cm/convert-effective-method form))))
+
+(defgeneric rc-cm/testgf16 (x)
+ (:method-combination standard-with-restarts))
+(defclass rc-cm/testclass16a () ())
+(defclass rc-cm/testclass16b (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16c (rc-cm/testclass16a) ())
+(defclass rc-cm/testclass16d (rc-cm/testclass16b rc-cm/testclass16c) ())
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16a))
+ (list 'a
+ (not (null (find-restart 'method-redo)))
+ (not (null (find-restart 'method-return)))))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16b))
+ (cons 'b (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16c))
+ (cons 'c (call-next-method)))
+(defmethod rc-cm/testgf16 ((x rc-cm/testclass16d))
+ (cons 'd (call-next-method)))
+(assert (equal (rc-cm/testgf16 (make-instance 'rc-cm/testclass16d))
+ '(d b c a t t)))
+
+;;; test case from Gerd Moellmann
+(define-method-combination r-c/c-m-1 ()
+ ((primary () :required t))
+ `(restart-case (call-method ,(first primary))
+ ()))
+
+(defgeneric r-c/c-m-1-gf ()
+ (:method-combination r-c/c-m-1)
+ (:method () nil))
+
+(assert (null (r-c/c-m-1-gf)))
+
+(handler-bind ((warning #'error))
+ (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))))))
+\f
+;;; 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))))
+\f
+;;; 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))
+\f
+;;; 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))))
+\f
+;;; 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)))
+\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
+;;; 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
+\f
+;;; more invalid wrappers. This time for a long-standing bug in the
+;;; compiler's expansion for TYPEP on various class-like things, with
+;;; user-visible consequences.
+(defclass obsolete-again () ())
+(defvar *obsolete-again* (make-instance 'obsolete-again))
+(defvar *obsolete-again-hash* (sxhash *obsolete-again*))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (streamp *obsolete-again*)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
+(compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (is-a-structure-object-p *obsolete-again*)))
+\f
+;;; overeager optimization of slot-valuish things
+(defclass listoid ()
+ ((caroid :initarg :caroid)
+ (cdroid :initarg :cdroid :initform nil)))
+(defmethod lengthoid ((x listoid))
+ (let ((result 0))
+ (loop until (null x)
+ do (incf result) (setq x (slot-value x 'cdroid)))
+ result))
+(with-test (:name ((:setq :method-parameter) slot-value))
+ (assert (= (lengthoid (make-instance 'listoid)) 1))
+ (assert (= (lengthoid
+ (make-instance 'listoid :cdroid
+ (make-instance 'listoid :cdroid
+ (make-instance 'listoid))))
+ 3)))
+
+\f
+
+;;;; Tests for argument parsing in fast-method-functions.
+
+(defvar *foo* 0)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (symbol-value 'a) 'invalid))
+
+(defmacro test1 (lambda-list values args &key declarations cnm)
+ `(progn
+ (fmakunbound 'll-method)
+ (fmakunbound 'll-function)
+ (defmethod ll-method ,lambda-list
+ ,@declarations
+ ,@(when cnm
+ `((when nil (call-next-method))))
+ (list ,@values))
+ (defun ll-function ,lambda-list
+ ,@declarations
+ (list ,@values))
+ (dotimes (i 2)
+ (assert (equal (ll-method ,@args)
+ (ll-function ,@args))))))
+
+(defmacro test (&rest args)
+ `(progn
+ (test1 ,@args :cnm nil)
+ (test1 ,@args :cnm t)))
+
+;; Just plain arguments
+
+(test (a) (a) (1))
+(test (a b c d e f g h i) (a b c d e f g h i) (1 2 3 4 5 6 7 8 9))
+
+(test (*foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (a) (a (symbol-value 'a)) (1)
+ :declarations ((declare (special a))))
+
+;; Optionals
+
+(test (a &optional b c) (a b c) (1))
+(test (a &optional b c) (a b c) (1 2))
+(test (a &optional b c) (a b c) (1 2 3))
+
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2 3))
+
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) ())
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) ())
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) (1))
+
+(test (&optional a) (a (symbol-value 'a)) ()
+ :declarations ((declare (special a))))
+(test (&optional a) (a (symbol-value 'a)) (1)
+ :declarations ((declare (special a))))
+
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) ()
+ :declarations ((declare (special a))))
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) (1)
+ :declarations ((declare (special a))))
+
+(defparameter *count* 0)
+
+(test (&optional (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+;; Keywords with some &RESTs thrown in
+
+(dolist (args '((1)
+ (1 :b 2)
+ (1 :c 3)
+ (1 :b 2 :c 3)
+ (1 :c 3 :b 2)
+ (1 :c 3 :c 1 :b 2 :b 4)))
+ (eval `(test (a &key b c) (a b c) ,args))
+ (eval `(test (a &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p)
+ ,args))
+ (eval `(test (a &rest rest &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p rest)
+ ,args))
+ (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p *foo* (symbol-value '*foo*))
+ ,args))
+ (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+ (a b c b-p c-p *foo* (symbol-value '*foo*))
+ ,args
+ :declarations ((declare (special b-p))))))
+
+(dolist (args '(()
+ (:*foo* 1)
+ (:*foo* 1 :*foo* 2)))
+ (eval `(test (&key *foo*) (*foo* (symbol-value '*foo*)) ,args))
+ (eval `(test (&key (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p)
+ ,args))
+ (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+ ,args))
+ (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+ ,args
+ :declarations ((declare (special a))))))
+
+(defparameter *count* 0)
+
+(test (&key (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+(test (&key a b &allow-other-keys) (a b) (:a 1 :b 2 :c 3))
+
+(defmethod clim-style-lambda-list-test (a b &optional c d &key x y)
+ (list a b c d x y))
+
+(clim-style-lambda-list-test 1 2)
+
+(setf *count* 0)
+
+(test (&aux (a (incf *count*)) (b (incf *count*)))
+ (a b *count* (setf *count* 0))
+ ())
+
+;;;; long-form method combination with &rest in :arguments
+;;;; (this had a bug what with fixed in 1.0.4.something)
+(define-method-combination long-form-with-&rest ()
+ ((methods *))
+ (:arguments x &rest others)
+ `(progn
+ ,@(mapcar (lambda (method)
+ `(call-method ,method))
+ methods)
+ (list ,x (length ,others))))
+
+(defgeneric test-long-form-with-&rest (x &rest others)
+ (:method-combination long-form-with-&rest))
+
+(defmethod test-long-form-with-&rest (x &rest others)
+ nil)
+
+(assert (equal '(:foo 13)
+ (apply #'test-long-form-with-&rest :foo (make-list 13))))
+
+;;;; slot-missing for non-standard classes on SLOT-VALUE
+;;;;
+;;;; FIXME: This is arguably not right, actually: CLHS seems to say
+;;;; we should just signal an error at least for built-in classes, but
+;;;; for a while we were hitting NO-APPLICABLE-METHOD, which is definitely
+;;;; wrong -- so test this for now at least.
+
+(defvar *magic-symbol* (gensym "MAGIC"))
+
+(set *magic-symbol* 42)
+
+(defmethod slot-missing (class instance (slot-name (eql *magic-symbol*)) op
+ &optional new)
+ (if (eq 'setf op)
+ (setf (symbol-value *magic-symbol*) new)
+ (symbol-value *magic-symbol*)))
+
+(assert (eql 42 (slot-value (cons t t) *magic-symbol*)))
+(assert (eql 13 (setf (slot-value 123 *magic-symbol*) 13)))
+(assert (eql 13 (slot-value 'foobar *magic-symbol*)))
+
+;;;; Built-in structure and condition layouts should have NIL in
+;;;; LAYOUT-FOR-STD-CLASS-P, and classes should have T.
+
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'warning))))
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'hash-table))))
+(assert (eq t (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'standard-object))))
+\f
+;;;; success