X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=753dd4cfed3c4c75b4053a02fb48da662f05b98d;hb=342b4bc80d748ced4f8b949ddb3e5b290520fe7d;hp=60815d0aee9da692d970def2ac65fe86c14066f1;hpb=c7638557b3c7b34267daba188d345f5d284f4ac3;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 60815d0..753dd4c 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -277,6 +277,145 @@ (defmethod gf (obj) obj) +;;; 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))))) + (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 foo003 () + ((a :allocation :class :allocation :class)))) + (assert-program-error (defclass foo004 () + ((a :silly t)))) + ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd + ;; Moellmann in 0.7.8.x: + (assert-program-error (progn + (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))) + +;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully +;;; preserved through the bootstrap process until sbcl-0.7.8.39. +;;; (thanks to Gerd Moellmann) +(let ((answer (documentation '+ 'function))) + (assert (stringp answer)) + (defmethod documentation ((x (eql '+)) y) "WRONG") + (assert (string= (documentation '+ 'function) answer))) + +;;; 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))))) + (assert-program-error (defgeneric bogus-declaration (x) + (declare (special y)))) + (assert-program-error (defgeneric bogus-declaration2 (x) + (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)))) + +;;; 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))) + +;;; 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)) + +;;; DEFMETHOD should signal a PROGRAM-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))) +;;; 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))) +(defmethod incompatible-ll-test-2 (x &rest y) y) +(assert (= (length + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1)) +(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar) +(assert (= (length + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2)) +(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2))) +(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes)) + ;;;; success (sb-ext:quit :unix-status 104)