mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1192 lines
45 KiB
Common Lisp
1192 lines
45 KiB
Common Lisp
;;;; arithmetic tests with no side effects
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(enable-test-parallelism)
|
|
|
|
;;; Once upon a time, in the process of porting CMUCL's SPARC backend
|
|
;;; to SBCL, multiplications were excitingly broken. While it's
|
|
;;; unlikely that anything with such fundamental arithmetic errors as
|
|
;;; these are going to get this far, it's probably worth checking.
|
|
(with-test (:name (:fundamental-arithmetic :smoke))
|
|
(macrolet ((test (op res1 res2)
|
|
`(progn
|
|
(assert (= (,op 4 2) ,res1))
|
|
(assert (= (,op 2 4) ,res2))
|
|
(assert (= (funcall (checked-compile '(lambda (x y) (,op x y)))
|
|
4 2)
|
|
,res1))
|
|
(assert (= (funcall (checked-compile '(lambda (x y) (,op x y)))
|
|
2 4)
|
|
,res2)))))
|
|
(test + 6 6)
|
|
(test - 2 -2)
|
|
(test * 8 8)
|
|
(test / 2 1/2)
|
|
(test expt 16 16)))
|
|
|
|
;;; In a bug reported by Wolfhard Buss on cmucl-imp 2002-06-18 (BUG
|
|
;;; 184), sbcl didn't catch all divisions by zero, notably divisions
|
|
;;; of bignums and ratios by 0. Fixed in sbcl-0.7.6.13.
|
|
(with-test (:name (/ :division-by-zero ratio))
|
|
(checked-compile-and-assert (:allow-style-warnings t)
|
|
'(lambda () (/ 2/3 0))
|
|
(() (condition 'division-by-zero))))
|
|
|
|
(with-test (:name (/ :division-by-zero bignum))
|
|
(checked-compile-and-assert (:allow-warnings t)
|
|
'(lambda () (/ (1+ most-positive-fixnum) 0))
|
|
(() (condition 'division-by-zero))))
|
|
|
|
;;; In a bug reported by Raymond Toy on cmucl-imp 2002-07-18, (COERCE
|
|
;;; <RATIONAL> '(COMPLEX FLOAT)) was failing to return a complex
|
|
;;; float; a patch was given by Wolfhard Buss cmucl-imp 2002-07-19.
|
|
(with-test (:name (coerce complex float 1))
|
|
(assert (= (coerce 1 '(complex float)) #c(1.0 0.0)))
|
|
(assert (= (coerce 1/2 '(complex float)) #c(0.5 0.0)))
|
|
(assert (= (coerce 1.0d0 '(complex float)) #c(1.0d0 0.0d0))))
|
|
|
|
;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
|
|
;;; an error up to 0.8.17.31
|
|
(with-test (:name (coerce complex float 2))
|
|
(assert (= (coerce #c(1 2) '(complex float)) #c(1.0 2.0))))
|
|
|
|
;;; COERCE also sometimes failed to verify that a particular coercion
|
|
;;; was possible (in particular coercing rationals to bounded float
|
|
;;; types.
|
|
(with-test (:name (coerce :to float :outside-bounds))
|
|
(checked-compile-and-assert (:allow-style-warnings t)
|
|
'(lambda () (coerce 1 '(float 2.0 3.0)))
|
|
(() (condition 'type-error)))
|
|
(checked-compile-and-assert (:allow-style-warnings t)
|
|
'(lambda () (coerce 1 '(single-float -1.0 0.0)))
|
|
(() (condition 'type-error)))
|
|
(assert (eql (coerce 1 '(single-float -1.0 2.0)) 1.0)))
|
|
|
|
;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
|
|
;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
|
|
;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
|
|
(with-test (:name (min max type-error))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (min '(1 2 3)))
|
|
(() (condition 'type-error)))
|
|
(assert (= (min -1) -1))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (min 1 #(1 2 3)))
|
|
(() (condition 'type-error)))
|
|
(assert (= (min 10 11) 10))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (min (find-package "CL") -5.0))
|
|
(() (condition 'type-error)))
|
|
(assert (= (min 5.0 -3) -3))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (max #c(4 3)))
|
|
(() (condition 'type-error)))
|
|
(assert (= (max 0) 0))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (max "MIX" 3))
|
|
(() (condition 'type-error)))
|
|
(assert (= (max -1 10.0) 10.0))
|
|
(checked-compile-and-assert (:allow-warnings t :allow-style-warnings t)
|
|
'(lambda () (max 3 #'max))
|
|
(() (condition 'type-error)))
|
|
(assert (= (max -3 0) 0)))
|
|
|
|
(with-test (:name :numeric-inequality-&rest-arguments)
|
|
(dolist (f '(= < <= > >=))
|
|
;; 1 arg
|
|
(assert-error (funcall f 'feep) type-error)
|
|
(unless (eq f '=)
|
|
;; = accepts complex numbers
|
|
(assert-error (funcall f #c(0s0 1s0)) type-error))
|
|
;; 2 arg
|
|
(assert-error (funcall f 3 'feep) type-error)
|
|
(assert-error (funcall f 'feep 3) type-error)
|
|
;; 3 arg
|
|
(assert-error (funcall f 0 0 'feep) type-error)
|
|
(assert-error (funcall f 0 1 'feep) type-error)
|
|
(assert-error (funcall f 1 0 'feep) type-error)
|
|
;; 4 arg
|
|
(assert-error (funcall f 0 0 0 'feep) type-error))
|
|
;; Also MIN,MAX operate only on REAL
|
|
(dolist (f '(min max))
|
|
(assert-error (funcall f #c(1s0 -2s0)) type-error)))
|
|
|
|
;;; (CEILING x 2^k) was optimized incorrectly
|
|
(with-test (:name (ceiling :power-of-two))
|
|
(loop for divisor in '(-4 4)
|
|
for ceiler = (checked-compile `(lambda (x)
|
|
(declare (fixnum x))
|
|
(declare (optimize (speed 3)))
|
|
(ceiling x ,divisor)))
|
|
do (loop for i from -5 to 5
|
|
for exact-q = (/ i divisor)
|
|
do (multiple-value-bind (q r)
|
|
(funcall ceiler i)
|
|
(assert (= (+ (* q divisor) r) i))
|
|
(assert (<= exact-q q))
|
|
(assert (< q (1+ exact-q)))))))
|
|
|
|
;;; (TRUNCATE x 2^k) was optimized incorrectly
|
|
(with-test (:name (truncate :power-of-two))
|
|
(loop for divisor in '(-4 4)
|
|
for truncater = (checked-compile `(lambda (x)
|
|
(declare (fixnum x))
|
|
(declare (optimize (speed 3)))
|
|
(truncate x ,divisor)))
|
|
do (loop for i from -9 to 9
|
|
for exact-q = (/ i divisor)
|
|
do (multiple-value-bind (q r)
|
|
(funcall truncater i)
|
|
(assert (= (+ (* q divisor) r) i))
|
|
(assert (<= (abs q) (abs exact-q)))
|
|
(assert (< (abs exact-q) (1+ (abs q))))))))
|
|
|
|
;;; CEILING had a corner case, spotted by Paul Dietz
|
|
(with-test (:name (ceiling :corner-case))
|
|
(assert (= (ceiling most-negative-fixnum (1+ most-positive-fixnum)) -1)))
|
|
|
|
;;; give any optimizers of constant multiplication a light testing.
|
|
;;; 100 may seem low, but (a) it caught CSR's initial errors, and (b)
|
|
;;; before checking in, CSR tested with 10000. So one hundred
|
|
;;; checkins later, we'll have doubled the coverage.
|
|
(with-test (:name (* :multiplication :constant :optimization))
|
|
(dotimes (i 100)
|
|
(let* ((x (random most-positive-fixnum))
|
|
(x2 (* x 2))
|
|
(x3 (* x 3))
|
|
(fn (checked-compile
|
|
`(lambda (y)
|
|
(declare (optimize speed) (type (integer 0 3) y))
|
|
(* y ,x))
|
|
:allow-notes (> x3 most-positive-fixnum))))
|
|
(assert (= (funcall fn 0) 0))
|
|
(assert (= (funcall fn 1) x))
|
|
(assert (= (funcall fn 2) x2))
|
|
(assert (= (funcall fn 3) x3)))))
|
|
|
|
;;; Bugs reported by Paul Dietz:
|
|
|
|
;;; (GCD 0 x) must return (abs x)
|
|
(with-test (:name (gcd 0))
|
|
(dolist (x (list -10 (* 3 most-negative-fixnum)))
|
|
(assert (= (gcd 0 x) (abs x)))))
|
|
|
|
;;; LCM returns a non-negative number
|
|
(with-test (:name (lcm :non-negative))
|
|
(assert (= (lcm 4 -10) 20))
|
|
(assert (= (lcm 0 0) 0)))
|
|
|
|
;;; PPC bignum arithmetic bug:
|
|
(with-test (:name (truncate bignum :ppc))
|
|
(multiple-value-bind (quo rem)
|
|
(truncate 291351647815394962053040658028983955 10000000000000000000000000)
|
|
(assert (= quo 29135164781))
|
|
(assert (= rem 5394962053040658028983955))))
|
|
|
|
;;; x86 LEA bug:
|
|
(with-test (:name (:x86 :lea))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x) (declare (bit x)) (+ x #xf0000000))
|
|
((1) #xf0000001)))
|
|
|
|
(with-test (:name (logbitp bignum))
|
|
(dolist (x '(((1+ most-positive-fixnum) 1 nil)
|
|
((1+ most-positive-fixnum) -1 t)
|
|
((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
|
|
((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
|
|
(1 (ash most-negative-fixnum 1) nil)
|
|
(#.(- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1) most-negative-fixnum t)
|
|
(#.(1+ (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1)) (ash most-negative-fixnum 1) t)
|
|
(#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1)) (ash most-negative-fixnum 1) t)
|
|
(#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-fixnum-tag-bits 2)) nil)
|
|
(#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-fixnum-tag-bits 2)) t)))
|
|
(destructuring-bind (index int result) x
|
|
(assert (eq (eval `(logbitp ,index ,int)) result)))))
|
|
|
|
;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD:
|
|
(with-test (:name (dpb deposit-field :off-by-one))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (b)
|
|
(integer-length (dpb b (byte 4 28) -1005)))
|
|
((1230070) 32))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (b)
|
|
(integer-length (deposit-field b (byte 4 28) -1005)))
|
|
((1230070) 32)))
|
|
|
|
;;; type inference leading to an internal compiler error:
|
|
(with-test (:name (ldb byte 0 :type-inference))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (type fixnum x))
|
|
(ldb (byte 0 0) x))
|
|
((1) 0)
|
|
((most-positive-fixnum) 0)
|
|
((-1) 0)))
|
|
|
|
;;; Alpha bignum arithmetic bug:
|
|
(with-test (:name (bignum :arithmetic :alpha))
|
|
(assert (= (* 966082078641 419216044685) 404997107848943140073085)))
|
|
|
|
;;; Alpha smallnum arithmetic bug:
|
|
(with-test (:name (fixnum :arithmetc :alpha))
|
|
(assert (= (ash -129876 -1026) -1)))
|
|
|
|
;;; Alpha middlenum (yes, really! Affecting numbers between 2^32 and
|
|
;;; 2^64 :) arithmetic bug
|
|
(with-test (:name (truncate :middlenum))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (a b c d)
|
|
(declare (type (integer -1621 -513) a)
|
|
(type (integer -3 34163) b)
|
|
(type (integer -9485132993 81272960) c)
|
|
(type (integer -255340814 519943) d)
|
|
(ignorable a b c d))
|
|
(truncate c (min -100 4149605)))
|
|
((-1332 5864 -6963328729 -43789079) (values 69633287 -29))))
|
|
|
|
;;; Here's another fantastic Alpha backend bug: the code to load
|
|
;;; immediate 64-bit constants into a register was wrong.
|
|
(with-test (:name (dpb :constants))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (a b c d)
|
|
(declare (type (integer -3563 2733564) a)
|
|
(type (integer -548947 7159) b)
|
|
(type (integer -19 0) c)
|
|
(type (integer -2546009 0) d)
|
|
(ignorable a b c d))
|
|
(case a
|
|
((89 125 16) (ash a (min 18 -706)))
|
|
(t (dpb -3 (byte 30 30) -1))))
|
|
((1227072 -529823 -18 -792831) -2147483649)))
|
|
|
|
;;; ASH of a negative bignum by a bignum count would erroneously
|
|
;;; return 0 prior to sbcl-0.8.4.4
|
|
(with-test (:name (ash :negative bignum))
|
|
(assert (= (ash (1- most-negative-fixnum) (1- most-negative-fixnum)) -1)))
|
|
|
|
;;; Whoops. Too much optimization in division operators for 0
|
|
;;; divisor.
|
|
(with-test (:name (mod truncate rem / floor ceiling :division-by-zero fixnum))
|
|
(flet ((frob (name)
|
|
(let ((fn (checked-compile
|
|
`(lambda (x)
|
|
(declare (optimize speed) (fixnum x))
|
|
(,name x 0))
|
|
:allow-warnings t)))
|
|
(assert-error (funcall fn 1) division-by-zero))))
|
|
(mapc #'frob '(mod truncate rem / floor ceiling))))
|
|
|
|
;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
|
|
;; comparisons without rationalizing the floats still gives the right anwers
|
|
;; in the edge cases (had a fencepost error).
|
|
(macrolet ((test (range type sign)
|
|
`(let (ints
|
|
floats
|
|
(start (- ,(find-symbol (format nil
|
|
"MOST-~A-EXACTLY-~A-INTEGER"
|
|
sign type)
|
|
:sb-kernel)
|
|
,range)))
|
|
(dotimes (i (1+ (* ,range 2)))
|
|
(let* ((x (+ start i))
|
|
(y (coerce x ',type)))
|
|
(push x ints)
|
|
(push y floats)))
|
|
(dolist (i ints)
|
|
(dolist (f floats)
|
|
(dolist (op '(< <= = >= >))
|
|
(unless (eq (funcall op i f)
|
|
(funcall op i (rationalize f)))
|
|
(error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
|
|
op i f
|
|
op i (rationalize f)))
|
|
(unless (eq (funcall op f i)
|
|
(funcall op (rationalize f) i))
|
|
(error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
|
|
op f i
|
|
op (rationalize f) i))))))))
|
|
(test 32 double-float negative)
|
|
(test 32 double-float positive)
|
|
(test 32 single-float negative)
|
|
(test 32 single-float positive))
|
|
|
|
;; x86-64 sign-extension bug found using pfdietz's random tester.
|
|
(with-test (:name (:x86-64 :sign-extension))
|
|
(assert (= 286142502
|
|
(funcall (lambda ()
|
|
(declare (notinline logxor))
|
|
(min (logxor 0 0 0 286142502)))))))
|
|
|
|
;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
|
|
;; unnoticed, so check more thoroughly here.
|
|
(with-test (:name logcount)
|
|
(flet ((test (x n)
|
|
(unless (= (logcount x) n)
|
|
(error "logcount failure for ~a" x))))
|
|
;; Test with some patterns with well known number of ones/zeroes ...
|
|
(dotimes (i 128)
|
|
(let ((x (ash 1 i)))
|
|
(test x 1)
|
|
(test (- x) i)
|
|
(test (1- x) i)))
|
|
;; ... and with some random integers of varying length.
|
|
(flet ((test-logcount (x)
|
|
(declare (type integer x))
|
|
(do ((result 0 (1+ result))
|
|
(x (if (minusp x)
|
|
(lognot x)
|
|
x)
|
|
(logand x (1- x))))
|
|
((zerop x) result))))
|
|
(dotimes (i 200)
|
|
(let ((x (random (ash 1 i))))
|
|
(test x (test-logcount x))
|
|
(test (- x) (test-logcount (- x))))))))
|
|
|
|
;; 1.0 had a broken ATANH on win32
|
|
(with-test (:name atanh)
|
|
(assert (= (atanh 0.9d0) 1.4722194895832204d0)))
|
|
|
|
;; Test some cases of integer operations with constant arguments
|
|
(with-test (:name :constant-integers)
|
|
(labels ((test-forms (op x y header &rest forms)
|
|
(let ((val (funcall op x y)))
|
|
(dolist (form forms)
|
|
(let ((new-val (funcall (checked-compile (append header form)) x y)))
|
|
(unless (eql val new-val)
|
|
(error "~S /= ~S: ~S ~S ~S~%" val new-val (append header form) x y))))))
|
|
(test-case (op x y type)
|
|
(test-forms op x y `(lambda (x y &aux z)
|
|
(declare (type ,type x y)
|
|
(ignorable x y z)
|
|
(notinline identity)
|
|
(optimize speed (safety 0))))
|
|
`((,op x ,y))
|
|
`((setf z (,op x ,y))
|
|
(identity x)
|
|
z)
|
|
`((values (,op x ,y) x))
|
|
`((,op ,x y))
|
|
`((setf z (,op ,x y))
|
|
(identity y)
|
|
z)
|
|
`((values (,op ,x y) y))
|
|
|
|
`((identity x)
|
|
(,op x ,y))
|
|
`((identity x)
|
|
(setf z (,op x ,y))
|
|
(identity x)
|
|
z)
|
|
`((identity x)
|
|
(values (,op x ,y) x))
|
|
`((identity y)
|
|
(,op ,x y))
|
|
`((identity y)
|
|
(setf z (,op ,x y))
|
|
(identity y)
|
|
z)
|
|
`((identity y)
|
|
(values (,op ,x y) y))))
|
|
(test-op (op)
|
|
(let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
|
|
(sb `(signed-byte ,sb-vm:n-word-bits)))
|
|
(loop for (x y type)
|
|
in `((2 1 fixnum)
|
|
(2 1 ,ub)
|
|
(2 1 ,sb)
|
|
(,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
|
|
(,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
|
|
(,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
|
|
,@(when (> sb-vm:n-word-bits 32)
|
|
`((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
|
|
(,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
|
|
(,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
|
|
(,(ash 1 40) ,(ash 1 39) fixnum)
|
|
(,(ash 1 40) ,(ash 1 39) ,ub)
|
|
(,(ash 1 40) ,(ash 1 39) ,sb)))
|
|
;; fixnums that can be represented as 32-bit
|
|
;; sign-extended immediates on x86-64
|
|
,@(when (and (> sb-vm:n-word-bits 32)
|
|
(< sb-vm:n-fixnum-tag-bits 3))
|
|
`((,(1+ (ash 1 (- 31 sb-vm:n-fixnum-tag-bits)))
|
|
,(1- (ash 1 (- 32 sb-vm:n-fixnum-tag-bits)))
|
|
fixnum))))
|
|
do
|
|
(test-case op x y type)
|
|
(test-case op x x type)))))
|
|
(mapc #'test-op '(+ - * truncate
|
|
< <= = >= >
|
|
eql
|
|
eq))))
|
|
|
|
;; GCD used to sometimes return negative values. The following did, on 32 bit
|
|
;; builds.
|
|
(with-test (:name gcd)
|
|
;; from lp#413680
|
|
(assert (plusp (gcd 20286123923750474264166990598656
|
|
680564733841876926926749214863536422912)))
|
|
;; from lp#516750
|
|
(assert (plusp (gcd 2596102012663483082521318626691873
|
|
2596148429267413814265248164610048))))
|
|
|
|
(with-test (:name (expt 0 0))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (x y) (expt x y))
|
|
((0 0) 1)
|
|
((0f0 0) 1f0)
|
|
((0d0 0) 1d0)
|
|
((0 0f0) 1f0)
|
|
((0 0d0) 1d0)
|
|
((0d0 0f0) 1d0)
|
|
((0f0 0d0) 1d0)
|
|
((0f0 -0f0) 1f0)
|
|
((-0f0 0f0) 1f0)))
|
|
|
|
(with-test (:name :multiple-constant-folding)
|
|
(let ((*random-state* (make-random-state t)))
|
|
(flet ((make-args ()
|
|
(let (args vars)
|
|
(loop repeat (1+ (random 12))
|
|
do (if (zerop (random 2))
|
|
(let ((var (gensym)))
|
|
(push var args)
|
|
(push var vars))
|
|
(push (- (random 21) 10) args)))
|
|
(values args vars))))
|
|
(dolist (op '(+ * logior logxor logand logeqv gcd lcm - /))
|
|
(loop repeat 10
|
|
do (multiple-value-bind (args vars) (make-args)
|
|
(let ((fast (checked-compile
|
|
`(lambda ,vars
|
|
(,op ,@args))
|
|
:allow-warnings (eq op '/)))
|
|
(slow (checked-compile
|
|
`(lambda ,vars
|
|
(declare (notinline ,op))
|
|
(,op ,@args))
|
|
:allow-warnings (eq op '/))))
|
|
(loop repeat 3
|
|
do (let* ((call-args (loop repeat (length vars)
|
|
collect (- (random 21) 10)))
|
|
(fast-result (handler-case
|
|
(apply fast call-args)
|
|
(division-by-zero () :div0)))
|
|
(slow-result (handler-case
|
|
(apply slow call-args)
|
|
(division-by-zero () :div0))))
|
|
(if (not (eql fast-result slow-result))
|
|
(error "oops: ~S, ~S" args call-args)
|
|
#+nil (print (list :ok `(,op ,@args) :=> fast-result))
|
|
))))))))))
|
|
|
|
;;; (TRUNCATE <unsigned-word> <constant unsigned-word>) is optimized
|
|
;;; to use multiplication instead of division. This propagates to FLOOR,
|
|
;;; MOD and REM. Test that the transform is indeed triggered and test
|
|
;;; several cases for correct results.
|
|
(with-test (:name (:integer-division-using-multiplication :used)
|
|
:skipped-on (not (or :x86-64 :x86 :arm64)))
|
|
(dolist (fun '(truncate floor ceiling mod rem))
|
|
(let* ((foo (checked-compile
|
|
`(lambda (x)
|
|
(declare (optimize (speed 3)
|
|
(space 1)
|
|
(compilation-speed 0))
|
|
(type (unsigned-byte ,sb-vm:n-word-bits) x))
|
|
(,fun x 9))))
|
|
(disassembly (with-output-to-string (s)
|
|
(disassemble foo :stream s))))
|
|
;; KLUDGE copied from test :float-division-using-exact-reciprocal
|
|
;; in compiler.pure.lisp.
|
|
(assert (and (not (search "DIV" disassembly))
|
|
(search "MUL" disassembly))))))
|
|
|
|
(with-test (:name (:integer-division-using-multiplication :correctness))
|
|
(let ((*random-state* (make-random-state t)))
|
|
(dolist (dividend-type `((unsigned-byte ,sb-vm:n-word-bits)
|
|
(signed-byte ,sb-vm:n-word-bits)
|
|
(and fixnum unsigned-byte)
|
|
(integer 10000 10100)
|
|
fixnum))
|
|
(dolist (divisor `(;; Some special cases from the paper
|
|
7 10 14 641 274177
|
|
;; Range extremes
|
|
3
|
|
,most-positive-fixnum
|
|
,(1- (expt 2 sb-vm:n-word-bits))
|
|
;; Some random values
|
|
,@(loop for i from 8 to sb-vm:n-word-bits
|
|
for r = (random (expt 2 i))
|
|
;; We don't want 0, 1 and powers of 2.
|
|
when (not (zerop (logand r (1- r))))
|
|
collect r
|
|
and
|
|
collect (- r))))
|
|
(dolist (fun '(truncate ceiling floor mod rem))
|
|
(let ((foo (checked-compile
|
|
`(lambda (x)
|
|
(declare (optimize (speed 3)
|
|
(space 1)
|
|
(compilation-speed 0))
|
|
(type ,dividend-type x))
|
|
(,fun x ,divisor)))))
|
|
(dolist (dividend `(0 1 ,most-positive-fixnum
|
|
,(1- divisor) ,divisor
|
|
,(1- (* divisor 2)) ,(* divisor 2)
|
|
,@(loop repeat 4
|
|
collect (+ 10000 (random 101)))
|
|
,@(loop for i from 4 to sb-vm:n-word-bits
|
|
for pow = (expt 2 (1- i))
|
|
for r = (+ pow (random pow))
|
|
collect r
|
|
collect (- r))))
|
|
(when (typep dividend dividend-type)
|
|
(multiple-value-bind (q1 r1)
|
|
(funcall foo dividend)
|
|
(multiple-value-bind (q2 r2)
|
|
(funcall fun dividend divisor)
|
|
(unless (and (= q1 q2)
|
|
(eql r1 r2))
|
|
(error "bad results for ~s with dividend type ~s"
|
|
(list fun dividend divisor)
|
|
dividend-type))))))))))))
|
|
|
|
;; The fast path for logbitp underestimated sb-vm:n-positive-fixnum-bits
|
|
;; for > 61 bit fixnums.
|
|
(with-test (:name (logbitp :wide fixnum))
|
|
(assert (not (logbitp (1- (integer-length most-positive-fixnum))
|
|
most-negative-fixnum))))
|
|
|
|
;; EXPT dispatches in a complicated way on the types of its arguments.
|
|
;; Check that all possible combinations are covered.
|
|
(with-test (:name (expt :argument-type-combinations))
|
|
(let ((numbers '(2 ; fixnum
|
|
3/5 ; ratio
|
|
1.2f0 ; single-float
|
|
2.0d0 ; double-float
|
|
#c(3/5 1/7) ; complex rational
|
|
#c(1.2f0 1.3f0) ; complex single-float
|
|
#c(2.0d0 3.0d0))) ; complex double-float
|
|
(bignum (expt 2 64))
|
|
results)
|
|
(dolist (base (cons bignum numbers))
|
|
(dolist (power numbers)
|
|
#+nil (format t "(expt ~s ~s) => " base power)
|
|
(let ((result (expt base power)))
|
|
#+nil (format t "~s~%" result)
|
|
(push result results))))
|
|
(assert (every #'numberp results))))
|
|
|
|
(with-test (:name :bug-741564)
|
|
;; The bug was that in (expt <fixnum> <(complex double-float)>) the
|
|
;; calculation was partially done only to single-float precision,
|
|
;; making the complex double-float result too unprecise. Some other
|
|
;; combinations of argument types were affected, too; test that all
|
|
;; of them are good to double-float precision.
|
|
(labels ((nearly-equal-p (x y)
|
|
"Are the arguments equal to nearly double-float precision?"
|
|
(declare (type double-float x y))
|
|
(< (/ (abs (- x y)) (abs y))
|
|
(* double-float-epsilon 4))) ; Differences in the two least
|
|
; significant mantissa bits
|
|
; are OK.
|
|
(test-complex (x y)
|
|
(and (nearly-equal-p (realpart x) (realpart y))
|
|
(nearly-equal-p (imagpart x) (imagpart y))))
|
|
(print-result (msg base power got expected)
|
|
(declare (ignorable msg base power got expected))
|
|
#+nil
|
|
(format t "~a (expt ~s ~s)~%got ~s~%expected ~s~%"
|
|
msg base power got expected)))
|
|
(let ((n-broken 0))
|
|
(flet ((test (base power coerce-to-type)
|
|
(let* ((got (expt base power))
|
|
(expected (expt (coerce base coerce-to-type) power))
|
|
(result (test-complex got expected)))
|
|
(print-result (if result "Good:" "Bad:")
|
|
base power got expected)
|
|
(unless result
|
|
(incf n-broken)))))
|
|
(dolist (base (list 2 ; fixnum
|
|
(expt 2 64) ; bignum
|
|
3/5 ; ratio
|
|
2.0f0)) ; single-float
|
|
(let ((power #c(-2.5d0 -4.5d0))) ; complex double-float
|
|
(test base power 'double-float)))
|
|
(dolist (base (list #c(2.0f0 3.0f0) ; complex single-float
|
|
#c(2 3) ; complex fixnum
|
|
(complex (expt 2 64) (expt 2 65))
|
|
; complex bignum
|
|
#c(3/5 1/7))) ; complex ratio
|
|
(dolist (power (list #c(-2.5d0 -4.5d0) ; complex double-float
|
|
-2.5d0)) ; double-float
|
|
(test base power '(complex double-float)))))
|
|
(when (> n-broken 0)
|
|
(error "Number of broken combinations: ~a" n-broken)))))
|
|
|
|
(with-test (:name (ldb :rlwinm :ppc))
|
|
(let ((one (checked-compile '(lambda (a) (ldb (byte 9 27) a))))
|
|
(two (checked-compile '(lambda (a)
|
|
(declare (type (integer -3 57216651) a))
|
|
(ldb (byte 9 27) a)))))
|
|
(assert (= 0 (- (funcall one 10) (funcall two 10))))))
|
|
|
|
;; The ISQRT implementation is sufficiently complicated that it should
|
|
;; be tested.
|
|
(with-test (:name isqrt)
|
|
(labels ((test (x)
|
|
(let* ((r (isqrt x))
|
|
(r2 (expt r 2))
|
|
(s2 (expt (1+ r) 2)))
|
|
(unless (and (<= r2 x)
|
|
(> s2 x))
|
|
(error "isqrt failure for ~a" x))))
|
|
(tests (x)
|
|
(test x)
|
|
(let ((x2 (expt x 2)))
|
|
(test x2)
|
|
(test (1+ x2))
|
|
(test (1- x2)))))
|
|
(test most-positive-fixnum)
|
|
(test (1+ most-positive-fixnum))
|
|
(loop for i from 1 to 200
|
|
for pow = (expt 2 (1- i))
|
|
for j = (+ pow (random pow))
|
|
do
|
|
(tests i)
|
|
(tests j))
|
|
(dotimes (i 10)
|
|
(tests (random (expt 2 (+ 1000 (random 10000))))))))
|
|
|
|
;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
|
|
(with-test (:name :recursive-cut-to-width)
|
|
(checked-compile-and-assert (:optimize '(:speed t :safety t :debug t :space t))
|
|
'(lambda (x)
|
|
(declare (type (integer 12417236377505266230
|
|
12417274239874990070)
|
|
x))
|
|
(logand 8459622733968096971 x))
|
|
((12417237222845306758) 2612793697039849090)))
|
|
|
|
;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
|
|
(with-test (:name (:recursive-cut-to-width :more))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (a b)
|
|
(logand (the (eql 16779072918521075607) a)
|
|
(the (integer 21371810342718833225 21371810343571293860) b)))
|
|
((16779072918521075607 21371810342718833263) 2923729245085762055)))
|
|
|
|
(with-test (:name (ldb :negative-index-no-error))
|
|
(checked-compile-and-assert (:optimize :safe)
|
|
'(lambda (x y) (ldb (byte x y) 100))
|
|
((-1 -2) (condition 'error)))
|
|
(checked-compile-and-assert (:optimize :safe)
|
|
'(lambda (x y) (mask-field (byte x y) 100))
|
|
((-1 -2) (condition 'error)))
|
|
(checked-compile-and-assert (:optimize :safe)
|
|
'(lambda (x y) (dpb 0 (byte x y) 100))
|
|
((-1 -2) (condition 'error)))
|
|
(checked-compile-and-assert (:optimize :safe)
|
|
'(lambda (x y) (deposit-field 0 (byte x y) 100))
|
|
((-1 -2) (condition 'error))))
|
|
|
|
(with-test (:name (mask-field setf))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (a)
|
|
(setf (mask-field (byte 2 0) a) 1) a)
|
|
((15) 13)))
|
|
|
|
(with-test (:name :complex-multiply)
|
|
(checked-compile-and-assert ()
|
|
'(lambda ()
|
|
(let (z)
|
|
(expt (setf z (complex -0.123 -0.789)) 2)))
|
|
(() #C(-0.60739195 0.194094))))
|
|
|
|
(with-test (:name (sqrt complex))
|
|
(assert (= (expt (sqrt least-negative-double-float) 2)
|
|
least-negative-double-float)))
|
|
|
|
(with-test (:name (ldb :sign))
|
|
(checked-compile-and-assert ()
|
|
`(lambda (x)
|
|
(ldb (byte ,(1- sb-vm:n-word-bits) 0) x))
|
|
((12) 12)))
|
|
|
|
(with-test (:name :mod-arith-large-constant)
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (sb-ext:word x))
|
|
(logand sb-ext:most-positive-word
|
|
(+ x 2312423423)))
|
|
((12) 2312423435)))
|
|
|
|
(with-test (:name (bignum :ash :left fixnum))
|
|
(assert (= (eval '(ash most-negative-fixnum (1- sb-vm:n-word-bits)))
|
|
(eval '(* most-negative-fixnum (expt 2 (1- sb-vm:n-word-bits)))))))
|
|
|
|
(with-test (:name (ldb fixnum :sign-bits))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (fixnum x))
|
|
(ldb (byte (/ sb-vm:n-word-bits 2)
|
|
(/ sb-vm:n-word-bits 2))
|
|
x))
|
|
((most-positive-fixnum) (ash most-positive-fixnum (- (/ sb-vm:n-word-bits 2))))
|
|
((-1) (1- (expt 2 (/ sb-vm:n-word-bits 2))))))
|
|
|
|
(with-test (:name (dpb :sign-bits))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (fixnum x))
|
|
(dpb 1 (byte (/ sb-vm:n-word-bits 2)
|
|
(/ sb-vm:n-word-bits 2))
|
|
x))
|
|
((-1)
|
|
(logior (ash 1 (/ sb-vm:n-word-bits 2))
|
|
(logandc2 -1
|
|
(mask-field (byte (/ sb-vm:n-word-bits 2)
|
|
(/ sb-vm:n-word-bits 2))
|
|
-1))))
|
|
((most-positive-fixnum)
|
|
(logior (ash 1 (/ sb-vm:n-word-bits 2))
|
|
(logandc2 most-positive-fixnum
|
|
(mask-field (byte (/ sb-vm:n-word-bits 2)
|
|
(/ sb-vm:n-word-bits 2))
|
|
-1))))))
|
|
|
|
(with-test (:name (dpb :position-zero))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (sb-vm:word x))
|
|
(dpb 0 (byte (/ sb-vm:n-word-bits 2) 0) x))
|
|
((1) 0)
|
|
((sb-ext:most-positive-word)
|
|
(logxor sb-ext:most-positive-word
|
|
(1- (expt 2 (/ sb-vm:n-word-bits 2)))))))
|
|
|
|
(with-test (:name (logand :mask-word))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(logand x (ash sb-ext:most-positive-word -1)))
|
|
((-1) (ash most-positive-word -1))))
|
|
|
|
(with-test (:name (/ complex real single-float))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (b)
|
|
(declare (type single-float b))
|
|
(/ #c(1.0 2.0) b))
|
|
((1.0) #c(1.0 2.0))))
|
|
|
|
(with-test (:name (ash :unsigned))
|
|
(checked-compile-and-assert ()
|
|
'(lambda (x)
|
|
(declare (sb-vm:signed-word x))
|
|
(ash x -64))
|
|
(( 123) 0)
|
|
((-321) -1)))
|
|
|
|
(with-test (:name :64-bit-logcount)
|
|
(checked-compile-and-assert
|
|
()
|
|
'(lambda (x)
|
|
(declare (type (unsigned-byte 54) x))
|
|
(logcount x))
|
|
(((1- (ash 1 24))) 24)
|
|
(((1- (ash 1 32))) 32)
|
|
(((1- (ash 1 48))) 48)
|
|
(((1- (ash 1 54))) 54)))
|
|
|
|
(with-test (:name :complex-rational-eql)
|
|
;; ensure no funny business with constant sharing so that we're forced
|
|
;; to do the most general form or EQL on two (complex rational)s
|
|
(eql (read-from-string "#c(1/2 1/3)") (read-from-string "#c(1/2 1/3)")))
|
|
|
|
(with-test (:name :gcd-derive-type)
|
|
(checked-compile-and-assert
|
|
()
|
|
'(lambda (a)
|
|
(declare (type (integer -142 -29) a))
|
|
(eql (gcd (setq a -29) a) 1))
|
|
((-33) nil)))
|
|
|
|
;;; Test that LOGIOR and LOGXOR on PPC64 can correctly perform the constant 2nd-arg
|
|
;;; vop variant on a 32-bit immediate using op + op-shifted instructions.
|
|
;;; (Probably we should refactor large parts of the test suite by the CPU
|
|
;;; architecture so that you can really see clearly the areas of concern
|
|
;;; for each backend, but I'm not about to embark on that now)
|
|
(with-test (:name :ppc64-logxor-32-bit-const)
|
|
(let ((f (compile nil
|
|
'(lambda (x)
|
|
(declare (fixnum x))
|
|
;; The asm code went wrong only if the result was not in the same
|
|
;; register as the source, so make sure that X is live throughout
|
|
;; the test so that each result is in a different register.
|
|
(let ((a (logxor x #x9516A7))
|
|
(b (logior x #x2531b4))
|
|
(c (ash x -1)))
|
|
(list a b c x))))))
|
|
(let ((result (funcall f 0)))
|
|
(assert (equal result
|
|
'(#x9516A7 #x2531b4 0 0))))))
|
|
|
|
(with-test (:name :truncate-by-zero-derivation)
|
|
(assert-type
|
|
(lambda ()
|
|
(declare (muffle-conditions warning))
|
|
(truncate 5 0))
|
|
nil))
|
|
|
|
(with-test (:name :truncate-by-zero-derivation.2)
|
|
(checked-compile
|
|
`(lambda (x y)
|
|
(declare (type (unsigned-byte 8) x y)
|
|
(optimize speed (safety 0)))
|
|
(mod x y))
|
|
:allow-notes nil))
|
|
|
|
(with-test (:name :ash-fixnum)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (b)
|
|
(declare (type (integer -2 2) b))
|
|
(ash b (min 13 b)))
|
|
((-2) -1)
|
|
((-1) -1)
|
|
((0) 0)
|
|
((1) 2)
|
|
((2) 8)))
|
|
|
|
(with-test (:name :mod-ash-cut)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (b)
|
|
(logand #xFF (ash 1 (the (integer -1000 1000) b))))
|
|
((1) 2)
|
|
((500) 0))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x b)
|
|
(logand #xFF (ash (the (unsigned-byte 64) x) (the (integer -1000 1000) b))))
|
|
(((1- (expt 2 64)) -63) 1)
|
|
(((1- (expt 2 64)) -64) 0)))
|
|
|
|
(with-test (:name :ash-cut-unsafe)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x b)
|
|
(truly-the fixnum (ash (the (unsigned-byte 64) x) (the (integer -1000 1000) b))))
|
|
(((1- (expt 2 64)) -63) 1)
|
|
(((1- (expt 2 64)) -64) 0)))
|
|
|
|
(with-test (:name :bogus-modular-fun-widths)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (b)
|
|
(logorc2 0 (- (isqrt (abs (logand (if b -1 2) 2))))))
|
|
((t) 0)
|
|
((nil) 0)))
|
|
|
|
(with-test (:name :lognot-type-derive)
|
|
(assert-type
|
|
(lambda (b)
|
|
(lognot (if b -1 2)))
|
|
(or (integer -3 -3) (integer 0 0))))
|
|
|
|
(with-test (:name :logand-minus-1-type-derive)
|
|
(assert-type
|
|
(lambda (b)
|
|
(logand #xf (if b -1 2)))
|
|
(or (integer 2 2) (integer 15 15))))
|
|
|
|
(with-test (:name :ash-vop-liftimes)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (A C)
|
|
(declare ((integer 18512171785636 25543390924355) a)
|
|
((integer -20485927966480856 54446023204744213) c))
|
|
(dpb a (byte 20 25) (ash a (min 2 c))))
|
|
((23906959691249 -15632482499364879) 15512918556672)
|
|
((23906959691249 1) 50697318833122)))
|
|
|
|
|
|
(with-test (:name :ash-modarith-transform-loop)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (p1 p2 p3)
|
|
(declare (type (integer * 53) p1)
|
|
(type number p2)
|
|
(type
|
|
(member 21006398744832 16437837094852630852 2251799813685252
|
|
-1597729350241882 466525164)
|
|
p3))
|
|
(ldb (byte (the (integer -3642545987372 *) p1) p2) p3))
|
|
((53 2 21006398744832) 5251599686208)))
|
|
|
|
(with-test (:name :logcount-negative-fixnum)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(logcount (the fixnum x)))
|
|
((54) 4)
|
|
((-54) 4)))
|
|
|
|
(with-test (:name :mod-ash64-signed)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare (fixnum a b))
|
|
(logand (ash a b) (1+ most-positive-fixnum)))
|
|
((-1 -3) (1+ most-positive-fixnum))
|
|
((1 3) 0)))
|
|
|
|
(with-test (:name :zero-shift-flags)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a m)
|
|
(declare ((integer 0 5000000000) a)
|
|
(bit m))
|
|
(zerop (ash a m)))
|
|
((1 0) nil)
|
|
((0 1) t)))
|
|
|
|
(with-test (:name :signum-merged-branch-if)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a y)
|
|
(declare (fixnum a y))
|
|
(when (< y 10)
|
|
(signum a)))
|
|
((1 5) 1)
|
|
((0 5) 0)
|
|
((-1 5) -1)))
|
|
|
|
(with-test (:name :cmov-merged-branch-if)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (b c)
|
|
(declare (type (integer 0 7711851432375361987) b))
|
|
(declare (type (integer -2 0) c))
|
|
(let ((v9 c))
|
|
(if (< c v9)
|
|
c
|
|
(if (= v9 c)
|
|
v9
|
|
b))))
|
|
((0 -1) -1)))
|
|
|
|
(with-test (:name :ash-amount-unsigned-comparison)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a)
|
|
(declare (type (integer -581 900) a))
|
|
(ash 3 (ash (ash a -50) (1- sb-vm:n-word-bits))))
|
|
((-1) 0)
|
|
((1) 3)))
|
|
|
|
(with-test (:name :ash-modfx-constant-folding)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a)
|
|
(declare (type (integer -10000 5) a))
|
|
(ldb (byte 16 28)
|
|
(ash 4611686018427387913
|
|
(progn
|
|
(multiple-value-setq (a) -10000)
|
|
a))))
|
|
((0) 0)))
|
|
|
|
(with-test (:name :fixnum*-lifetimes)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare ((integer -8394154896 -1950772105) b))
|
|
a
|
|
(round (+ b 4611686018427387903)
|
|
(let ((divisor (expt b 2)))
|
|
divisor)))
|
|
((0 -5000000000) (values 0 4611686013427387903))))
|
|
|
|
(with-test (:name :ash-*-cycle)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(truly-the fixnum (* (the fixnum x) -4)))
|
|
((4) -16)))
|
|
|
|
(with-test (:name :-unsigned=>signed)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare ((integer #.(- (expt 2 sb-vm:n-word-bits) 10)
|
|
#.(- (expt 2 sb-vm:n-word-bits) 1))
|
|
a b))
|
|
(- a b))
|
|
(((- (expt 2 sb-vm:n-word-bits) 10) (- (expt 2 sb-vm:n-word-bits) 9)) -1)))
|
|
|
|
(with-test (:name :>=-fixnum-integer)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare (fixnum a))
|
|
(and (integerp b)
|
|
(>= a b)))
|
|
((1 2) nil)
|
|
((2 2) t)
|
|
((3 2) t))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare (fixnum a))
|
|
(and (integerp b)
|
|
(<= a b)))
|
|
((1 2) t)
|
|
((2 2) t)
|
|
((3 2) nil)))
|
|
|
|
(with-test (:name :ash-signed-negation-overflow
|
|
:fails-on (or :sparc :arm))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare (fixnum a)
|
|
(sb-vm:signed-word b))
|
|
(truly-the sb-vm:signed-word (ash a b)))
|
|
((-44 (- (expt 2 (1- sb-vm:n-word-bits)))) -1)
|
|
((44 2) 176)))
|
|
|
|
(with-test (:name :-constant-mnf)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a)
|
|
(logand most-positive-fixnum
|
|
(- (the fixnum a) most-negative-fixnum)))
|
|
((10) 10)))
|
|
|
|
(with-test (:name :unary-truncate-discard-second-value)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a)
|
|
(truncate (expt (complex a 0) 0))
|
|
1)
|
|
((1) 1)))
|
|
|
|
(with-test (:name :unary-truncate-discard-second-value.2)
|
|
(checked-compile-and-assert
|
|
(:allow-style-warnings t)
|
|
`(lambda (a b)
|
|
(boole boole-nand
|
|
(dpb (* b (unwind-protect 0 b)) (byte 31 28) a)
|
|
(ignore-errors
|
|
(truncate
|
|
(eval
|
|
(values 1 2))))))
|
|
((1 2) -2)))
|
|
|
|
(with-test (:name :logtest-immediate)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(logtest (- (expt 2 63) 3) (the fixnum x)))
|
|
((1) t)
|
|
((2) nil)))
|
|
|
|
(with-test (:name :logand-negative-derive)
|
|
(assert
|
|
(subtypep (second (third (sb-kernel:%simple-fun-type
|
|
(checked-compile
|
|
`(lambda (a b)
|
|
(declare ((not unsigned-byte) a b))
|
|
(logand a b))))))
|
|
'(integer * -1))))
|
|
|
|
(with-test (:name :ash-mod64-constant-folding)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a d)
|
|
(declare (fixnum a)
|
|
((unsigned-byte 64) d))
|
|
(setq a -64)
|
|
(logand d (ash -1 a)))
|
|
((0 3) 3)))
|
|
|
|
(with-test (:name :signed-unsigned-cmp-elision)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (a b)
|
|
(declare (fixnum a)
|
|
((or (integer -1 0)
|
|
(unsigned-byte 64)) b))
|
|
(let ((v2 (abs b)))
|
|
(if (> a v2)
|
|
a
|
|
(>= a v2))))
|
|
((1 2) nil)
|
|
((1 1) t)
|
|
((3 0) 3)))
|
|
|
|
(with-test (:name :integer-fixnum-<)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (f b &optional a c d e g h i j k l m n o p q r s)
|
|
(declare (fixnum f))
|
|
(eval (list 'list a b c d e f g h i j k l m n o p q r s t))
|
|
(and (integerp b)
|
|
(< f b)))
|
|
((1 t) nil)
|
|
((1 10) t)))
|
|
|
|
(with-test (:name :cast-externally-checkable-p-satisfies)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (u s)
|
|
(the (unsigned-byte 64) (+ (the (or null (unsigned-byte 64)) u) (the fixnum s))))
|
|
((1 2) 3)))
|
|
|
|
(with-test (:name :rem-derive-type)
|
|
(flet ((test (form type)
|
|
(assert
|
|
(type-specifiers-equal
|
|
(caddr
|
|
(sb-kernel:%simple-fun-type
|
|
(checked-compile
|
|
`(lambda (a b)
|
|
,form))))
|
|
`(values ,type &optional)))))
|
|
(test `(rem (the fixnum a) (the integer b))
|
|
'fixnum)
|
|
(test `(rem (the fixnum a) (the (integer 0 20) b))
|
|
'(integer -19 19))
|
|
(test `(rem (the (unsigned-byte 32) a) (the (integer 0 20) b))
|
|
'(integer 0 19))
|
|
(test `(rem (the (signed-byte 32) a) (the (unsigned-byte 32) b))
|
|
'(signed-byte 32))
|
|
(test `(rem (the (signed-byte 8) a) (the (unsigned-byte 7) b))
|
|
'(integer -126 126))))
|
|
|
|
(with-test (:name :logand-positive-negative-type-derive)
|
|
(flet ((test (form type)
|
|
(assert
|
|
(type-specifiers-equal
|
|
(caddr
|
|
(sb-kernel:%simple-fun-type
|
|
(checked-compile
|
|
`(lambda (a)
|
|
,form))))
|
|
`(values ,type &optional)))))
|
|
(test `(logand (ash -1 20) (the (integer 0 20) a))
|
|
'(eql 0))
|
|
(test `(logand #xFF (the (integer -20 -1) a))
|
|
'(integer 236 255))))
|