X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=caf24e7c5cc7861937b5d42e77c76175f1ab1c4d;hb=41d822d26e0ffee4be348ebf35e19caff0c858e1;hp=869cd5a460e5d89672376872a84e671a7aee1299;hpb=f3c33b9dccb849bedd48f82bc67102484d1ede79;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 869cd5a..caf24e7 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -10,12 +10,14 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "test-util.lisp")
 (load "assertoid.lisp")
+(use-package "TEST-UTIL")
 (use-package "ASSERTOID")
 
 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
@@ -46,9 +48,9 @@
   (let (num x)
     (flet ((digs ()
              (setq num index))
-	   (z ()
-	     (let ()
-	       (setq x nil))))
+           (z ()
+             (let ()
+               (setq x nil))))
       (when (and (digs) (digs)) x))))
 
 ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH
@@ -68,8 +70,8 @@
     (flet ((wufn () (glorp table1 4.9)))
       (gleep *uustk* #'wufn "#1" (list)))
     (if (eql (lo foomax 3.2))
-	(values)
-	(error "not ~S" '(eql (lo foomax 3.2))))
+        (values)
+        (error "not ~S" '(eql (lo foomax 3.2))))
     (values)))
 ;;; A simpler test case for bug 150: The compiler died with the
 ;;; same type error when trying to compile this.
@@ -84,9 +86,9 @@
 (defun bug147 (string ind)
   (flet ((digs ()
            (let (old-index)
-	     (if (and (< ind ind)
-		      (typep (char string ind) '(member #\1)))
-		 nil))))))
+             (if (and (< ind ind)
+                      (typep (char string ind) '(member #\1)))
+                 nil))))))
 
 ;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13
 (defmacro foo-2002-05-13 () ''x)
@@ -120,24 +122,24 @@
 (defstruct something-known-to-be-a-struct x y)
 (multiple-value-bind (fun warnings-p failure-p)
     (compile nil
-	     '(lambda ()
-		(labels ((a1 (a2 a3)
-			     (cond (t (a4 a2 a3))))
-			 (a4 (a2 a3 a5 a6)
-			     (declare (type (or simple-vector null) a5 a6))
-			     (something-known-to-be-a-struct-x a5))
-			 (a8 (a2 a3)
-			     (a9 #'a1 a10 a2 a3))
-			 (a11 (a2 a3)
-			      (cond ((and (funcall a12 a2)
-					  (funcall a12 a3))
-				     (funcall a13 a2 a3))
-				    (t
-				     (when a14
-				     (let ((a15 (a1 a2 a3)))
-				       ))
-				     a16))))
-		  (values #'a17 #'a11))))
+             '(lambda ()
+                (labels ((a1 (a2 a3)
+                             (cond (t (a4 a2 a3))))
+                         (a4 (a2 a3 a5 a6)
+                             (declare (type (or simple-vector null) a5 a6))
+                             (something-known-to-be-a-struct-x a5))
+                         (a8 (a2 a3)
+                             (a9 #'a1 a10 a2 a3))
+                         (a11 (a2 a3)
+                              (cond ((and (funcall a12 a2)
+                                          (funcall a12 a3))
+                                     (funcall a13 a2 a3))
+                                    (t
+                                     (when a14
+                                     (let ((a15 (a1 a2 a3)))
+                                       ))
+                                     a16))))
+                  (values #'a17 #'a11))))
   ;; Python sees the structure accessor on the known-not-to-be-a-struct
   ;; A5 value and is very, very disappointed in you. (But it doesn't
   ;; signal BUG any more.)
@@ -149,10 +151,10 @@
 ;;; spotted and fixed by Raymond Toy for CMUCL)
 (defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
   (declare (type (unsigned-byte 32) a0)
-	   (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
-	   ;; to ensure that the call is a candidate for
-	   ;; transformation
-	   (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0)))
+           (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+           ;; to ensure that the call is a candidate for
+           ;; transformation
+           (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0)))
   (values
    ;; the call that fails compilation
    (logand a0 a10)
@@ -165,7 +167,7 @@
 ;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so
 ;;; it would fail.
 (defun bug192 ()
-      (funcall 
+      (funcall
        (LAMBDA (TEXT I L )
          (LABELS ((G908 (I)
                     (LET ((INDEX
@@ -208,65 +210,65 @@
   (labels
     ((alpha-equal-bound-term-lists (listx listy)
        (or (and (null listx) (null listy))
-	   (and listx listy
-		(let ((bindings-x (bindings-of-bound-term (car listx)))
-		      (bindings-y (bindings-of-bound-term (car listy))))
-		  (if (and (null bindings-x) (null bindings-y))
-		      (alpha-equal-terms (term-of-bound-term (car listx))
-					 (term-of-bound-term (car listy)))
-		      (and (= (length bindings-x) (length bindings-y))
-			   (prog2
-			       (enter-binding-pairs (bindings-of-bound-term (car listx))
-						    (bindings-of-bound-term (car listy)))
-			       (alpha-equal-terms (term-of-bound-term (car listx))
-						  (term-of-bound-term (car listy)))
-			     (exit-binding-pairs (bindings-of-bound-term (car listx))
-						 (bindings-of-bound-term (car listy)))))))
-		(alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
+           (and listx listy
+                (let ((bindings-x (bindings-of-bound-term (car listx)))
+                      (bindings-y (bindings-of-bound-term (car listy))))
+                  (if (and (null bindings-x) (null bindings-y))
+                      (alpha-equal-terms (term-of-bound-term (car listx))
+                                         (term-of-bound-term (car listy)))
+                      (and (= (length bindings-x) (length bindings-y))
+                           (prog2
+                               (enter-binding-pairs (bindings-of-bound-term (car listx))
+                                                    (bindings-of-bound-term (car listy)))
+                               (alpha-equal-terms (term-of-bound-term (car listx))
+                                                  (term-of-bound-term (car listy)))
+                             (exit-binding-pairs (bindings-of-bound-term (car listx))
+                                                 (bindings-of-bound-term (car listy)))))))
+                (alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
 
      (alpha-equal-terms (termx termy)
        (if (and (variable-p termx)
-		(variable-p termy))
-	   (equal-bindings (id-of-variable-term termx)
-			   (id-of-variable-term termy))
-	   (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
-		(alpha-equal-bound-term-lists (bound-terms-of-term termx)
-					      (bound-terms-of-term termy))))))
+                (variable-p termy))
+           (equal-bindings (id-of-variable-term termx)
+                           (id-of-variable-term termy))
+           (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
+                (alpha-equal-bound-term-lists (bound-terms-of-term termx)
+                                              (bound-terms-of-term termy))))))
 
     (or (eq termx termy)
-	(and termx termy
-	     (with-variable-invocation (alpha-equal-terms termx termy))))))
+        (and termx termy
+             (with-variable-invocation (alpha-equal-terms termx termy))))))
 (defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28
   ;; Given an FSSP alignment file named by the argument . . .
   (labels ((get-fssp-char ()
-	     (get-fssp-char))
-	   (read-fssp-char ()
-	     (get-fssp-char)))
+             (get-fssp-char))
+           (read-fssp-char ()
+             (get-fssp-char)))
     ;; Stub body, enough to tickle the bug.
     (list (read-fssp-char)
-	  (read-fssp-char))))
+          (read-fssp-char))))
 (defun bug70 ; from David Young cmucl-help 30 Nov 2000
     (item sequence &key (test #'eql))
   (labels ((find-item (obj seq test &optional (val nil))
-		      (let ((item (first seq)))
-			(cond ((null seq)
-			       (values nil nil))
-			      ((funcall test obj item)
-			       (values val seq))
-			      (t	
-			       (find-item obj
-					  (rest seq)
-					  test
-					  (nconc val `(,item))))))))
+                      (let ((item (first seq)))
+                        (cond ((null seq)
+                               (values nil nil))
+                              ((funcall test obj item)
+                               (values val seq))
+                              (t
+                               (find-item obj
+                                          (rest seq)
+                                          test
+                                          (nconc val `(,item))))))))
     (find-item item sequence test)))
 (defun bug109 () ; originally from CMU CL bugs collection, reported as
                  ; SBCL bug by MNA 2001-06-25
-  (labels 
+  (labels
       ((eff (&key trouble)
-	    (eff)
-	    ;; nil
-	    ;; Uncomment and it works
-	    ))
+            (eff)
+            ;; nil
+            ;; Uncomment and it works
+            ))
     (eff)))
 
 ;;; bug 192a, fixed by APD "more strict type checking" patch
@@ -288,37 +290,45 @@
 ;;; bug 194, fixed in part by APD "more strict type checking" patch
 ;;; (sbcl-devel 2002-08-07)
 (progn
-  #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
   (multiple-value-bind (result error)
       (ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3)))))
     (assert (null result))
     (assert (typep error 'type-error)))
-  #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
   (multiple-value-bind (result error)
       (ignore-errors (the real '(1 2 3)))
     (assert (null result))
     (assert (typep error 'type-error))))
+
+(defun bug194d ()
+  (null (ignore-errors
+          (let ((arg1 1)
+                (arg2 (identity (the real #(1 2 3)))))
+            (if (< arg1 arg2) arg1 arg2)))))
+(assert (eq (bug194d) t))
+
 
 ;;; 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 ()
-		(symbol-macrolet ((*standard-input* nil))
-		  *standard-input*)))
+             '(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)
   (assert (raises-error? (funcall function) program-error)))
-#||
-BUG 48c, not yet fixed:
 (multiple-value-bind (function warnings-p failure-p)
     (compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s)))
   (assert failure-p)
   (assert (raises-error? (funcall function) program-error)))
-||#
 
 ;;; bug 120a: Turned out to be constraining code looking like (if foo
 ;;; <X> <X>) where <X> was optimized by the compiler to be the exact
@@ -334,7 +344,7 @@ BUG 48c, not yet fixed:
   (declare (optimize (speed 3) (safety 1) (debug 1)))
   (if x t (if y t (dont-constrain-if-too-much x y))))
 
-(assert (null (dont-constrain-if-too-much-aux nil nil)))  
+(assert (null (dont-constrain-if-too-much-aux nil nil)))
 
 ;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by
 ;;; APD sbcl-devel 2002-09-14
@@ -404,21 +414,22 @@ BUG 48c, not yet fixed:
   (declare (ignore result))
   (assert (typep condition 'type-error)))
 
-;;; bug 110: the compiler flushed the argument type test and the default
-;;; case in the cond.
-
-(defun bug110 (x)
-  (declare (optimize (safety 2) (speed 3)))
-  (declare (type (or string stream) x))
-  (cond ((typep x 'string) 'string)
-        ((typep x 'stream) 'stream)
-        (t
-         'none)))
-
-(multiple-value-bind (result condition)
-    (ignore-errors (bug110 0))
-  (declare (ignore result))
-  (assert (typep condition 'type-error)))
+;;;; bug 110: the compiler flushed the argument type test and the default
+;;;; case in the cond.
+;
+;(locally (declare (optimize (safety 3) (speed 2)))
+;  (defun bug110 (x)
+;    (declare (optimize (safety 2) (speed 3)))
+;    (declare (type (or string stream) x))
+;    (cond ((typep x 'string) 'string)
+;          ((typep x 'stream) 'stream)
+;          (t
+;           'none))))
+;
+;(multiple-value-bind (result condition)
+;    (ignore-errors (bug110 0))
+;  (declare (ignore result))
+;  (assert (typep condition 'type-error)))
 
 ;;; bug 202: the compiler failed to compile a function, which derived
 ;;; type contradicted declared.
@@ -576,7 +587,7 @@ BUG 48c, not yet fixed:
 ;;; bug 172: macro lambda lists were too permissive until 0.7.9.28
 ;;; (fix provided by Matthew Danish) on sbcl-devel
 (assert (null (ignore-errors
-		(defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
+                (defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
 
 ;;; embedded THEs
 (defun check-embedded-thes (policy1 policy2 x y)
@@ -585,9 +596,9 @@ BUG 48c, not yet fixed:
                         `(lambda (f)
                            (declare (optimize (speed 2) (safety ,policy1)))
                            (multiple-value-list
-                            (the (values (integer 2 3) t)
+                            (the (values (integer 2 3) t &optional)
                               (locally (declare (optimize (safety ,policy2)))
-                                (the (values t (single-float 2f0 3f0))
+                                (the (values t (single-float 2f0 3f0) &optional)
                                   (funcall f)))))))
                (lambda () (values x y)))
     (type-error (error)
@@ -601,7 +612,6 @@ BUG 48c, not yet fixed:
 (assert (equal (check-embedded-thes 0 1  :a 3.5f0) '(:a 3.5f0)))
 (assert (typep (check-embedded-thes 0 1  2 2.5d0) 'type-error))
 
-#+nil
 (assert (equal (check-embedded-thes 3 0  2 :a) '(2 :a)))
 (assert (typep (check-embedded-thes 3 0  4 2.5f0) 'type-error))
 
@@ -612,7 +622,6 @@ BUG 48c, not yet fixed:
 (assert (equal (check-embedded-thes 3 3  2 2.5f0) '(2 2.5f0)))
 (assert (typep (check-embedded-thes 3 3  0 2.5f0) 'type-error))
 (assert (typep (check-embedded-thes 3 3  2 3.5f0) 'type-error))
-
 
 ;;; INLINE inside MACROLET
 (declaim (inline to-be-inlined))
@@ -625,9 +634,9 @@ BUG 48c, not yet fixed:
   (defun to-be-inlined (y)
     (frob y)))
 (assert (= (call-inlined 3)
-	   ;; we should have inlined the previous definition, so the
-	   ;; new one won't show up yet.
-	   4))
+           ;; we should have inlined the previous definition, so the
+           ;; new one won't show up yet.
+           4))
 (defun call-inlined (z)
   (to-be-inlined z))
 (assert (= (call-inlined 3) 6))
@@ -648,7 +657,7 @@ BUG 48c, not yet fixed:
 (defun bug219-a-aux ()
   (bug219-a 2))
 (assert (= (bug219-a-aux)
-	   (if *bug219-a-expanded-p* 4 3)))
+           (if *bug219-a-expanded-p* 4 3)))
 (defvar *bug219-a-temp* 3)
 (assert (= (bug219-a *bug219-a-temp*) 4))
 
@@ -668,7 +677,7 @@ BUG 48c, not yet fixed:
 (defun bug219-b (x)
   x)
 (assert (= (bug219-b-aux2 1)
-	   (if *bug219-b-expanded-p* 3 1)))
+           (if *bug219-b-expanded-p* 3 1)))
 
 ;;; bug 224: failure in unreachable code deletion
 (defmacro do-optimizations (&body body)
@@ -719,7 +728,203 @@ BUG 48c, not yet fixed:
 (assert (equal (bug223-int 4) '(ext int 3)))
 (bug223-wrap)
 (assert (equal (bug223-int 4) '(ext ext int 2)))
+
+;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of
+;;; SPECIFIER-TYPE-NTH-ARG.  For a while, an illegal type would throw
+;;; you into the debugger on compilation.
+(defun coerce-defopt1 (x)
+  ;; illegal, but should be compilable.
+  (coerce x '(values t)))
+(defun coerce-defopt2 (x)
+  ;; illegal, but should be compilable.
+  (coerce x '(values t &optional)))
+(assert (null (ignore-errors (coerce-defopt1 3))))
+(assert (null (ignore-errors (coerce-defopt2 3))))
+
+;;; Oops.  In part of the (CATCH ..) implementation of DEBUG-RETURN,
+;;; it was possible to confuse the type deriver of the compiler
+;;; sufficiently that compiler invariants were broken (explained by
+;;; APD sbcl-devel 2003-01-11).
+
+;;; WHN's original report
+(defun debug-return-catch-break1 ()
+  (with-open-file (s "/tmp/foo"
+                     :direction :output
+                     :element-type (list
+                                    'signed-byte
+                                    (1+
+                                     (integer-length most-positive-fixnum))))
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)))
+
+;;; APD's simplified test case
+(defun debug-return-catch-break2 (x)
+  (declare (type (vector (unsigned-byte 8)) x))
+  (setq *y* (the (unsigned-byte 8) (aref x 4))))
+
+;;; FUNCTION-LAMBDA-EXPRESSION should return something that's COMPILE
+;;; can understand.  Here's a simple test for that on a function
+;;; that's likely to return a hairier list than just a lambda:
+(macrolet ((def (fn) `(progn
+                       (declaim (inline ,fn))
+                       (defun ,fn (x) (1+ x)))))
+  (def bug228))
+(let ((x (function-lambda-expression #'bug228)))
+  (when x
+    (assert (= (funcall (compile nil x) 1) 2))))
 
+;;;
+(defun bug192b (i)
+  (dotimes (j i)
+    (declare (type (mod 4) i))
+    (unless (< i 5)
+      (print j))))
+(assert (raises-error? (bug192b 6) type-error))
+
+(defun bug192c (x y)
+  (locally (declare (type fixnum x y))
+    (+ x (* 2 y))))
+(assert (raises-error? (bug192c 1.1 2) type-error))
+
+(assert (raises-error? (progn (the real (list 1)) t) type-error))
+
+(defun bug236 (a f)
+  (declare (optimize (speed 2) (safety 0)))
+  (+ 1d0
+     (the double-float
+       (multiple-value-prog1
+           (svref a 0)
+         (unless f (return-from bug236 0))))))
+(assert (eql (bug236 #(4) nil) 0))
+
+;;; Bug reported by reported by rif on c.l.l 2003-03-05
+(defun test-type-of-special-1 (x)
+  (declare (special x)
+           (fixnum x)
+           (optimize (safety 3)))
+  (list x))
+(defun test-type-of-special-2 (x)
+  (declare (special x)
+           (fixnum x)
+           (optimize (safety 3)))
+  (list x (setq x (/ x 2)) x))
+(assert (raises-error? (test-type-of-special-1 3/2) type-error))
+(assert (raises-error? (test-type-of-special-2 3) type-error))
+(assert (equal (test-type-of-special-2 8) '(8 4 4)))
+
+;;; bug which existed in 0.8alpha.0.4 for several milliseconds before
+;;; APD fixed it in 0.8alpha.0.5
+(defun frob8alpha04 (x y)
+  (+ x y))
+(defun baz8alpha04 (this kids)
+  (flet ((n-i (&rest rest)
+           ;; Removing the #+NIL here makes the bug go away.
+           #+nil (format t "~&in N-I REST=~S~%" rest)
+           (apply #'frob8alpha04 this rest)))
+    (n-i kids)))
+;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
+(assert (= (baz8alpha04 12 13) 25))
+
+;;; evaluation order in structure slot writers
+(defstruct sswo
+  a b)
+(let* ((i 0)
+       (s (make-sswo :a (incf i) :b (incf i)))
+       (l (list s :v)))
+  (assert (= (sswo-a s) 1))
+  (assert (= (sswo-b s) 2))
+  (setf (sswo-a (pop l)) (pop l))
+  (assert (eq l nil))
+  (assert (eq (sswo-a s) :v)))
+
+(defun bug249 (x)
+  (flet ((bar (y)
+           (declare (fixnum y))
+           (incf x)))
+    (list (bar x) (bar x) (bar x))))
+
+(assert (raises-error? (bug249 1.0) type-error))
+
+;;; bug reported by ohler on #lisp 2003-07-10
+(defun bug-ohler-2003-07-10 (a b)
+  (declare (optimize (speed 0) (safety 3) (space 0)
+                     (debug 1) (compilation-speed 0)))
+  (adjoin a b))
+
+;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14:
+;;; COMPILE-FILE did not bind *READTABLE*
+(let* ((source "bug-doug-mcnaught-20030914.lisp")
+       (fasl (compile-file-pathname source)))
+  (labels ((check ()
+             (assert (null (get-macro-character #\]))))
+           (full-check ()
+             (check)
+             (assert (typep *bug-doug-mcnaught-20030914*
+                            '(simple-array (unsigned-byte 4) (*))))
+             (assert (equalp *bug-doug-mcnaught-20030914* #(1 2 3)))
+             (makunbound '*bug-doug-mcnaught-20030914*)))
+    (compile-file source)
+    (check)
+    (load fasl)
+    (full-check)
+    (load source)
+    (full-check)
+    (delete-file fasl)))
+
+(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))
+
+;;;; 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)))))
+
+(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)))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -737,55 +942,389 @@ BUG 48c, not yet fixed:
   (dolist (template (fun-info-templates (info :function :info function)))
     (when (template-more-results-type template)
       (format t "~&Template ~A has :MORE results, and translates ~A.~%"
-	      (template-name template)
-	      function)
+              (template-name template)
+              function)
       (return nil))
     (when (eq (template-result-types template) :conditional)
       ;; dunno.
       (return t))
     (let ((types (template-result-types template))
-	  (result-type (fun-type-returns (info :function :type function))))
+          (result-type (fun-type-returns (info :function :type function))))
       (cond
-	((values-type-p result-type)
-	 (do ((ltypes (append (args-type-required result-type)
-			      (args-type-optional result-type))
-		      (rest ltypes))
-	      (types types (rest types)))
-	     ((null ltypes)
-	      (unless (null types)
-		(format t "~&More types than ltypes in ~A, translating ~A.~%"
-			(template-name template)
-			function)
-		(return nil)))
-	   (when (null types)
-	     (unless (null ltypes)
-	       (format t "~&More ltypes than types in ~A, translating ~A.~%"
-		       (template-name template)
-		       function)
-	       (return nil)))))
-	((eq result-type (specifier-type nil))
-	 (unless (null types)
-	   (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
-		   (template-name template)
-		   function)
-	   (return nil)))
-	((/= (length types) 1)
-	 (format t "~&Template ~A isn't returning 1 value for ~A.~%"
-		 (template-name template)
-		 function)
-	 (return nil))
-	(t t)))))
+        ((values-type-p result-type)
+         (do ((ltypes (append (args-type-required result-type)
+                              (args-type-optional result-type))
+                      (rest ltypes))
+              (types types (rest types)))
+             ((null ltypes)
+              (unless (null types)
+                (format t "~&More types than ltypes in ~A, translating ~A.~%"
+                        (template-name template)
+                        function)
+                (return nil)))
+           (when (null types)
+             (unless (null ltypes)
+               (format t "~&More ltypes than types in ~A, translating ~A.~%"
+                       (template-name template)
+                       function)
+               (return nil)))))
+        ((eq result-type (specifier-type nil))
+         (unless (null types)
+           (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
+                   (template-name template)
+                   function)
+           (return nil)))
+        ((/= (length types) 1)
+         (format t "~&Template ~A isn't returning 1 value for ~A.~%"
+                 (template-name template)
+                 function)
+         (return nil))
+        (t t)))))
 (defun identify-suspect-vops (&optional (env (first
-					      (last *info-environment*))))
+                                              (last *info-environment*))))
   (do-info (env :class class :type type :name name :value value)
     (when (and (eq class :function) (eq type :type))
       ;; OK, so we have an entry in the INFO database. Now, if ...
       (let* ((info (info :function :info name))
-	     (templates (and info (fun-info-templates info))))
-	(when templates
-	  ;; ... it has translators
-	  (grovel-results name))))))
+             (templates (and info (fun-info-templates info))))
+        (when templates
+          ;; ... it has translators
+          (grovel-results name))))))
 (identify-suspect-vops)
 
+;;;; 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)))))
+
+;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM).
+(handler-bind ((compiler-note #'error))
+  (let ((f1 (compile nil '(lambda (x1 y1)
+                           (declare (type (or symbol fixnum) x1)
+                                    (optimize speed))
+                           (eql x1 y1))))
+        (f2 (compile nil '(lambda (x2 y2)
+                           (declare (type (or symbol fixnum) y2)
+                                    (optimize speed))
+                           (eql x2 y2)))))
+    (let ((fix (random most-positive-fixnum))
+          (sym (gensym))
+          (e-count 0))
+      (assert (funcall f1 fix fix))
+      (assert (funcall f2 fix fix))
+      (assert (funcall f1 sym sym))
+      (assert (funcall f2 sym sym))
+      (handler-bind ((type-error (lambda (c)
+                                   (incf e-count)
+                                   (continue c))))
+        (flet ((test (f x y)
+                 (with-simple-restart (continue "continue with next test")
+                   (funcall f x y)
+                   (error "fell through with (~S ~S ~S)" f x y))))
+          (test f1 "oops" 42)
+          (test f1 (1+ most-positive-fixnum) 42)
+          (test f2 42 "oops")
+          (test f2 42 (1+ most-positive-fixnum))))
+      (assert (= e-count 4)))))
+
+;;; bug #389 (Rick Taube sbcl-devel)
+(defun bes-jn (unn ux)
+   (let ((nn unn) (x ux))
+     (let* ((n (floor (abs nn)))
+            (besn
+             (if (= n 0)
+                 (bes-j0 x)
+                 (if (= n 1)
+                     (bes-j1 x)
+                     (if (zerop x)
+                         0.0
+                         (let ((iacc 40)
+                               (ans 0.0)
+                               (bigno 1.0e+10)
+                               (bigni 1.0e-10))
+                           (if (> (abs x) n)
+                               (do ((tox (/ 2.0 (abs x)))
+                                    (bjm (bes-j0 (abs x)))
+                                    (bj (bes-j1 (abs x)))
+                                    (j 1 (+ j 1))
+                                    (bjp 0.0))
+                                   ((= j n) (setf ans bj))
+                                 (setf bjp (- (* j tox bj) bjm))
+                                 (setf bjm bj)
+                                 (setf bj bjp))
+                               (let ((tox (/ 2.0 (abs x)))
+                                     (m
+                                      (* 2
+                                         (floor
+                                          (/ (+ n (sqrt (* iacc n)))
+                                             2))))
+                                     (jsum 0.0)
+                                     (bjm 0.0)
+                                     (sum 0.0)
+                                     (bjp 0.0)
+                                     (bj 1.0))
+                                 (do ((j m (- j 1)))
+                                     ((= j 0))
+                                   (setf bjm (- (* j tox bj) bjp))
+                                   (setf bjp bj)
+                                   (setf bj bjm)
+                                   (when (> (abs bj) bigno)
+                                     (setf bj (* bj bigni))
+                                     (setf bjp (* bjp bigni))
+                                     (setf ans (* ans bigni))
+                                     (setf sum (* sum bigni)))
+                                   (if (not (= 0 jsum)) (incf sum bj))
+                                   (setf jsum (- 1 jsum))
+                                   (if (= j n) (setf ans bjp)))
+                                 (setf sum (- (* 2.0 sum) bj))
+                                 (setf ans (/ ans sum))))
+                           (if (and (minusp x) (oddp n))
+                               (- ans)
+                               ans)))))))
+       (if (and (minusp nn) (oddp nn)) (- besn) besn))))
+
+
+;;; bug 233b: lvar lambda-var equality in constraint propagation
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/ref ()
+  (let ((x nil))
+    (if (multiple-value-prog1 x (setq x t))
+        1
+        x)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :ref))
+  (assert (eq t (test-constraint-propagation/ref))))
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/typep (x y)
+  (if (typep (multiple-value-prog1 x (setq x y))
+             'double-float)
+      (+ x 1d0)
+      (+ x 2)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :typep))
+  (assert (= 6.0d0 (test-constraint-propagation/typep 1d0 5))))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :eq/eql))
+  (assert (eq :right (let ((c :wrong))
+                       (if (eq (let ((x c))
+                                 (setq c :right)
+                                 x)
+                               :wrong)
+                           c
+                           0)))))
+
+;;; Put this in a separate function.
+(defun test-constraint-propagation/cast (x)
+  (when (the double-float (multiple-value-prog1
+                              x
+                            (setq x (1+ x))))
+    x))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :cast))
+  (assert (assertoid:raises-error?
+           (test-constraint-propagation/cast 1) type-error)))
+
+;;; bug #399
+(let ((result (make-array 50000 :fill-pointer 0 :adjustable t)))
+  (defun string->html (string &optional (max-length nil))
+    (when (and (numberp max-length)
+               (> max-length (array-dimension result 0)))
+      (setf result (make-array max-length :fill-pointer 0 :adjustable t)))
+    (let ((index 0)
+          (left-quote? t))
+      (labels ((add-char (it)
+                 (setf (aref result index) it)
+                 (incf index))
+               (add-string (it)
+                 (loop for ch across it do
+                       (add-char ch))))
+        (loop for char across string do
+              (cond ((char= char #\<)
+                     (add-string "&lt;"))
+                    ((char= char #\>)
+                     (add-string "&gt;"))
+                    ((char= char #\&)
+                     (add-string "&amp;"))
+                    ((char= char #\')
+                     (add-string "&#39;"))
+                    ((char= char #\newline)
+                     (add-string "<br>"))
+                    ((char= char #\")
+                     (if left-quote? (add-string "&#147;") (add-string "&#148;"))
+                     (setf left-quote? (not left-quote?)))
+                    (t
+                     (add-char char))))
+        (setf (fill-pointer result) index)
+        (coerce result 'string)))))
+
+;;; Callign thru constant symbols
+(require :sb-introspect)
+
+(declaim (inline target-fun))
+(defun target-fun (arg0 arg1)
+  (+ arg0 arg1))
+(declaim (notinline target-fun))
+
+(defun test-target-fun-called (fun res)
+  (assert (member #'target-fun
+                  (sb-introspect:find-function-callees #'caller-fun-1)))
+  (assert (equal (funcall fun) res)))
+
+(defun caller-fun-1 ()
+  (funcall 'target-fun 1 2))
+(test-target-fun-called #'caller-fun-1 3)
+
+(defun caller-fun-2 ()
+  (declare (inline target-fun))
+  (apply 'target-fun 1 '(3)))
+(test-target-fun-called #'caller-fun-2 4)
+
+(defun caller-fun-3 ()
+  (flet ((target-fun (a b)
+           (- a b)))
+    (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
+(test-target-fun-called #'caller-fun-3 (list -3 5))
+
+;;; Reported by NIIMI Satoshi
+;;; Subject: [Sbcl-devel] compilation error with optimization
+;;; Date: Sun, 09 Apr 2006 17:36:05 +0900
+(defun test-minimal-debug-info-for-unstored-but-used-parameter (n a)
+  (declare (optimize (speed 3)
+                     (debug 1)))
+  (if (= n 0)
+      0
+      (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a)))
+
+;;; &KEY arguments with non-constant defaults.
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+(defstruct tricky-defaults
+  (fun #'identity :type function)
+  (num (opaque-identity 3) :type fixnum))
+(macrolet ((frob (form expected-expected-type)
+             `(handler-case ,form
+               (type-error (c) (assert (eq (type-error-expected-type c)
+                                           ',expected-expected-type)))
+               (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals)))))
+  (frob (make-tricky-defaults :fun 3) function)
+  (frob (make-tricky-defaults :num #'identity) fixnum))
+
+(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3)))
+                          (declare (optimize safety) (type integer key))
+                          key))))
+  (assert (= (funcall fun) 3))
+  (assert (= (funcall fun :key 17) 17))
+  (handler-case (funcall fun :key t)
+    (type-error (c) (assert (eq (type-error-expected-type c) 'integer)))
+    (:no-error (&rest vals) (error "no error"))))
+
+;;; Basic compiler-macro expansion
+(define-compiler-macro test-cmacro-0 () ''expanded)
+
+(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
+
+;;; FUNCALL forms in compiler macros, lambda-list parsing
+(define-compiler-macro test-cmacro-1
+    (&whole whole a &optional b &rest c &key d)
+  (list whole a b c d))
+
+(macrolet ((test (form a b c d)
+             `(let ((form ',form))
+                (destructuring-bind (whole a b c d)
+                    (funcall (compiler-macro-function 'test-cmacro-1) form nil)
+                  (assert (equal whole form))
+                  (assert (eql a ,a))
+                  (assert (eql b ,b))
+                  (assert (equal c ,c))
+                  (assert (eql d ,d))))) )
+  (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3)
+  (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13))
+
+;;; FUNCALL forms in compiler macros, expansions
+(define-compiler-macro test-cmacro-2 () ''ok)
+
+(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
+
+;;; Shadowing of compiler-macros by local functions
+(define-compiler-macro test-cmacro-3 () ''global)
+
+(defmacro find-cmacro-3 (&environment env)
+  (compiler-macro-function 'test-cmacro-3 env))
+
+(assert (funcall (lambda () (find-cmacro-3))))
+(assert (not (funcall (lambda () (flet ((test-cmacro-3 ()))
+                                   (find-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                         (test-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                         (funcall #'test-cmacro-3))))))
+(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+                                          (funcall 'test-cmacro-3))))))
+
+;;; Local NOTINLINE & INLINE
+(defun test-cmacro-4 () 'fun)
+(define-compiler-macro test-cmacro-4 () ''macro)
+
+(assert (eq 'fun (funcall (lambda ()
+                            (declare (notinline test-cmacro-4))
+                            (test-cmacro-4)))))
+
+(assert (eq 'macro (funcall (lambda ()
+                              (declare (inline test-cmacro-4))
+                              (test-cmacro-4)))))
+
+;;; Step instrumentation breaking type-inference
+(handler-bind ((warning #'error))
+  (assert (= 42 (funcall (compile nil '(lambda (v x)
+                                        (declare (optimize sb-c:insert-step-conditions))
+                                        (if (typep (the function x) 'fixnum)
+                                            (svref v (the function x))
+                                            (funcall x))))
+                         nil (constantly 42)))))
+
 ;;; success
-(quit :unix-status 104)