X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=1a398d3bf5e49b837997688b2b8c6468892ba6ad;hb=3641e3c73615bffcdd9c014e6663d80935e985ef;hp=8f8d4c32725e7f5bbcec36f5dad460c31f6c9937;hpb=d30da16eea1fe05d17d337c5f392f12736199dc0;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 8f8d4c3..1a398d3 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.) @@ -2984,8 +2986,8 @@ (compile nil `(lambda (x) (declare (character x) (optimize speed)) (,name x)))) - (dolist (name '(char= char/= char< char> char<= char>= char-equal - char-not-equal char-lessp char-greaterp char-not-greaterp + (dolist (name '(char= char/= char< char> char<= char>= + char-lessp char-greaterp char-not-greaterp char-not-lessp)) (setf current name) (compile nil `(lambda (x y) @@ -4656,3 +4658,167 @@ ((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)))) + +(with-test (:name :equal-equalp-transforms) + (let* ((s "foo") + (bit-vector #*11001100) + (values `(nil 1 2 "test" + ;; Floats duplicated here to ensure we get newly created instances + (read-from-string "1.1") (read-from-string "1.2d0") + (read-from-string "1.1") (read-from-string "1.2d0") + 1.1 1.2d0 '("foo" "bar" "test") + #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file" + ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector) + ,(make-hash-table) #\a #\b #\A #\C + ,(make-random-state) 1/2 2/3))) + ;; Test all permutations of different types + (assert + (loop + for x in values + always (loop + for y in values + always + (and (eq (funcall (compile nil `(lambda (x y) + (equal (the ,(type-of x) x) + (the ,(type-of y) y)))) + x y) + (equal x y)) + (eq (funcall (compile nil `(lambda (x y) + (equalp (the ,(type-of x) x) + (the ,(type-of y) y)))) + x y) + (equalp x y)))))) + (assert + (funcall (compile + nil + `(lambda (x y) + (equal (the (cons (or simple-bit-vector simple-base-string)) + x) + (the (cons (or (and bit-vector (not simple-array)) + (simple-array character (*)))) + y)))) + (list (string 'list)) + (list "LIST"))) + (assert + (funcall (compile + nil + `(lambda (x y) + (equalp (the (cons (or simple-bit-vector simple-base-string)) + x) + (the (cons (or (and bit-vector (not simple-array)) + (simple-array character (*)))) + y)))) + (list (string 'list)) + (list "lisT")))))