X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=9041c40b631b864e401a184d0ee45d0e8dd72062;hb=e76ddf242a31a2acaae3a9cb818fa31500ebbf92;hp=dc33bd5e6439539edc7a2ac675942cb84dfdd40b;hpb=3ecee4526a55b3b4e6d7f86d69dc411f074968ec;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index dc33bd5..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.
@@ -435,6 +447,76 @@
 (defclass subclass-for-class-allocation (superclass-with-slot) ())
 (make-instance 'subclass-for-class-allocation)
 
-;;;; success
+;;; 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)