X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=46f15ef42f98ac2bd16f704ffd58c618314e13a0;hb=e76ddf242a31a2acaae3a9cb818fa31500ebbf92;hp=9a8458c203d1867f9fa25356b6312db331005300;hpb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;p=sbcl.git

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