X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=16436ff4faa5707f3ee20d241ca9a533afba57d9;hb=9e7a18990d8cfe726edca3450f84510f5676a3e1;hp=8f8d4c32725e7f5bbcec36f5dad460c31f6c9937;hpb=d30da16eea1fe05d17d337c5f392f12736199dc0;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 8f8d4c3..16436ff 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1,3 +1,4 @@
+
 ;;;; various compiler tests without side effects
 
 ;;;; This software is part of the SBCL system. See the README file for
@@ -149,10 +150,11 @@
 
 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
 ;;; a while; fixed by CSR 2002-07-18
-(multiple-value-bind (value error)
-    (ignore-errors (some-undefined-function))
-  (assert (null value))
-  (assert (eq (cell-error-name error) 'some-undefined-function)))
+(with-test (:name :undefined-function-error)
+  (multiple-value-bind (value error)
+      (ignore-errors (some-undefined-function))
+    (assert (null value))
+    (assert (eq (cell-error-name error) 'some-undefined-function))))
 
 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
@@ -4656,3 +4658,115 @@
                         ((some (lambda (c)
                                  (digit-char-p c))
                                string))))))
+
+;; the x87 backend used to sometimes signal FP errors during boxing,
+;; because converting between double and single float values was a
+;; noop (fixed), and no doubt many remaining issues.  We now store
+;; the value outside pseudo-atomic, so any SIGFPE should be handled
+;; corrrectly.
+;;
+;; When it fails, this test lands into ldb.
+(with-test (:name :no-overflow-during-allocation)
+  (handler-case (eval '(cosh 90))
+    (floating-point-overflow ()
+      t)))
+
+;; unbounded integer types could break integer arithmetic.
+(with-test (:name :bug-1199127)
+  (compile nil `(lambda (b)
+                  (declare (type (integer -1225923945345 -832450738898) b))
+                  (declare (optimize (speed 3) (space 3) (safety 2)
+                                     (debug 0) (compilation-speed 1)))
+                  (loop for lv1 below 3
+                        sum (logorc2
+                             (if (>= 0 lv1)
+                                 (ash b (min 25 lv1))
+                                 0)
+                             -2)))))
+
+;; non-trivial modular arithmetic operations would evaluate to wider results
+;; than expected, and never be cut to the right final bitwidth.
+(with-test (:name :bug-1199428-1)
+  (let ((f1 (compile nil `(lambda (a c)
+                            (declare (type (integer -2 1217810089) a))
+                            (declare (type (integer -6895591104928 -561736648588) c))
+                            (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
+                                               (compilation-speed 3)))
+                            (logandc1 (gcd c)
+                                      (+ (- a c)
+                                         (loop for lv2 below 1 count t))))))
+        (f2 (compile nil `(lambda (a c)
+                            (declare (notinline - + gcd logandc1))
+                            (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
+                                               (compilation-speed 3)))
+                            (logandc1 (gcd c)
+                                      (+ (- a c)
+                                         (loop for lv2 below 1 count t)))))))
+    (let ((a 530436387)
+          (c -4890629672277))
+      (assert (eql (funcall f1 a c)
+                   (funcall f2 a c))))))
+
+(with-test (:name :bug-1199428-2)
+  (let ((f1 (compile nil `(lambda (a b)
+                            (declare (type (integer -1869232508 -6939151) a))
+                            (declare (type (integer -11466348357 -2645644006) b))
+                            (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
+                                               (compilation-speed 2)))
+                            (logand (lognand a -6) (* b -502823994)))))
+        (f2 (compile nil `(lambda (a b)
+                            (logand (lognand a -6) (* b -502823994))))))
+    (let ((a -1491588365)
+          (b -3745511761))
+      (assert (eql (funcall f1 a b)
+                   (funcall f2 a b))))))
+
+;; win32 is very specific about the order in which catch blocks
+;; must be allocated on the stack
+(with-test (:name :bug-121581169)
+  (let ((f (compile nil
+                    `(lambda ()
+                       (STRING=
+                        (LET ((% 23))
+                          (WITH-OUTPUT-TO-STRING (G13908)
+                            (PRINC
+                             (LET ()
+                               (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
+                               (HANDLER-CASE
+                                   (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
+                                 (UNBOUND-VARIABLE NIL
+                                   (HANDLER-CASE
+                                       (WITH-OUTPUT-TO-STRING (G13914)
+                                         (PRINC %A%B% G13914)
+                                         (PRINC "" G13914)
+                                         G13914)
+                                     (UNBOUND-VARIABLE NIL
+                                       (HANDLER-CASE
+                                           (WITH-OUTPUT-TO-STRING (G13913)
+                                             (PRINC %A%B G13913)
+                                             (PRINC "%" G13913)
+                                             G13913)
+                                         (UNBOUND-VARIABLE NIL
+                                           (HANDLER-CASE
+                                               (WITH-OUTPUT-TO-STRING (G13912)
+                                                 (PRINC %A% G13912)
+                                                 (PRINC "b%" G13912)
+                                                 G13912)
+                                             (UNBOUND-VARIABLE NIL
+                                               (HANDLER-CASE
+                                                   (WITH-OUTPUT-TO-STRING (G13911)
+                                                     (PRINC %A G13911)
+                                                     (PRINC "%b%" G13911)
+                                                     G13911)
+                                                 (UNBOUND-VARIABLE NIL
+                                                   (HANDLER-CASE
+                                                       (WITH-OUTPUT-TO-STRING (G13910)
+                                                         (PRINC % G13910)
+                                                         (PRINC "a%b%" G13910)
+                                                         G13910)
+                                                     (UNBOUND-VARIABLE NIL
+                                                       (ERROR "Interpolation error in \"%a%b%\"
+"))))))))))))))
+                             G13908)))
+                        "23a%b%")))))
+    (assert (funcall f))))