X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=9041c40b631b864e401a184d0ee45d0e8dd72062;hb=e76ddf242a31a2acaae3a9cb818fa31500ebbf92;hp=b4462cd453cc355fe2d9f767338145eb19b93177;hpb=2fe7ca730f378505f86a7553462fa3241185d444;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index b4462cd..9041c40 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -293,12 +293,24 @@ (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: + ;; 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))) (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)))) ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully ;;; preserved through the bootstrap process until sbcl-0.7.8.39. @@ -365,7 +377,146 @@ 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)) -;;;; success +;;; 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)) + +;;; 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))) + +;;; 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) + +;;; 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)) + +;;; 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"))) + +;;; 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))) + +;;;; success (sb-ext:quit :unix-status 104)