X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=73a68bbc172997ff11cd10871ad472ab92d664a2;hb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;hp=60815d0aee9da692d970def2ac65fe86c14066f1;hpb=c7638557b3c7b34267daba188d345f5d284f4ac3;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 60815d0..73a68bb 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -11,9 +11,11 @@ ;;;; 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")) +(in-package "CLOS-IMPURE") ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to ;;; structure types defined earlier in the file. @@ -277,6 +279,297 @@ (defmethod gf (obj) obj) -;;;; success +;;; 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 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)) + ;; 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. +;;; (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)) + +;;; 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))) + +;;; 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)) + +;;; 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)) + 'setf)) + +;;;; success (sb-ext:quit :unix-status 104)