X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=b183624b3976a6c3c13bf6301938e66d18a4aa0f;hb=a53deb94a224bc903d00a5075acf562488cab06a;hp=41b20492243771bfa4b5ee2beb5b0729a72c4f35;hpb=619ee68faffc3990c5108611762ef54bf8cbbd1e;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 41b2049..b183624 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -70,7 +70,7 @@ (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))))) @@ -176,8 +176,16 @@ ;;; 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) @@ -312,7 +320,31 @@ (assert-program-error (defclass foo008 () (a :initarg :a) (:default-initargs :a 1) - (:default-initargs :a 2)))) + (: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))) ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully ;;; preserved through the bootstrap process until sbcl-0.7.8.39. @@ -401,26 +433,17 @@ form))) 'dmc-test-return)) -;;; DEFMETHOD should signal a PROGRAM-ERROR if an incompatible lambda -;;; list is given: +;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is +;;; given: (defmethod incompatible-ll-test-1 (x) x) -(multiple-value-bind (result error) - (ignore-errors (defmethod incompatible-ll-test-1 (x y) y)) - (assert (null result)) - (assert (typep error 'program-error))) -(multiple-value-bind (result error) - (ignore-errors (defmethod incompatible-ll-test-1 (x &rest y) y)) - (assert (null result)) - (assert (typep error 'program-error))) +(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) -(multiple-value-bind (result error) - (ignore-errors (defmethod incompatible-ll-test-2 (x) x)) - (assert (null result)) - (assert (typep error 'program-error))) +(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)) @@ -553,5 +576,161 @@ (bug234-b) (assert (= *bug234-b* 1)) +;;; we should be able to make classes with uninterned names: +(defclass #:class-with-uninterned-name () ()) + +;;; 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)) + +;;; 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)) + +;;; 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))) + +;;; 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))) + +;;; 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)) + +;;; 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))) + +;;; 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))) + +;;; 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)) + ;;;; success (sb-ext:quit :unix-status 104)