X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=4dd6b029fb817af81930ca07837a835bf0e73b1c;hb=447985f1243b79918f9fece47d8e9664e44ec07a;hp=48b2028b81796af0708c9af9e0d86b1e7c0abb4b;hpb=f76b45e1a3bb2008540e0db90b591c591315f129;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 48b2028..4dd6b02 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -15,6 +15,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(when (eq sb-ext:*evaluator-mode* :interpret)
+  (sb-ext:quit :unix-status 104))
+
 (load "test-util.lisp")
 (load "assertoid.lisp")
 (use-package "TEST-UTIL")
@@ -1361,4 +1364,66 @@
   (assert (s368-p nsu))
   (assert *h368-was-called-p*))
 
+;;; bug 367: array type intersections in the compiler
+(defstruct e367)
+(defstruct i367)
+(defstruct g367
+  (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null)))
+(defstruct s367
+  (g367 (error "missing :G367") :type g367 :read-only t))
+(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367))
+(declaim (ftype (function ((vector e367)) (values)) h367))
+(defun frob-367 (v w)
+  (let ((x (g367-i367s (make-g367))))
+    (let* ((y (or (r367 x w)
+                  (h367 x)))
+           (z (s367-g367 y)))
+      (format t "~&Y=~S Z=~S~%" y z)
+      (g367-i367s z))))
+(defun r367 (x y) (declare (ignore x y)) nil)
+(defun h367 (x) (declare (ignore x)) (values))
+(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367)))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+
+(handler-case
+    (delete-file (compile-file "circ-tree-test.lisp"))
+  (storage-condition (e)
+    (error e)))
+
+;;; warnings due to step-insturmentation
+(defclass debug-test-class () ())
+(handler-case
+    (compile nil '(lambda ()
+                   (declare (optimize (debug 3)))
+                   (defmethod print-object ((x debug-test-class) s)
+                     (call-next-method))))
+  ((and (not style-warning) warning) (e)
+    (error e)))
+
+;;; program-error from bad lambda-list keyword
+(assert (eq :ok
+            (handler-case
+                (funcall (lambda (&whole x)
+                           (list &whole x)))
+              (program-error ()
+                :ok))))
+(assert (eq :ok
+            (handler-case
+                (let ((*evaluator-mode* :interpret))
+                  (funcall (eval '(lambda (&whole x)
+                                   (list &whole x)))))
+              (program-error ()
+                :ok))))
+
+;;; ignore &environment
+(handler-bind ((style-warning #'error))
+  (compile nil '(lambda ()
+                 (defmacro macro-ignore-env (&environment env)
+                   (declare (ignore env))
+                   :foo)))
+  (compile nil '(lambda ()
+                 (defmacro macro-no-env ()
+                   :foo))))
+
 ;;; success