X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=a1e22b137b450e70568fb8cad066d971eaf791ae;hb=fb03344c5e8388e0b16512f1cb662d8cf5d13972;hp=a319f42f260cc487349387d7effd13dc6b0b40e0;hpb=937a46e64983862cb9e21761db95e58700341940;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index a319f42..a1e22b1 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -6,7 +6,7 @@ ;;;; 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. @@ -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 @@ -81,26 +81,26 @@ ;;; 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) @@ -110,14 +110,14 @@ (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 @@ -148,7 +148,7 @@ ;;; 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) @@ -191,10 +191,11 @@ ((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)) @@ -290,49 +291,49 @@ ;;; 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 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)) ;; yet some more, fixed in sbcl-0.7.9.xx (assert-program-error (defclass foo005 () - (:metaclass sb-pcl::funcallable-standard-class) - (:metaclass 1))) + (:metaclass sb-pcl::funcallable-standard-class) + (:metaclass 1))) (assert-program-error (defclass foo006 () - ((a :reader (setf a))))) + ((a :reader (setf a))))) (assert-program-error (defclass foo007 () - ((a :initarg 1)))) + ((a :initarg 1)))) (assert-program-error (defclass foo008 () - (a :initarg :a) - (:default-initargs :a 1) - (:default-initargs :a 2))) + (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)))) + ((:a :initarg :a)))) (assert-program-error (defclass foo010 () - (("a" :initarg :a)))) + (("a" :initarg :a)))) (assert-program-error (defclass foo011 () - ((#1a() :initarg :a)))) + ((#1a() :initarg :a)))) (assert-program-error (defclass foo012 () - ((t :initarg :t)))) + ((t :initarg :t)))) (assert-program-error (defclass foo013 () ("a"))) ;; specialized lambda lists have certain restrictions on ordering, ;; repeating keywords, and the like: @@ -340,7 +341,7 @@ (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)) + &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)) @@ -356,14 +357,14 @@ ;;; 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)) @@ -408,31 +409,145 @@ (:method-combination dmc-test-mc)) (defmethod dmc-test-mc dmc-test-mc (&key k) - 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)) + 'dmc-test-return-foo)) (assert (eq (define-method-combination dmc-test-return-bar :operator and) - 'dmc-test-return-bar)) + '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)) + (&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)) +;;; 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) @@ -440,18 +555,29 @@ (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)) + (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)) + (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))) + (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)))) + ;;; Attempting to instantiate classes with forward references in their ;;; CPL should signal errors (FIXME: of what type?) @@ -489,9 +615,9 @@ (:arguments object) `(unwind-protect (progn (lock (object-lock ,object)) - ,@(mapcar #'(lambda (method) - `(call-method ,method)) - methods)) + ,@(mapcar #'(lambda (method) + `(call-method ,method)) + methods)) (unlock (object-lock ,object)))) (defun object-lock (obj) (push "object-lock" *d-m-c-args-test*) @@ -510,11 +636,11 @@ (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"))) + '("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"))) + '("unlock" "object-lock" "lock" "object-lock"))) ;;; 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 @@ -557,8 +683,8 @@ (incf *bug234*)) (assert (typep (subbug-234) 'subclass234)) (assert (= *bug234* - ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE - 2)) + ;; 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): @@ -582,19 +708,19 @@ ;;; 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) + slot-name op + &optional new-value) op) (assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo) - 'slot-value)) + 'slot-value)) (assert (eq (funcall (lambda (x) (slot-value x 'bar)) - (make-instance 'class-with-all-slots-missing)) - 'slot-value)) + (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)) + (make-instance 'class-with-all-slots-missing)) + ;; SLOT-MISSING's value is specified to be ignored; we + ;; return NEW-VALUE. + 'baz)) ;;; we should be able to specialize on anything that names a class. (defclass name-for-class () ()) @@ -603,7 +729,7 @@ (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)) + 2)) ;;; more forward referenced classes stuff (defclass frc-1 (frc-2) ()) @@ -629,7 +755,7 @@ ;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS). (defstruct allocatable-structure a) (assert (typep (allocate-instance (find-class 'allocatable-structure)) - 'allocatable-structure)) + 'allocatable-structure)) ;;; Bug found by Paul Dietz when devising CPL tests: somewhat ;;; amazingly, calls to CPL would work a couple of times, and then @@ -648,11 +774,11 @@ (assert (equal (cpl 0) '(integer number))) (assert (equal (cpl 0) '(integer number))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) ;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal ;;; parameters shouldn't affect the arguments to the next method for a @@ -660,8 +786,538 @@ (defgeneric cnm-assignment (x) (:method (x) x) (:method ((x integer)) (setq x 3) - (list x (call-next-method) (call-next-method x)))) + (list x (call-next-method) (call-next-method x)))) (assert (equal (cnm-assignment 1) '(3 1 3))) +;;; 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) + +(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"))) + + + +;;; 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))) + + + +(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)))) + +;;; 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)))))) + +;;; 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)))) + +;;; 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)) + +;;; 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*))) + +;;; 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))) + ;;;; success -(sb-ext:quit :unix-status 104)