+;;; regression test for bug 176, following a fix that seems
+;;; simultaneously to fix 140 while not exposing 176 (by Gerd
+;;; Moellmann, merged in sbcl-0.7.9.12).
+(dotimes (i 10)
+ (let ((lastname (intern (format nil "C176-~D" (1- i))))
+ (name (intern (format nil "C176-~D" i))))
+ (eval `(defclass ,name
+ (,@(if (= i 0) nil (list lastname)))
+ ()))
+ (eval `(defmethod initialize-instance :after ((x ,name) &rest any)
+ (declare (ignore any))))))
+(defclass b176 () (aslot-176))
+(defclass c176-0 (b176) ())
+(assert (= 1 (setf (slot-value (make-instance 'c176-9) 'aslot-176) 1)))
+\f
+;;; DEFINE-METHOD-COMBINATION was over-eager at checking for duplicate
+;;; primary methods:
+(define-method-combination dmc-test-mc (&optional (order :most-specific-first))
+ ((around (:around))
+ (primary (dmc-test-mc) :order order :required t))
+ (let ((form (if (rest primary)
+ `(and ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ primary))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))
+ form)))
+
+(defgeneric dmc-test-mc (&key k)
+ (:method-combination dmc-test-mc))
+
+(defmethod dmc-test-mc dmc-test-mc (&key k)
+ k)
+
+(dmc-test-mc :k 1)
+;;; While I'm at it, DEFINE-METHOD-COMBINATION is defined to return
+;;; the NAME argument, not some random method object. So:
+(assert (eq (define-method-combination dmc-test-return-foo)
+ 'dmc-test-return-foo))
+(assert (eq (define-method-combination dmc-test-return-bar :operator and)
+ 'dmc-test-return-bar))
+(assert (eq (define-method-combination dmc-test-return
+ (&optional (order :most-specific-first))
+ ((around (:around))
+ (primary (dmc-test-return) :order order :required t))
+ (let ((form (if (rest primary)
+ `(and ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ primary))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))
+ form)))
+ 'dmc-test-return))
+\f
+;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
+;;; given:
+(defmethod incompatible-ll-test-1 (x) x)
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
+;;; Sneakily using a bit of MOPness to check some consistency
+(assert (= (length
+ (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
+
+(defmethod incompatible-ll-test-2 (x &key bar) bar)
+(assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
+(defmethod incompatible-ll-test-2 (x &rest y) y)
+(assert (= (length
+ (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
+(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
+(assert (= (length
+ (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
+(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
+(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+\f
+;;; Attempting to instantiate classes with forward references in their
+;;; CPL should signal errors (FIXME: of what type?)
+(defclass never-finished-class (this-one-unfinished-too) ())
+(multiple-value-bind (result error)
+ (ignore-errors (make-instance 'never-finished-class))
+ (assert (null result))
+ (assert (typep error 'error)))
+(multiple-value-bind (result error)
+ (ignore-errors (make-instance 'this-one-unfinished-too))
+ (assert (null result))
+ (assert (typep error 'error)))
+\f
+;;; Classes with :ALLOCATION :CLASS slots should be subclassable (and
+;;; weren't for a while in sbcl-0.7.9.xx)
+(defclass superclass-with-slot ()
+ ((a :allocation :class)))
+(defclass subclass-for-class-allocation (superclass-with-slot) ())
+(make-instance 'subclass-for-class-allocation)
+\f
+;;; bug #136: CALL-NEXT-METHOD was being a little too lexical,
+;;; resulting in failure in the following:
+(defmethod call-next-method-lexical-args ((x integer))
+ x)
+(defmethod call-next-method-lexical-args :around ((x integer))
+ (let ((x (1+ x)))
+ (call-next-method)))
+(assert (= (call-next-method-lexical-args 3) 3))
+\f
+;;; DEFINE-METHOD-COMBINATION with arguments was hopelessly broken
+;;; until 0.7.9.5x
+(defvar *d-m-c-args-test* nil)
+(define-method-combination progn-with-lock ()
+ ((methods ()))
+ (:arguments object)
+ `(unwind-protect
+ (progn (lock (object-lock ,object))
+ ,@(mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods))
+ (unlock (object-lock ,object))))
+(defun object-lock (obj)
+ (push "object-lock" *d-m-c-args-test*)
+ obj)
+(defun unlock (obj)
+ (push "unlock" *d-m-c-args-test*)
+ obj)
+(defun lock (obj)
+ (push "lock" *d-m-c-args-test*)
+ obj)
+(defgeneric d-m-c-args-test (x)
+ (:method-combination progn-with-lock))
+(defmethod d-m-c-args-test ((x symbol))
+ (push "primary" *d-m-c-args-test*))
+(defmethod d-m-c-args-test ((x number))
+ (error "foo"))
+(assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock")))
+(assert (equal *d-m-c-args-test*
+ '("unlock" "object-lock" "primary" "lock" "object-lock")))
+(setf *d-m-c-args-test* nil)
+(ignore-errors (d-m-c-args-test 1))
+(assert (equal *d-m-c-args-test*
+ '("unlock" "object-lock" "lock" "object-lock")))
+\f
+;;; The walker (on which DEFMETHOD depended) didn't know how to handle
+;;; SYMBOL-MACROLET properly. In fact, as of sbcl-0.7.10.20 it still
+;;; doesn't, but it does well enough to compile the following without
+;;; error (the problems remain in asking for a complete macroexpansion
+;;; of an arbitrary form).
+(symbol-macrolet ((x 1))
+ (defmethod bug222 (z)
+ (macrolet ((frob (form) `(progn ,form ,x)))
+ (frob (print x)))))
+(assert (= (bug222 t) 1))
+
+;;; also, a test case to guard against bogus environment hacking:
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq bug222-b 3))
+;;; this should at the least compile:
+(let ((bug222-b 1))
+ (defmethod bug222-b (z stream)
+ (macrolet ((frob (form) `(progn ,form ,bug222-b)))
+ (frob (format stream "~D~%" bug222-b)))))
+;;; and it would be nice (though not specified by ANSI) if the answer
+;;; were as follows:
+(let ((x (make-string-output-stream)))
+ ;; not specified by ANSI
+ (assert (= (bug222-b t x) 3))
+ ;; specified.
+ (assert (char= (char (get-output-stream-string x) 0) #\1)))
+\f
+;;; REINITIALIZE-INSTANCE, in the ctor optimization, wasn't checking
+;;; for invalid initargs where it should:
+(defclass class234 () ())
+(defclass subclass234 (class234) ())
+(defvar *bug234* 0)
+(defun bug-234 ()
+ (reinitialize-instance (make-instance 'class234) :dummy 0))
+(defun subbug-234 ()
+ (reinitialize-instance (make-instance 'subclass234) :dummy 0))
+(assert (raises-error? (bug-234) program-error))
+(defmethod shared-initialize :after ((i class234) slots &key dummy)
+ (incf *bug234*))
+(assert (typep (subbug-234) 'subclass234))
+(assert (= *bug234*
+ ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE
+ 2))