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 aa5ee2e..5baf7d1 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -308,12 +308,17 @@
 ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
 ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
 (multiple-value-bind (function warnings-p failure-p)
-    (compile nil '(lambda () (symbol-macrolet ((t nil)) t)))
+    (compile nil '(lambda ()
+                   ;; not interested in the package lock violation here
+                   (declare (sb-ext:disable-package-locks t))
+                   (symbol-macrolet ((t nil)) t)))
   (assert failure-p)
   (assert (raises-error? (funcall function) program-error)))
 (multiple-value-bind (function warnings-p failure-p)
     (compile nil
             '(lambda ()
+               ;; not interested in the package lock violation here
+               (declare (sb-ext:disable-package-locks *standard-input*))
                (symbol-macrolet ((*standard-input* nil))
                  *standard-input*)))
   (assert failure-p)
@@ -865,7 +870,59 @@
     (load source)
     (full-check)
     (delete-file fasl)))
-
+\f
+(defun expt-derive-type-bug (a b)
+  (unless (< a b)
+    (truncate (expt a b))))
+(assert (equal (multiple-value-list (expt-derive-type-bug 1 1))
+              '(1 0)))
+
+;;; Problems with type checking in functions with EXPLICIT-CHECK
+;;; attribute (reported by Peter Graves)
+(loop for (fun . args) in '((= a) (/= a)
+                            (< a) (<= a) (> a) (>= a))
+      do (assert (raises-error? (apply fun args) type-error)))
+
+(defclass broken-input-stream (sb-gray:fundamental-input-stream) ())
+(defmethod sb-gray:stream-read-char ((stream broken-input-stream))
+  (throw 'break :broken))
+(assert (eql (block return
+               (handler-case
+                   (catch 'break
+                     (funcall (eval ''peek-char)
+                              1 (make-instance 'broken-input-stream))
+                     :test-broken)
+                 (type-error (c)
+                   (return-from return :good))))
+             :good))
+\f
+;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
+(defvar *compiler-note-count* 0)
+#-(or alpha x86-64) ; FIXME: make a better test!
+(handler-bind ((sb-ext:compiler-note (lambda (c)
+                                      (declare (ignore c))
+                                      (incf *compiler-note-count*))))
+  (let ((fun
+        (compile nil
+                 '(lambda (x)
+                   (declare (optimize speed) (fixnum x))
+                   (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+                   (values (* x 5) ; no compiler note from this
+                    (locally
+                      (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+                      ;; this one gives a compiler note
+                      (* x -5)))))))
+    (assert (= *compiler-note-count* 1))
+    (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5)))))
+\f
+(handler-case
+    (eval '(flet ((%f (&key) nil)) (%f nil nil)))
+  (error (c) :good)
+  (:no-error (val) (error "no error: ~S" val)))
+(handler-case
+    (eval '(labels ((%f (&key x) x)) (%f nil nil)))
+  (error (c) :good)
+  (:no-error (val) (error "no error: ~S" val)))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -933,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)