0.7.10.34:

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 0a530bd..46f15ef 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -669,6 +669,64 @@ BUG 48c, not yet fixed:
   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)))
+\f
+;;; 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-defopt (x)
+  ;; illegal, but should be compilable.
+  (coerce x '(values t)))
+(assert (null (ignore-errors (coerce-defopt 3))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself