;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(defpackage "FOO"
- (:use "CL"))
-(in-package "FOO")
+(load "assertoid.lisp")
+
+(defpackage "CLOS-IMPURE"
+ (:use "CL" "ASSERTOID" "TEST-UTIL"))
+(in-package "CLOS-IMPURE")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
;;; structure types defined earlier in the file.
(assert (expect-error (defgeneric foo2 (x a &rest))))
(defgeneric foo3 (x &rest y))
(defmethod foo3 ((x t) &rest y) nil)
-(defmethod foo4 ((x t) &key y &rest z) nil)
+(defmethod foo4 ((x t) &rest z &key y) nil)
(defgeneric foo4 (x &rest z &key y))
(assert (expect-error (defgeneric foo5 (x &rest))))
(assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
;;; section 3.4.2 of the ANSI spec. Since Alexey Dejneka's patch for
;;; bug 191-b ca. sbcl-0.7.22, these limitations should be enforced.
(labels ((coerce-to-boolean (x)
- (if x t nil))
- (%like-or-dislike (expr expected-failure-p)
+ (if x t nil))
+ (%like-or-dislike (expr expected-failure-p)
(declare (type boolean expected-failure-p))
(format t "~&trying ~S~%" expr)
(multiple-value-bind (fun warnings-p failure-p)
- (compile nil
- `(lambda ()
+ (compile nil
+ `(lambda ()
,expr))
- (declare (ignore fun))
- ;; In principle the constraint on WARNINGS-P below seems
- ;; reasonable, but in practice we get warnings about
- ;; undefined functions from the DEFGENERICs, apparently
- ;; because the DECLAIMs which ordinarily prevent such
- ;; warnings don't take effect because EVAL-WHEN
- ;; (:COMPILE-TOPLEVEL) loses its magic when compiled
- ;; within a LAMBDA. So maybe we can't test WARNINGS-P
- ;; after all?
+ (declare (ignore fun))
+ ;; In principle the constraint on WARNINGS-P below seems
+ ;; reasonable, but in practice we get warnings about
+ ;; undefined functions from the DEFGENERICs, apparently
+ ;; because the DECLAIMs which ordinarily prevent such
+ ;; warnings don't take effect because EVAL-WHEN
+ ;; (:COMPILE-TOPLEVEL) loses its magic when compiled
+ ;; within a LAMBDA. So maybe we can't test WARNINGS-P
+ ;; after all?
;;(unless expected-failure-p
- ;; (assert (not warnings-p)))
- (assert (eq (coerce-to-boolean failure-p) expected-failure-p))))
+ ;; (assert (not warnings-p)))
+ (assert (eq (coerce-to-boolean failure-p) expected-failure-p))))
(like (expr)
(%like-or-dislike expr nil))
(dislike (expr)
(like '(defgeneric gf-for-ll-test-1 ()))
(like '(defgeneric gf-for-ll-test-2 (x)))
;; forbidden default or supplied-p for &OPTIONAL or &KEY arguments
- (dislike '(defgeneric gf-for-ll-test-3 (x &optional (y 0))))
- (like '(defgeneric gf-for-ll-test-4 (x &optional y)))
- (dislike '(defgeneric gf-for-ll-test-5 (x y &key (z :z z-p))))
+ (dislike '(defgeneric gf-for-ll-test-3 (x &optional (y 0))))
+ (like '(defgeneric gf-for-ll-test-4 (x &optional y)))
+ (dislike '(defgeneric gf-for-ll-test-5 (x y &key (z :z z-p))))
(like '(defgeneric gf-for-ll-test-6 (x y &key z)))
- (dislike '(defgeneric gf-for-ll-test-7 (x &optional (y 0) &key z)))
- (like '(defgeneric gf-for-ll-test-8 (x &optional y &key z)))
- (dislike '(defgeneric gf-for-ll-test-9 (x &optional y &key (z :z))))
- (like '(defgeneric gf-for-ll-test-10 (x &optional y &key z)))
+ (dislike '(defgeneric gf-for-ll-test-7 (x &optional (y 0) &key z)))
+ (like '(defgeneric gf-for-ll-test-8 (x &optional y &key z)))
+ (dislike '(defgeneric gf-for-ll-test-9 (x &optional y &key (z :z))))
+ (like '(defgeneric gf-for-ll-test-10 (x &optional y &key z)))
(dislike '(defgeneric gf-for-ll-test-11 (&optional &key (k :k k-p))))
(like '(defgeneric gf-for-ll-test-12 (&optional &key k)))
;; forbidden &AUX
;;; DEFGENERIC's blow-away-old-methods behavior is specified to have
;;; special hacks to distinguish between defined-with-DEFGENERIC-:METHOD
;;; methods and defined-with-DEFMETHOD methods, so that reLOADing
-;;; DEFGENERIC-containing files does the right thing instead of
+;;; DEFGENERIC-containing files does the right thing instead of
;;; randomly slicing your generic functions. (APD made this work
;;; in sbcl-0.7.0.2.)
(defgeneric born-to-be-redefined (x)
;;; that it doesn't happen again.
;;;
;;; First, the forward references:
-(defclass a (b) ())
-(defclass b () ())
+(defclass forward-ref-a (forward-ref-b) ())
+(defclass forward-ref-b () ())
+;;; (a couple more complicated examples found by Paul Dietz' test
+;;; suite):
+(defclass forward-ref-c1 (forward-ref-c2) ())
+(defclass forward-ref-c2 (forward-ref-c3) ())
+
+(defclass forward-ref-d1 (forward-ref-d2 forward-ref-d3) ())
+(defclass forward-ref-d2 (forward-ref-d4 forward-ref-d5) ())
+
;;; Then change-class
(defclass class-with-slots ()
((a-slot :initarg :a-slot :accessor a-slot)
(b-slot :initarg :b-slot :accessor b-slot)
(c-slot :initarg :c-slot :accessor c-slot)))
+
(let ((foo (make-instance 'class-with-slots
- :a-slot 1
- :b-slot 2
- :c-slot 3)))
+ :a-slot 1
+ :b-slot 2
+ :c-slot 3)))
(let ((bar (change-class foo 'class-with-slots)))
(assert (= (a-slot bar) 1))
(assert (= (b-slot bar) 2))
;;; Until sbcl-0.7.7.20, some conditions weren't being signalled, and
;;; some others were of the wrong type:
(macrolet ((assert-program-error (form)
- `(multiple-value-bind (value error)
- (ignore-errors ,form)
- (assert (null value))
- (assert (typep error 'program-error)))))
+ `(multiple-value-bind (value error)
+ (ignore-errors ,form)
+ (unless (and (null value) (typep error 'program-error))
+ (error "~S failed: ~S, ~S" ',form value error)))))
(assert-program-error (defclass foo001 () (a b a)))
- (assert-program-error (defclass foo002 ()
- (a b)
- (:default-initargs x 'a x 'b)))
+ (assert-program-error (defclass foo002 ()
+ (a b)
+ (:default-initargs x 'a x 'b)))
(assert-program-error (defclass foo003 ()
- ((a :allocation :class :allocation :class))))
+ ((a :allocation :class :allocation :class))))
(assert-program-error (defclass foo004 ()
- ((a :silly t))))
+ ((a :silly t))))
;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd
- ;; Moellmann in 0.7.8.x:
+ ;; Moellmann in sbcl-0.7.8.x:
(assert-program-error (progn
- (defmethod odd-key-args-checking (&key (key 42)) key)
- (odd-key-args-checking 3)))
+ (defmethod odd-key-args-checking (&key (key 42)) key)
+ (odd-key-args-checking 3)))
(assert (= (odd-key-args-checking) 42))
- (assert (eq (odd-key-args-checking :key t) t)))
+ (assert (eq (odd-key-args-checking :key t) t))
+ ;; yet some more, fixed in sbcl-0.7.9.xx
+ (assert-program-error (defclass foo005 ()
+ (:metaclass sb-pcl::funcallable-standard-class)
+ (:metaclass 1)))
+ (assert-program-error (defclass foo006 ()
+ ((a :reader (setf a)))))
+ (assert-program-error (defclass foo007 ()
+ ((a :initarg 1))))
+ (assert-program-error (defclass foo008 ()
+ (a :initarg :a)
+ (:default-initargs :a 1)
+ (:default-initargs :a 2)))
+ ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26
+ (assert-program-error (defgeneric if (x)))
+ ;; DEFCLASS should detect an error if slot names aren't suitable as
+ ;; variable names:
+ (assert-program-error (defclass foo009 ()
+ ((:a :initarg :a))))
+ (assert-program-error (defclass foo010 ()
+ (("a" :initarg :a))))
+ (assert-program-error (defclass foo011 ()
+ ((#1a() :initarg :a))))
+ (assert-program-error (defclass foo012 ()
+ ((t :initarg :t))))
+ (assert-program-error (defclass foo013 () ("a")))
+ ;; specialized lambda lists have certain restrictions on ordering,
+ ;; repeating keywords, and the like:
+ (assert-program-error (defmethod foo014 ((foo t) &rest) nil))
+ (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil))
+ (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil))
+ (assert-program-error (defmethod foo017 ((foo t)
+ &optional x &optional y) nil))
+ (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil))
+ (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil))
+ (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil))
+ (assert-program-error (defmethod foo021 ((foo t) &key x &rest y) nil)))
\f
;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
;;; preserved through the bootstrap process until sbcl-0.7.8.39.
\f
;;; only certain declarations are permitted in DEFGENERIC
(macrolet ((assert-program-error (form)
- `(multiple-value-bind (value error)
- (ignore-errors ,form)
- (assert (null value))
- (assert (typep error 'program-error)))))
+ `(multiple-value-bind (value error)
+ (ignore-errors ,form)
+ (assert (null value))
+ (assert (typep error 'program-error)))))
(assert-program-error (defgeneric bogus-declaration (x)
- (declare (special y))))
+ (declare (special y))))
(assert-program-error (defgeneric bogus-declaration2 (x)
- (declare (notinline concatenate)))))
+ (declare (notinline concatenate)))))
+;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next
+;;; method.
+(defmethod no-next-method-test ((x integer)) (call-next-method))
+(assert (null (ignore-errors (no-next-method-test 1))))
+(defmethod no-next-method ((g (eql #'no-next-method-test)) m &rest args)
+ 'success)
+(assert (eq (no-next-method-test 1) 'success))
+(assert (null (ignore-errors (no-next-method-test 'foo))))
\f
-;;;; success
+;;; 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
+;;; DEFINE-METHOD-COMBINATION should, according to the description in 7.7,
+;;; allow you to do everything in the body forms yourself if you specify
+;;; exactly one method group whose qualifier-pattern is *
+;;;
+;;; The specific language is:
+;;; "The use of method group specifiers provides a convenient syntax to select
+;;; methods, to divide them among the possible roles, and to perform the
+;;; necessary error checking. It is possible to perform further filtering of
+;;; methods in the body forms by using normal list-processing operations and
+;;; the functions method-qualifiers and invalid-method-error. It is permissible
+;;; to use setq on the variables named in the method group specifiers and to
+;;; bind additional variables. It is also possible to bypass the method group
+;;; specifier mechanism and do everything in the body forms. This is
+;;; accomplished by writing a single method group with * as its only
+;;; qualifier-pattern; the variable is then bound to a list of all of the
+;;; applicable methods, in most-specific-first order."
+(define-method-combination wam-test-method-combination-a ()
+ ((all-methods *))
+ (do ((methods all-methods (rest methods))
+ (primary nil)
+ (around nil))
+ ((null methods)
+ (let ((primary (nreverse primary))
+ (around (nreverse around)))
+ (if primary
+ (let ((form (if (rest primary)
+ `(call-method ,(first primary) ,(rest primary))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around) (,@(rest around)
+ (make-method ,form)))
+ form))
+ `(make-method (error "No primary methods")))))
+ (let* ((method (first methods))
+ (qualifier (first (method-qualifiers method))))
+ (cond
+ ((equal :around qualifier)
+ (push method around))
+ ((null qualifier)
+ (push method primary))))))
+
+(defgeneric wam-test-mc-a (val)
+ (:method-combination wam-test-method-combination-a))
+(assert (raises-error? (wam-test-mc-a 13)))
+(defmethod wam-test-mc-a ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-a 13) 13))
+(defmethod wam-test-mc-a :around ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-a 13) 26))
+
+;;; DEFINE-METHOD-COMBINATION
+;;; When two methods are in the same method group and have the same
+;;; specializers, their sort order within the group may be ambiguous. Therefore,
+;;; we should throw an error when we have two methods in the same group with
+;;; the same specializers /as long as/ we have more than one method group
+;;; or our single method group qualifier-pattern is not *. This resolves the
+;;; apparent conflict with the above 'It is also possible to bypass' language.
+;;;
+;;; The language specifying this behavior is:
+;;; "Note that two methods with identical specializers, but with different
+;;; qualifiers, are not ordered by the algorithm described in Step 2 of the
+;;; method selection and combination process described in Section 7.6.6
+;;; (Method Selection and Combination). Normally the two methods play different
+;;; roles in the effective method because they have different qualifiers, and
+;;; no matter how they are ordered in the result of Step 2, the effective
+;;; method is the same. If the two methods play the same role and their order
+;;; matters, an error is signaled. This happens as part of the qualifier
+;;; pattern matching in define-method-combination."
+;;;
+;;; Note that the spec pretty much equates 'method group' and 'role'.
+;; First we ensure that it fails correctly when there is more than one
+;; method group
+(define-method-combination wam-test-method-combination-b ()
+ ((around (:around))
+ (primary * :required t))
+ (let ((form (if (rest primary)
+ `(call-method ,(first primary) ,(rest primary))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around) (,@(rest around)
+ (make-method ,form)))
+ form)))
+
+(defgeneric wam-test-mc-b (val)
+ (:method-combination wam-test-method-combination-b))
+(defmethod wam-test-mc-b ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-b 13) 13))
+(defmethod wam-test-mc-b :around ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-b 13) 26))
+(defmethod wam-test-mc-b :somethingelse ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (raises-error? (wam-test-mc-b 13)))
+
+;;; now, ensure that it fails with a single group with a qualifier-pattern
+;;; that is not *
+(define-method-combination wam-test-method-combination-c ()
+ ((methods listp :required t))
+ (if (rest methods)
+ `(call-method ,(first methods) ,(rest methods))
+ `(call-method ,(first methods))))
+
+(defgeneric wam-test-mc-c (val)
+ (:method-combination wam-test-method-combination-c))
+(assert (raises-error? (wam-test-mc-c 13)))
+(defmethod wam-test-mc-c :foo ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (= (wam-test-mc-c 13) 13))
+(defmethod wam-test-mc-c :bar ((val number))
+ (+ val (if (next-method-p) (call-next-method) 0)))
+(assert (raises-error? (wam-test-mc-c 13)))
+
+;;; 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))
+
+;;; Per Christophe, this is an illegal method call because of 7.6.5
+(assert (raises-error? (incompatible-ll-test-2 t 1 2)))
+
+(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+
+(defmethod incompatible-ll-test-3 ((x integer)) x)
+(remove-method #'incompatible-ll-test-3
+ (find-method #'incompatible-ll-test-3
+ nil
+ (list (find-class 'integer))))
+(assert (raises-error? (defmethod incompatible-ll-test-3 (x y) (list x y))))
+
+\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))
+
+;;; also, some combinations of MAKE-INSTANCE and subclassing missed
+;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29):
+(defclass class234-b1 () ())
+(defclass class234-b2 (class234-b1) ())
+(defvar *bug234-b* 0)
+(defun bug234-b ()
+ (make-instance 'class234-b2))
+(compile 'bug234-b)
+(bug234-b)
+(assert (= *bug234-b* 0))
+(defmethod initialize-instance :before ((x class234-b1) &rest args)
+ (declare (ignore args))
+ (incf *bug234-b*))
+(bug234-b)
+(assert (= *bug234-b* 1))
+\f
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+\f
+;;; SLOT-MISSING should be called when there are missing slots.
+(defclass class-with-all-slots-missing () ())
+(defmethod slot-missing (class (o class-with-all-slots-missing)
+ slot-name op
+ &optional new-value)
+ op)
+(assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (slot-value x 'bar))
+ (make-instance 'class-with-all-slots-missing))
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
+ (make-instance 'class-with-all-slots-missing))
+ ;; SLOT-MISSING's value is specified to be ignored; we
+ ;; return NEW-VALUE.
+ 'baz))
+\f
+;;; we should be able to specialize on anything that names a class.
+(defclass name-for-class () ())
+(defmethod something-that-specializes ((x name-for-class)) 1)
+(setf (find-class 'other-name-for-class) (find-class 'name-for-class))
+(defmethod something-that-specializes ((x other-name-for-class)) 2)
+(assert (= (something-that-specializes (make-instance 'name-for-class)) 2))
+(assert (= (something-that-specializes (make-instance 'other-name-for-class))
+ 2))
+\f
+;;; more forward referenced classes stuff
+(defclass frc-1 (frc-2) ())
+(assert (subtypep 'frc-1 (find-class 'frc-2)))
+(assert (subtypep (find-class 'frc-1) 'frc-2))
+(assert (not (subtypep (find-class 'frc-2) 'frc-1)))
+(defclass frc-2 (frc-3) ((a :initarg :a)))
+(assert (subtypep 'frc-1 (find-class 'frc-3)))
+(defclass frc-3 () ())
+(assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1)))
+(assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2)))
+\f
+;;; check that we can define classes with two slots of different names
+;;; (even if it STYLE-WARNs).
+(defclass odd-name-class ()
+ ((name :initarg :name)
+ (cl-user::name :initarg :name2)))
+(let ((x (make-instance 'odd-name-class :name 1 :name2 2)))
+ (assert (= (slot-value x 'name) 1))
+ (assert (= (slot-value x 'cl-user::name) 2)))
+\f
+;;; ALLOCATE-INSTANCE should work on structures, even if defined by
+;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
+(defstruct allocatable-structure a)
+(assert (typep (allocate-instance (find-class 'allocatable-structure))
+ 'allocatable-structure))
+\f
+;;; Bug found by Paul Dietz when devising CPL tests: somewhat
+;;; amazingly, calls to CPL would work a couple of times, and then
+;;; start returning NIL. A fix was found (relating to the
+;;; applicability of constant-dfun optimization) by Gerd Moellmann.
+(defgeneric cpl (x)
+ (:method-combination list)
+ (:method list ((x broadcast-stream)) 'broadcast-stream)
+ (:method list ((x integer)) 'integer)
+ (:method list ((x number)) 'number)
+ (:method list ((x stream)) 'stream)
+ (:method list ((x structure-object)) 'structure-object))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+\f
+;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal
+;;; parameters shouldn't affect the arguments to the next method for a
+;;; no-argument call to CALL-NEXT-METHOD
+(defgeneric cnm-assignment (x)
+ (:method (x) x)
+ (:method ((x integer)) (setq x 3)
+ (list x (call-next-method) (call-next-method x))))
+(assert (equal (cnm-assignment 1) '(3 1 3)))
+\f
+;;; Bug reported by Istvan Marko 2003-07-09
+(let ((class-name (gentemp)))
+ (loop for i from 1 to 9
+ for slot-name = (intern (format nil "X~D" i))
+ for initarg-name = (intern (format nil "X~D" i) :keyword)
+ collect `(,slot-name :initarg ,initarg-name) into slot-descs
+ append `(,initarg-name (list 0)) into default-initargs
+ finally (eval `(defclass ,class-name ()
+ (,@slot-descs)
+ (:default-initargs ,@default-initargs))))
+ (let ((f (compile nil `(lambda () (make-instance ',class-name)))))
+ (assert (typep (funcall f) class-name))))
+
+;;; bug 262: DEFMETHOD failed on a generic function without a lambda
+;;; list
+(ensure-generic-function 'bug262)
+(defmethod bug262 (x y)
+ (list x y))
+(assert (equal (bug262 1 2) '(1 2)))
+
+;;; salex on #lisp 2003-10-13 reported that type declarations inside
+;;; WITH-SLOTS are too hairy to be checked
+(defun ensure-no-notes (form)
+ (handler-case (compile nil `(lambda () ,form))
+ (sb-ext:compiler-note (c)
+ ;; FIXME: it would be better to check specifically for the "type
+ ;; is too hairy" note
+ (error c))))
+(defvar *x*)
+(ensure-no-notes '(with-slots (a) *x*
+ (declare (integer a))
+ a))
+(ensure-no-notes '(with-slots (a) *x*
+ (declare (integer a))
+ (declare (notinline slot-value))
+ a))
+
+;;; from CLHS 7.6.5.1
+(defclass character-class () ((char :initarg :char)))
+(defclass picture-class () ((glyph :initarg :glyph)))
+(defclass character-picture-class (character-class picture-class) ())
+
+(defmethod width ((c character-class) &key font) font)
+(defmethod width ((p picture-class) &key pixel-size) pixel-size)
-(sb-ext:quit :unix-status 104)
+(assert (raises-error?
+ (width (make-instance 'character-class :char #\Q)
+ :font 'baskerville :pixel-size 10)
+ program-error))
+(assert (raises-error?
+ (width (make-instance 'picture-class :glyph #\Q)
+ :font 'baskerville :pixel-size 10)
+ program-error))
+(assert (eq (width (make-instance 'character-picture-class :char #\Q)
+ :font 'baskerville :pixel-size 10)
+ 'baskerville))
+
+;;; class redefinition shouldn't give any warnings, in the usual case
+(defclass about-to-be-redefined () ((some-slot :accessor some-slot)))
+(handler-bind ((warning #'error))
+ (defclass about-to-be-redefined () ((some-slot :accessor some-slot))))
+
+;;; attempts to add accessorish methods to generic functions with more
+;;; complex lambda lists should fail
+(defgeneric accessoroid (object &key &allow-other-keys))
+(assert (raises-error?
+ (defclass accessoroid-class () ((slot :accessor accessoroid)))
+ program-error))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass shared-slot-and-redefinition ()
+ ((size :initarg :size :initform 1 :allocation :class)))
+(let ((i (make-instance 'shared-slot-and-redefinition)))
+ (defclass shared-slot-and-redefinition ()
+ ((size :initarg :size :initform 2 :allocation :class)))
+ (assert (= (slot-value i 'size) 1)))
+
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass superclass-born-to-be-obsoleted () (a))
+(defclass subclass-born-to-be-obsoleted (superclass-born-to-be-obsoleted) ())
+(defparameter *born-to-be-obsoleted*
+ (make-instance 'subclass-born-to-be-obsoleted))
+(defparameter *born-to-be-obsoleted-obsoleted* nil)
+(defmethod update-instance-for-redefined-class
+ ((o subclass-born-to-be-obsoleted) a d pl &key)
+ (setf *born-to-be-obsoleted-obsoleted* t))
+(make-instances-obsolete 'superclass-born-to-be-obsoleted)
+(slot-boundp *born-to-be-obsoleted* 'a)
+(assert *born-to-be-obsoleted-obsoleted*)
+
+;;; additional test suggested by Bruno Haible sbcl-devel 2004-04-21
+(defclass super-super-obsoleted () (a))
+(defclass super-obsoleted-1 (super-super-obsoleted) ())
+(defclass super-obsoleted-2 (super-super-obsoleted) ())
+(defclass obsoleted (super-obsoleted-1 super-obsoleted-2) ())
+(defparameter *obsoleted* (make-instance 'obsoleted))
+(defparameter *obsoleted-counter* 0)
+(defmethod update-instance-for-redefined-class ((o obsoleted) a d pl &key)
+ (incf *obsoleted-counter*))
+(make-instances-obsolete 'super-super-obsoleted)
+(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)
+ (defclass super-with-magic-slot ()
+ ((magic :initarg :size :initform 1 :allocation :class)))
+ (defclass sub-of-super-with-magic-slot (super-with-magic-slot) ())
+ (setq i (make-instance 'sub-of-super-with-magic-slot))
+ (defclass super-with-magic-slot ()
+ ((magic :initarg :size :initform 2)))
+ (assert (= 1 (slot-value i 'magic))))
+
+;;; MAKE-INSTANCES-OBSOLETE return values
+(defclass one-more-to-obsolete () ())
+(assert (eq 'one-more-to-obsolete
+ (make-instances-obsolete 'one-more-to-obsolete)))
+(assert (eq (find-class 'one-more-to-obsolete)
+ (make-instances-obsolete (find-class 'one-more-to-obsolete))))
+
+;;; Sensible error instead of a BUG. Reported by Thomas Burdick.
+(multiple-value-bind (value err)
+ (ignore-errors
+ (defclass slot-def-with-duplicate-accessors ()
+ ((slot :writer get-slot :reader get-slot))))
+ (assert (typep err 'error))
+ (assert (not (typep err 'sb-int:bug))))
+
+;;; BUG 321: errors in parsing DEFINE-METHOD-COMBINATION arguments
+;;; lambda lists.
+
+(define-method-combination w-args ()
+ ((method-list *))
+ (:arguments arg1 arg2 &aux (extra :extra))
+ `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list)))
+(defgeneric mc-test-w-args (p1 p2 s)
+ (:method-combination w-args)
+ (:method ((p1 number) (p2 t) s)
+ (vector-push-extend (list 'number p1 p2) s))
+ (:method ((p1 string) (p2 t) s)
+ (vector-push-extend (list 'string p1 p2) s))
+ (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s)))
+(let ((v (make-array 0 :adjustable t :fill-pointer t)))
+ (assert (= (mc-test-w-args 1 2 v) 1))
+ (assert (equal (aref v 0) '(number 1 2)))
+ (assert (equal (aref v 1) '(t 1 2))))
+
+;;; BUG 276: declarations and mutation.
+(defmethod fee ((x fixnum))
+ (setq x (/ x 2))
+ x)
+(assert (= (fee 1) 1/2))
+(defmethod fum ((x fixnum))
+ (setf x (/ x 2))
+ x)
+(assert (= (fum 3) 3/2))
+(defmethod fii ((x fixnum))
+ (declare (special x))
+ (setf x (/ x 2))
+ x)
+(assert (= (fii 1) 1/2))
+(defvar *faa*)
+(defmethod faa ((*faa* string-stream))
+ (setq *faa* (make-broadcast-stream *faa*))
+ (write-line "Break, you sucker!" *faa*)
+ 'ok)
+(assert (eq 'ok (faa (make-string-output-stream))))
+(defmethod fex ((x fixnum) (y fixnum))
+ (multiple-value-setq (x y) (values (/ x y) (/ y x)))
+ (list x y))
+(assert (equal (fex 5 3) '(5/3 3/5)))
+
+;;; Bug reported by Zach Beane; incorrect return of (function
+;;; ',fun-name) in defgeneric
+(assert
+ (typep (funcall (compile nil
+ '(lambda () (flet ((nonsense () nil))
+ (defgeneric nonsense ())))))
+ 'generic-function))
+
+(assert
+ (typep (funcall (compile nil
+ '(lambda () (flet ((nonsense-2 () nil))
+ (defgeneric nonsense-2 ()
+ (:method () t))))))
+ 'generic-function))
+
+;;; bug reported by Bruno Haible: (setf find-class) using a
+;;; forward-referenced class
+(defclass fr-sub (fr-super) ())
+(setf (find-class 'fr-alt) (find-class 'fr-super))
+(assert (eq (find-class 'fr-alt) (find-class 'fr-super)))
+
+
+;;; ANSI Figure 4-8: all defined classes. Check that we can define
+;;; methods on all of these.
+(progn
+ (defgeneric method-for-defined-classes (x))
+ (dolist (c '(arithmetic-error
+ generic-function simple-error array hash-table
+ simple-type-error
+ bit-vector integer simple-warning
+ broadcast-stream list standard-class
+ built-in-class logical-pathname standard-generic-function
+ cell-error method standard-method
+ character method-combination standard-object
+ class null storage-condition
+ complex number stream
+ concatenated-stream package stream-error
+ condition package-error string
+ cons parse-error string-stream
+ control-error pathname structure-class
+ division-by-zero print-not-readable structure-object
+ echo-stream program-error style-warning
+ end-of-file random-state symbol
+ error ratio synonym-stream
+ file-error rational t
+ file-stream reader-error two-way-stream
+ float readtable type-error
+ floating-point-inexact real unbound-slot
+ floating-point-invalid-operation restart unbound-variable
+ floating-point-overflow sequence undefined-function
+ floating-point-underflow serious-condition vector
+ function simple-condition warning))
+ (eval `(defmethod method-for-defined-classes ((x ,c)) (princ x))))
+ (assert (string= (with-output-to-string (*standard-output*)
+ (method-for-defined-classes #\3))
+ "3")))
+
+
+\f
+;;; When class definition does not complete due to a bad accessor
+;;; name, do not cause an error when a new accessor name is provided
+;;; during class redefinition
+
+(defun existing-name (object)
+ (list object))
+
+(assert (raises-error? (defclass redefinition-of-accessor-class ()
+ ((slot :accessor existing-name)))))
+
+(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))
+
+(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))
+\f
+;;;; success
projects / sbcl.git / blobdiff