X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=45d030b7cb539d719ad11041c48c232e09c2d309;hb=8ade1fa8b1ddc95478d2287b4593a80d314b6bd3;hp=db2546253601002da06c4880443bc428377485d4;hpb=e62a03c99097db9454d66f32b5edbd6af874a539;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index db25462..45d030b 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -10,14 +10,13 @@
 ;;;; 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.
 
-(cl:in-package :cl-user)
-
 (load "assertoid.lisp")
+(use-package "ASSERTOID")
 
 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
 ;;; necessarily self-evaluating symbols, but ANSI Common Lisp allows
@@ -47,9 +46,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
@@ -69,8 +68,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.
@@ -85,9 +84,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)
@@ -121,24 +120,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.)
@@ -150,10 +149,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)
@@ -166,7 +165,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
@@ -209,65 +208,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
@@ -289,37 +288,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
@@ -335,7 +342,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
@@ -359,6 +366,563 @@ BUG 48c, not yet fixed:
 
 (raises-error? (foo 3) type-error)
 (raises-error? (foo 3f0) type-error)
+
+;;; until 0.8.2 SBCL did not check THEs in arguments
+(defun the-in-arguments-aux (x)
+  x)
+(defun the-in-arguments-1 (x)
+  (list x (the-in-arguments-aux (the (single-float 0s0) x))))
+(defun the-in-arguments-2 (x)
+  (list x (the-in-arguments-aux (the single-float x))))
+
+(multiple-value-bind (result condition)
+    (ignore-errors (the-in-arguments-1 1))
+  (assert (null result))
+  (assert (typep condition 'type-error)))
+(multiple-value-bind (result condition)
+    (ignore-errors (the-in-arguments-2 1))
+  (assert (null result))
+  (assert (typep condition 'type-error)))
+
+;;; bug 153: a hole in a structure slot type checking
+(declaim (optimize safety))
+(defstruct foo153
+  (bla 0 :type fixnum))
+(defun bug153-1 ()
+  (let ((foo (make-foo153)))
+    (setf (foo153-bla foo) '(1 . 1))
+    (format t "Is ~a of type ~a a cons? => ~a~%"
+            (foo153-bla foo)
+            (type-of (foo153-bla foo))
+            (consp (foo153-bla foo)))))
+(defun bug153-2 (x)
+  (let ((foo (make-foo153)))
+    (setf (foo153-bla foo) x)
+    (format t "Is ~a of type ~a a cons? => ~a~%"
+            (foo153-bla foo)
+            (type-of (foo153-bla foo))
+            (consp (foo153-bla foo)))))
+
+(multiple-value-bind (result condition)
+    (ignore-errors (bug153-1))
+  (declare (ignore result))
+  (assert (typep condition 'type-error)))
+(multiple-value-bind (result condition)
+    (ignore-errors (bug153-2 '(1 . 1)))
+  (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.
+(declaim (ftype (function () null) bug202))
+(defun bug202 ()
+  t)
+
+;;; bugs 178, 199: compiler failed to compile a call of a function
+;;; with a hairy type
+(defun bug178 (x)
+      (funcall (the function (the standard-object x))))
+
+(defun bug199-aux (f)
+  (eq nil (funcall f)))
+
+(defun bug199 (f x)
+  (declare (type (and function (satisfies bug199-aux)) f))
+  (funcall f x))
+
+;;; check non-toplevel DEFMACRO
+(defvar *defmacro-test-status* nil)
+
+(defun defmacro-test ()
+  (fmakunbound 'defmacro-test-aux)
+  (let* ((src "defmacro-test.lisp")
+         (obj (compile-file-pathname src)))
+    (unwind-protect
+         (progn
+           (compile-file src)
+           (assert (equal *defmacro-test-status* '(function a)))
+           (setq *defmacro-test-status* nil)
+           (load obj)
+           (assert (equal *defmacro-test-status* nil))
+           (macroexpand '(defmacro-test-aux 'a))
+           (assert (equal *defmacro-test-status* '(macro 'a z-value)))
+           (eval '(defmacro-test-aux 'a))
+           (assert (equal *defmacro-test-status* '(expanded 'a z-value))))
+      (ignore-errors (delete-file obj)))))
+
+(defmacro-test)
+
+;;; bug 204: EVAL-WHEN inside a local environment
+(defvar *bug204-test-status*)
+
+(defun bug204-test ()
+  (let* ((src "bug204-test.lisp")
+         (obj (compile-file-pathname src)))
+    (unwind-protect
+         (progn
+           (setq *bug204-test-status* nil)
+           (compile-file src)
+           (assert (equal *bug204-test-status* '((:expanded :load-toplevel)
+                                                 (:called :compile-toplevel)
+                                                 (:expanded :compile-toplevel))))
+           (setq *bug204-test-status* nil)
+           (load obj)
+           (assert (equal *bug204-test-status* '((:called :load-toplevel)))))
+      (ignore-errors (delete-file obj)))))
+
+(bug204-test)
+
+;;; toplevel SYMBOL-MACROLET
+(defvar *symbol-macrolet-test-status*)
+
+(defun symbol-macrolet-test ()
+  (let* ((src "symbol-macrolet-test.lisp")
+         (obj (compile-file-pathname src)))
+    (unwind-protect
+         (progn
+           (setq *symbol-macrolet-test-status* nil)
+           (compile-file src)
+           (assert (equal *symbol-macrolet-test-status*
+                          '(2 1)))
+           (setq *symbol-macrolet-test-status* nil)
+           (load obj)
+           (assert (equal *symbol-macrolet-test-status* '(2))))
+      (ignore-errors (delete-file obj)))))
+
+(symbol-macrolet-test)
+
+;;; On the x86, this code failed to compile until sbcl-0.7.8.37:
+(defun x86-assembler-failure (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (eq (setf (car x) 'a) nil))
+
+;;; bug 211: :ALLOW-OTHER-KEYS
+(defun bug211d (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+  (list x x-p y y-p))
+
+(assert (equal (bug211d) '(:x nil :y nil)))
+(assert (equal (bug211d :x 1) '(1 t :y nil)))
+(assert (raises-error? (bug211d :y 2) program-error))
+(assert (equal (bug211d :y 2 :allow-other-keys t :allow-other-keys nil)
+               '(:x nil t t)))
+(assert (raises-error? (bug211d :y 2 :allow-other-keys nil) program-error))
+
+(let ((failure-p
+       (nth-value
+        3
+        (compile 'bug211b
+                 '(lambda ()
+                   (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+                            (list x x-p y y-p)))
+                     (assert (equal (test) '(:x nil :y nil)))
+                     (assert (equal (test :x 1) '(1 t :y nil)))
+                     (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil)
+                                    '(:x nil 11 t)))))))))
+  (assert (not failure-p))
+  (bug211b))
+
+(let ((failure-p
+       (nth-value
+        3
+        (compile 'bug211c
+                 '(lambda ()
+                   (flet ((test (&key (x :x x-p))
+                            (list x x-p)))
+                     (assert (equal (test) '(:x nil)))
+                     (assert (equal (test :x 1) '(1 t)))
+                     (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil)
+                                    '(:x nil)))))))))
+  (assert (not failure-p))
+  (bug211c))
+
+(dolist (form '((test :y 2)
+                (test :y 2 :allow-other-keys nil)
+                (test :y 2 :allow-other-keys nil :allow-other-keys t)))
+  (multiple-value-bind (result warnings-p failure-p)
+      (compile nil `(lambda ()
+                     (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+                              (list x x-p y y-p)))
+                       ,form)))
+    (assert failure-p)
+    (assert (raises-error? (funcall result) program-error))))
+
+;;; bug 217: wrong type inference
+(defun bug217-1 (x s)
+  (let ((f (etypecase x
+             (character #'write-char)
+             (integer #'write-byte))))
+    (funcall f x s)
+    (etypecase x
+      (character (write-char x s))
+      (integer (write-byte x s)))))
+(bug217-1 #\1 *standard-output*)
+
+
+;;; bug 221: tried and died on CSUBTYPEP (not VALUES-SUBTYPEP) of the
+;;; function return types when inferring the type of the IF expression
+(declaim (ftype (function (fixnum) (values package boolean)) bug221f1))
+(declaim (ftype (function (t) (values package boolean)) bug221f2))
+(defun bug221 (b x)
+  (funcall (if b #'bug221f1 #'bug221f2) x))
+
+;;; 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)))))
+
+;;; embedded THEs
+(defun check-embedded-thes (policy1 policy2 x y)
+  (handler-case
+      (funcall (compile nil
+                        `(lambda (f)
+                           (declare (optimize (speed 2) (safety ,policy1)))
+                           (multiple-value-list
+                            (the (values (integer 2 3) t &optional)
+                              (locally (declare (optimize (safety ,policy2)))
+                                (the (values t (single-float 2f0 3f0) &optional)
+                                  (funcall f)))))))
+               (lambda () (values x y)))
+    (type-error (error)
+      error)))
+
+(assert (equal (check-embedded-thes 0 0  :a :b) '(:a :b)))
+
+(assert (equal (check-embedded-thes 0 3  :a 2.5f0) '(:a 2.5f0)))
+(assert (typep (check-embedded-thes 0 3  2 3.5f0) 'type-error))
+
+(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))
+
+(assert (equal (check-embedded-thes 3 0  2 :a) '(2 :a)))
+(assert (typep (check-embedded-thes 3 0  4 2.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 1 0  4 :b) '(4 :b)))
+(assert (typep (check-embedded-thes 1 0  1.0 2.5f0) 'type-error))
+
+
+(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))
+(macrolet ((def (x) `(defun ,x (y) (+ y 1))))
+  (def to-be-inlined))
+(defun call-inlined (z)
+  (to-be-inlined z))
+(assert (= (call-inlined 3) 4))
+(macrolet ((frob (x) `(+ ,x 3)))
+  (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))
+(defun call-inlined (z)
+  (to-be-inlined z))
+(assert (= (call-inlined 3) 6))
+(defun to-be-inlined (y)
+  (+ y 5))
+(assert (= (call-inlined 3) 6))
+
+;;; DEFINE-COMPILER-MACRO to work as expected, not via weird magical
+;;; IR1 pseudo-:COMPILE-TOPLEVEL handling
+(defvar *bug219-a-expanded-p* nil)
+(defun bug219-a (x)
+  (+ x 1))
+(define-compiler-macro bug219-a (&whole form y)
+  (setf *bug219-a-expanded-p* t)
+  (if (constantp y)
+      (+ (eval y) 2)
+      form))
+(defun bug219-a-aux ()
+  (bug219-a 2))
+(assert (= (bug219-a-aux)
+           (if *bug219-a-expanded-p* 4 3)))
+(defvar *bug219-a-temp* 3)
+(assert (= (bug219-a *bug219-a-temp*) 4))
+
+(defvar *bug219-b-expanded-p* nil)
+(defun bug219-b-aux1 (x)
+  (when x
+    (define-compiler-macro bug219-b (y)
+      (setf *bug219-b-expanded-p* t)
+      `(+ ,y 2))))
+(defun bug219-b-aux2 (z)
+  (bug219-b z))
+(assert (not *bug219-b-expanded-p*))
+(assert (raises-error? (bug219-b-aux2 1) undefined-function))
+(bug219-b-aux1 t)
+(defun bug219-b-aux2 (z)
+  (bug219-b z))
+(defun bug219-b (x)
+  x)
+(assert (= (bug219-b-aux2 1)
+           (if *bug219-b-expanded-p* 3 1)))
+
+;;; bug 224: failure in unreachable code deletion
+(defmacro do-optimizations (&body body)
+  `(dotimes (.speed. 4)
+     (dotimes (.space. 4)
+       (dotimes (.debug. 4)
+         (dotimes (.compilation-speed. 4)
+           (proclaim `(optimize (speed , .speed.) (space , .space.)
+                                (debug , .debug.)
+                                (compilation-speed , .compilation-speed.)))
+           ,@body)))))
+
+(do-optimizations
+    (compile nil
+             (read-from-string
+              "(lambda () (#:localy (declare (optimize (safety 3)))
+                                    (ignore-errors (progn (values-list (car (list '(1 . 2)))) t))))")))
+
+(do-optimizations
+    (compile nil '(lambda ()
+                   (labels ((ext ()
+                              (tagbody
+                                 (labels ((i1 () (list (i2) (i2)))
+                                          (i2 () (list (int) (i1)))
+                                          (int () (go :exit)))
+                                   (list (i1) (i1) (i1)))
+                               :exit (return-from ext)
+                                 )))
+                     (list (error "nih") (ext) (ext))))))
+
+(do-optimizations
+  (compile nil '(lambda (x) (let ((y (error ""))) (list x y)))))
+
+;;; bug 223: invalid moving of global function name referencing
+(defun bug223-int (n)
+  `(int ,n))
+
+(defun bug223-wrap ()
+  (let ((old #'bug223-int))
+    (setf (fdefinition 'bug223-int)
+          (lambda (n)
+            (assert (> n 0))
+            `(ext ,@(funcall old (1- n)))))))
+(compile 'bug223-wrap)
+
+(assert (equal (bug223-int 4) '(int 4)))
+(bug223-wrap)
+(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
@@ -376,55 +940,187 @@ 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))))
+
 ;;; success
-(quit :unix-status 104)