X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=ae0fe96f8494b6fd9f98f40dab9c3c5fed940009;hb=b9a60d8c091096ce7f90073de9b3d26ec7433387;hp=72403638c11e31b121179798bf5b7551c1a20914;hpb=20b2378572cf7378f3f267e2234c4234dacfbdc9;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 7240363..ae0fe96 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1033,6 +1033,8 @@
      215067723)
     13739018))
 
+
+;;;; Bugs in stack analysis
 ;;; bug 299 (reported by PFD)
 (assert
  (equal (funcall
@@ -1044,6 +1046,43 @@
               (if (eval t) (eval '(values :a :b :c)) nil)
               (catch 'foo (throw 'foo (values :x :y)))))))
         '(:a :b :c :x :y)))
+;;; bug 298 (= MISC.183)
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b c)
+                   (declare (type (integer -368154 377964) a))
+                   (declare (type (integer 5044 14959) b))
+                   (declare (type (integer -184859815 -8066427) c))
+                   (declare (ignorable a b c))
+                   (declare (optimize (speed 3)))
+                   (declare (optimize (safety 1)))
+                   (declare (optimize (debug 1)))
+                   (block b7
+                     (flet ((%f3 (f3-1 f3-2 f3-3) 0))
+                       (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
+                0 6000 -9000000)))
+(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
+               '(1 2)))
+(let ((f (compile
+          nil
+          '(lambda (x)
+            (block foo
+              (multiple-value-call #'list
+                :a
+                (block bar
+                  (return-from foo
+                    (multiple-value-call #'list
+                      :b
+                      (block quux
+                        (return-from bar
+                          (catch 'baz
+                            (if x
+                                (return-from quux 1)
+                                (throw 'baz 2))))))))))))))
+  (assert (equal (funcall f t) '(:b 1)))
+  (assert (equal (funcall f nil) '(:a 2))))
+
 ;;; MISC.185
 (assert (equal
          (funcall
@@ -1094,6 +1133,133 @@
                 :good
                 (values result1 result2))))
          :good))
+
+;;; MISC.290
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare
+              (optimize (speed 3) (space 3) (safety 1)
+               (debug 2) (compilation-speed 0)))
+             (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
+
+;;; MISC.292
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b)
+                   (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
+                             (compilation-speed 2)))
+                   (apply (constantly 0)
+                    a
+                    0
+                    (catch 'ct6
+                      (apply (constantly 0)
+                             0
+                             0
+                             (let* ((v1
+                                     (let ((*s7* 0))
+                                       b)))
+                               0)
+                             0
+                             nil))
+                    0
+                    nil)))
+                1 2)))
+
+;;; misc.295
+(assert (eql
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
+             (multiple-value-prog1
+                 (the integer (catch 'ct8 (catch 'ct7 15867134)))
+               (catch 'ct1 (throw 'ct1 0))))))
+         15867134))
+
+;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
+;;; could transform known-values LVAR to UVL
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b c)
+       (declare (notinline boole values denominator list))
+       (declare
+	(optimize (speed 2)
+		  (space 0)
+		  (safety 1)
+		  (debug 0)
+		  (compilation-speed 2)))
+       (catch 'ct6
+	 (progv
+	     '(*s8*)
+	     (list 0)
+	   (let ((v9 (ignore-errors (throw 'ct6 0))))
+	     (denominator
+	      (progv nil nil (values (boole boole-and 0 v9)))))))))
+   1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+  (multiple-value-call #'list
+    (eval '(values 11 12))
+    (eval '(values 13 14))
+    (block ext
+      (return-from non-continuous-stack-test
+        (multiple-value-call #'list
+          (eval '(values :b1 :b2))
+          (eval '(values :b3 :b4))
+          (block int
+            (return-from ext
+              (multiple-value-call (eval #'values)
+                (eval '(values 1 2))
+                (eval '(values 3 4))
+                (block ext
+                  (return-from int
+                    (multiple-value-call (eval #'values)
+                      (eval '(values :a1 :a2))
+                      (eval '(values :a3 :a4))
+                      (block int
+                        (return-from ext
+                          (multiple-value-call (eval #'values)
+                            (eval '(values 5 6))
+                            (eval '(values 7 8))
+                            (if x
+                                :ext
+                                (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+   (compile
+    nil
+    '(lambda (b g h)
+       (declare (optimize (speed 3) (space 3) (safety 2)
+			  (debug 2) (compilation-speed 3)))
+       (catch 'ct5
+	 (unwind-protect
+	     (labels ((%f15 (f15-1 f15-2 f15-3)
+                            (rational (throw 'ct5 0))))
+	       (%f15 0
+		     (apply #'%f15
+			    0
+			    h
+			    (progn
+			      (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+			      0)
+			    nil)
+		     0))
+	   (common-lisp:handler-case 0)))))
+   1 2 3))
+ '(0)))
+
+
 ;;; MISC.275
 (assert
  (zerop
@@ -1134,3 +1300,116 @@
               do
               (dolist (x '(nil t))
                 (assert (eql (funcall f1 x) (funcall f2 x)))))))
+
+;;;
+(handler-case (compile nil '(lambda (x)
+                             (declare (optimize (speed 3) (safety 0)))
+                             (the double-float (sqrt (the double-float x)))))
+  (sb-ext:compiler-note ()
+    (error "Compiler does not trust result type assertion.")))
+
+(let ((f (compile nil '(lambda (x)
+                        (declare (optimize speed (safety 0)))
+                        (block nil
+                          (the double-float
+                            (multiple-value-prog1
+                                (sqrt (the double-float x))
+                              (when (< x 0)
+                                (return :minus)))))))))
+  (assert (eql (funcall f -1d0) :minus))
+  (assert (eql (funcall f 4d0) 2d0)))
+
+;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
+(handler-case
+    (compile nil '(lambda (a i)
+                   (locally
+                     (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                                        (inhibit-warnings 0)))
+                     (declare (type (alien (* (unsigned 8))) a)
+                              (type (unsigned-byte 32) i))
+                     (deref a i))))
+  (compiler-note () (error "The code is not optimized.")))
+
+(handler-case
+    (compile nil '(lambda (x)
+		   (declare (type (integer -100 100) x))
+		   (declare (optimize speed))
+		   (declare (notinline identity))
+		   (1+ (identity x))))
+  (compiler-note () (error "IDENTITY derive-type not applied.")))
+
+(assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
+
+;;; MISC.293 = easy variant of bug 303: repeated write to the same
+;;; LVAR; here the first write may be cleared before the second is
+;;; made.
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda ()
+      (declare (notinline complex))
+      (declare (optimize (speed 1) (space 0) (safety 1)
+                (debug 3) (compilation-speed 3)))
+      (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
+        (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a c)
+     (declare (type (integer -1294746569 1640996137) a))
+     (declare (type (integer -807801310 3) c))
+     (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+     (catch 'ct7
+       (if
+        (logbitp 0
+                 (if (/= 0 a)
+                     c
+                     (ignore-errors
+                       (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+        0 0))))
+   391833530 -32785211)))
+
+;;; efficiency notes for ordinary code
+(macrolet ((frob (arglist &body body)
+	     `(progn
+	       (handler-case
+		   (compile nil '(lambda ,arglist ,@body))
+		 (sb-ext:compiler-note (e)
+		   (error "bad compiler note for ~S:~%  ~A" ',body e)))
+	       (catch :got-note
+		 (handler-case
+		     (compile nil '(lambda ,arglist (declare (optimize speed))
+				    ,@body))
+		   (sb-ext:compiler-note (e) (throw :got-note nil)))
+		 (error "missing compiler note for ~S" ',body)))))
+  (frob (x) (funcall x))
+  (frob (x y) (find x y))
+  (frob (x y) (find-if x y))
+  (frob (x y) (find-if-not x y))
+  (frob (x y) (position x y))
+  (frob (x y) (position-if x y))
+  (frob (x y) (position-if-not x y))
+  (frob (x) (aref x 0)))
+
+(macrolet ((frob (style-warn-p form)
+	     (if style-warn-p
+		 `(catch :got-style-warning
+		   (handler-case
+		       (eval ',form)
+		     (style-warning (e) (throw :got-style-warning nil)))
+		   (error "missing style-warning for ~S" ',form))
+		 `(handler-case
+		   (eval ',form)
+		   (style-warning (e)
+		    (error "bad style-warning for ~S: ~A" ',form e))))))
+  (frob t (lambda (x &optional y &key z) (list x y z)))
+  (frob nil (lambda (x &optional y z) (list x y z)))
+  (frob nil (lambda (x &key y z) (list x y z)))
+  (frob t (defgeneric #:foo (x &optional y &key z)))
+  (frob nil (defgeneric #:foo (x &optional y z)))
+  (frob nil (defgeneric #:foo (x &key y z)))
+  (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))