X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=e3efc7281d75e9f14e92209dc45200944de84f70;hb=e38cf29945f9ff0cfbf614c0c216be60e2515175;hp=ffdbd3b4c31b6936237760ce44eb675982fd9f23;hpb=920f9a94cc0512d7fbab3f1578e8b71485b18b00;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index ffdbd3b..e3efc72 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. @@ -293,12 +295,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. @@ -327,6 +341,220 @@ (assert (eq (no-next-method-test 1) 'success)) (assert (null (ignore-errors (no-next-method-test 'foo)))) -;;;; success +;;; 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 () ()) + +;;;; success (sb-ext:quit :unix-status 104)