0.8.21.38: fix bug 211e

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d371ea9..5baf7d1 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -990,5 +990,51 @@
          (grovel-results name))))))
 (identify-suspect-vops)
 \f
+;;;; tests for compiler output
+(let* ((*error-output* (make-broadcast-stream))
+       (output (with-output-to-string (*standard-output*)
+                (compile-file "compiler-output-test.lisp" 
+                              :print nil :verbose nil))))
+  (print output)
+  (assert (zerop (length output))))
+
+;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
+
+(define-condition optimization-error (error) ())
+
+(labels ((compile-lambda (type sense)
+          (handler-bind ((compiler-note (lambda (_)
+                                          (declare (ignore _))
+                                          (error 'optimization-error))))
+            (values
+             (compile 
+              nil
+              `(lambda ()
+                 (declare 
+                  ,@(when type '((ftype (function () (integer 0 10)) bug-305)))
+                  (,sense bug-305)
+                  (optimize speed))
+                 (1+ (bug-305))))
+             nil)))
+        (expect-error (sense)
+          (multiple-value-bind (f e)  (ignore-errors (compile-lambda nil sense))
+            (assert (not f))
+            (assert (typep e 'optimization-error))))
+        (expect-pass (sense)
+          (multiple-value-bind (f e)  (ignore-errors (compile-lambda t sense))
+            (assert f)
+            (assert (not e)))))
+  (expect-error 'inline)
+  (expect-error 'notinline)
+  (expect-pass 'inline)
+  (expect-pass 'notinline))
+
+;;; bug 211e: bogus style warning from duplicated keyword argument to
+;;; a local function.
+(handler-bind ((style-warning #'error))
+  (let ((f (compile nil '(lambda () (flet ((foo (&key y) (list y)))
+                                     (list (foo :y 1 :y 2)))))))
+    (assert (equal '((1)) (funcall f)))))
+
 ;;; success
 (quit :unix-status 104)