X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=36d1ee056e9baf086be0aedcb9c3ea4f178e3616;hb=bef0d9c1274819ee3fb886401209662bace136ce;hp=27bbf453783b67fe5d6b0a29a0f075587f0b12e1;hpb=42938a8cffe21be4b5a50d2253bbe76bab25e16a;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 27bbf45..36d1ee0 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,8 +11,6 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(load "assertoid.lisp")
-
 (defpackage "CLOS-IMPURE"
   (:use "CL" "ASSERTOID" "TEST-UTIL"))
 (in-package "CLOS-IMPURE")
@@ -654,6 +652,7 @@
 (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:
@@ -664,8 +663,10 @@
 ;;; 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))
+  (let ((value (bug222-b t x)))
+    ;; not specified by ANSI
+    #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+    (assert (= value 3)))
   ;; specified.
   (assert (char= (char (get-output-stream-string x) 0) #\1)))
 
@@ -1346,4 +1347,185 @@
 ;;; cache with more than one key, then failure ensues.
 (reinitialize-instance #'print-object)
 
+;;; bug in long-form method combination: if there's an applicable
+;;; method not part of any method group, we need to call
+;;; INVALID-METHOD-ERROR.  (MC27 test case from Bruno Haible)
+(define-method-combination mc27 ()
+  ((normal ())
+   (ignored (:ignore :unused)))
+  `(list 'result
+    ,@(mapcar #'(lambda (method) `(call-method ,method)) normal)))
+(defgeneric test-mc27 (x)
+  (:method-combination mc27)
+  (:method :ignore ((x number)) (/ 0)))
+(assert (raises-error? (test-mc27 7)))
+
+(define-method-combination mc27prime ()
+  ((normal ())
+   (ignored (:ignore)))
+  `(list 'result ,@(mapcar (lambda (m) `(call-method ,m)) normal)))
+(defgeneric test-mc27prime (x)
+  (:method-combination mc27prime)
+  (:method :ignore ((x number)) (/ 0)))
+(assert (equal '(result) (test-mc27prime 3)))
+(assert (raises-error? (test-mc27 t))) ; still no-applicable-method
+
+;;; more invalid wrappers.  This time for a long-standing bug in the
+;;; compiler's expansion for TYPEP on various class-like things, with
+;;; user-visible consequences.
+(defclass obsolete-again () ())
+(defvar *obsolete-again* (make-instance 'obsolete-again))
+(defvar *obsolete-again-hash* (sxhash *obsolete-again*))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (streamp *obsolete-again*)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
+(compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (is-a-structure-object-p *obsolete-again*)))
+
+;;; overeager optimization of slot-valuish things
+(defclass listoid ()
+  ((caroid :initarg :caroid)
+   (cdroid :initarg :cdroid :initform nil)))
+(defmethod lengthoid ((x listoid))
+  (let ((result 0))
+    (loop until (null x)
+          do (incf result) (setq x (slot-value x 'cdroid)))
+    result))
+(with-test (:name ((:setq :method-parameter) slot-value))
+  (assert (= (lengthoid (make-instance 'listoid)) 1))
+  (assert (= (lengthoid
+              (make-instance 'listoid :cdroid
+                             (make-instance 'listoid :cdroid
+                                            (make-instance 'listoid))))
+             3)))
+
+
+
+;;;; Tests for argument parsing in fast-method-functions.
+
+(defvar *foo* 0)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf (symbol-value 'a) 'invalid))
+
+(defmacro test1 (lambda-list values args &key declarations cnm)
+  `(progn
+     (fmakunbound 'll-method)
+     (fmakunbound 'll-function)
+     (defmethod ll-method ,lambda-list
+       ,@declarations
+       ,@(when cnm
+           `((when nil (call-next-method))))
+       (list ,@values))
+     (defun ll-function ,lambda-list
+       ,@declarations
+       (list ,@values))
+     (dotimes (i 2)
+       (assert (equal (ll-method ,@args)
+                      (ll-function ,@args))))))
+
+(defmacro test (&rest args)
+  `(progn
+     (test1 ,@args :cnm nil)
+     (test1 ,@args :cnm t)))
+
+;; Just plain arguments
+
+(test (a) (a) (1))
+(test (a b c d e f g h i) (a b c d e f g h i) (1 2 3 4 5 6 7 8 9))
+
+(test (*foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (a) (a (symbol-value 'a)) (1)
+      :declarations ((declare (special a))))
+
+;; Optionals
+
+(test (a &optional b c) (a b c) (1))
+(test (a &optional b c) (a b c) (1 2))
+(test (a &optional b c) (a b c) (1 2 3))
+
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2))
+(test (a &optional (b 'b b-p) (c 'c c-p)) (a b c b-p c-p) (1 2 3))
+
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) ())
+(test (&optional *foo*) (*foo* (symbol-value '*foo*)) (1))
+
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) ())
+(test (&optional (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p) (1))
+
+(test (&optional a) (a (symbol-value 'a)) ()
+      :declarations ((declare (special a))))
+(test (&optional a) (a (symbol-value 'a)) (1)
+      :declarations ((declare (special a))))
+
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) ()
+      :declarations ((declare (special a))))
+(test (&optional (a 'z a-p)) (a (symbol-value 'a) a-p) (1)
+      :declarations ((declare (special a))))
+
+(defparameter *count* 0)
+
+(test (&optional (a (incf *count*)) (b (incf *count*)))
+      (a b *count* (setf *count* 0))
+      ())
+
+;; Keywords with some &RESTs thrown in
+
+(dolist (args '((1)
+                (1 :b 2)
+                (1 :c 3)
+                (1 :b 2 :c 3)
+                (1 :c 3 :b 2)
+                (1 :c 3 :c 1 :b 2 :b 4)))
+  (eval `(test (a &key b c) (a b c) ,args))
+  (eval `(test (a &key (b 'b b-p) (c 'c c-p))
+               (a b c b-p c-p)
+               ,args))
+  (eval `(test (a &rest rest &key (b 'b b-p) (c 'c c-p))
+               (a b c b-p c-p rest)
+               ,args))
+  (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+               (a b c b-p c-p *foo* (symbol-value '*foo*))
+               ,args))
+  (eval `(test (a &rest *foo* &key (b 'b b-p) (c 'c c-p))
+               (a b c b-p c-p *foo* (symbol-value '*foo*))
+               ,args
+               :declarations ((declare (special b-p))))))
+
+(dolist (args '(()
+                (:*foo* 1)
+                (:*foo* 1 :*foo* 2)))
+  (eval `(test (&key *foo*) (*foo* (symbol-value '*foo*)) ,args))
+  (eval `(test (&key (*foo* 'z foo-p)) (*foo* (symbol-value '*foo*) foo-p)
+               ,args))
+  (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+               ,args))
+  (eval `(test (&key ((:*foo* a) 'z foo-p)) (a (symbol-value 'a) foo-p)
+               ,args
+               :declarations ((declare (special a))))))
+
+(defparameter *count* 0)
+
+(test (&key (a (incf *count*)) (b (incf *count*)))
+      (a b *count* (setf *count* 0))
+      ())
+
+(test (&key a b &allow-other-keys) (a b) (:a 1 :b 2 :c 3))
+
+(defmethod clim-style-lambda-list-test (a b &optional c d &key x y)
+  (list a b c d x y))
+
+(clim-style-lambda-list-test 1 2)
+
+(setf *count* 0)
+
+(test (&aux (a (incf *count*)) (b (incf *count*)))
+      (a b *count* (setf *count* 0))
+      ())
+
+
 ;;;; success