1 ;;;; arithmetic tests with no side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (cl:in-package
:cl-user
)
16 ;;; Once upon a time, in the process of porting CMUCL's SPARC backend
17 ;;; to SBCL, multiplications were excitingly broken. While it's
18 ;;; unlikely that anything with such fundamental arithmetic errors as
19 ;;; these are going to get this far, it's probably worth checking.
20 (with-test (:name
(:fundamental-arithmetic
:smoke
))
21 (macrolet ((test (op res1 res2
)
23 (assert (= (,op
4 2) ,res1
))
24 (assert (= (,op
2 4) ,res2
))
25 (assert (= (funcall (checked-compile '(lambda (x y
) (,op x y
)))
28 (assert (= (funcall (checked-compile '(lambda (x y
) (,op x y
)))
37 ;;; In a bug reported by Wolfhard Buss on cmucl-imp 2002-06-18 (BUG
38 ;;; 184), sbcl didn't catch all divisions by zero, notably divisions
39 ;;; of bignums and ratios by 0. Fixed in sbcl-0.7.6.13.
40 (with-test (:name
(/ :division-by-zero ratio
))
41 (checked-compile-and-assert (:allow-style-warnings t
)
42 '(lambda () (/ 2/3 0))
43 (() (condition 'division-by-zero
))))
45 (with-test (:name
(/ :division-by-zero bignum
))
46 (checked-compile-and-assert (:allow-style-warnings t
)
47 '(lambda () (/ (1+ most-positive-fixnum
) 0))
48 (() (condition 'division-by-zero
))))
50 ;;; In a bug reported by Raymond Toy on cmucl-imp 2002-07-18, (COERCE
51 ;;; <RATIONAL> '(COMPLEX FLOAT)) was failing to return a complex
52 ;;; float; a patch was given by Wolfhard Buss cmucl-imp 2002-07-19.
53 (with-test (:name
(coerce complex float
1))
54 (assert (= (coerce 1 '(complex float
)) #c
(1.0
0.0)))
55 (assert (= (coerce 1/2 '(complex float
)) #c
(0.5
0.0)))
56 (assert (= (coerce 1.0d0
'(complex float
)) #c
(1.0d0
0.0d0
))))
58 ;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
59 ;;; an error up to 0.8.17.31
60 (with-test (:name
(coerce complex float
2))
61 (assert (= (coerce #c
(1 2) '(complex float
)) #c
(1.0
2.0))))
63 ;;; COERCE also sometimes failed to verify that a particular coercion
64 ;;; was possible (in particular coercing rationals to bounded float
66 (with-test (:name
(coerce :to float
:outside-bounds
))
67 (checked-compile-and-assert (:allow-style-warnings t
)
68 '(lambda () (coerce 1 '(float 2.0 3.0)))
69 (() (condition 'type-error
)))
70 (checked-compile-and-assert (:allow-style-warnings t
)
71 '(lambda () (coerce 1 '(single-float -
1.0 0.0)))
72 (() (condition 'type-error
)))
73 (assert (eql (coerce 1 '(single-float -
1.0 2.0)) 1.0)))
75 ;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
76 ;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
77 ;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
78 (with-test (:name
(min max type-error
))
79 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
80 '(lambda () (min '(1 2 3)))
81 (() (condition 'type-error
)))
82 (assert (= (min -
1) -
1))
83 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
84 '(lambda () (min 1 #(1 2 3)))
85 (() (condition 'type-error
)))
86 (assert (= (min 10 11) 10))
87 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
88 '(lambda () (min (find-package "CL") -
5.0))
89 (() (condition 'type-error
)))
90 (assert (= (min 5.0 -
3) -
3))
91 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
92 '(lambda () (max #c
(4 3)))
93 (() (condition 'type-error
)))
94 (assert (= (max 0) 0))
95 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
96 '(lambda () (max "MIX" 3))
97 (() (condition 'type-error
)))
98 (assert (= (max -
1 10.0) 10.0))
99 (checked-compile-and-assert (:allow-warnings t
:allow-style-warnings t
)
100 '(lambda () (max 3 #'max
))
101 (() (condition 'type-error
)))
102 (assert (= (max -
3 0) 0)))
104 (with-test (:name
:numeric-inequality-
&rest-arguments
)
105 (dolist (f '(= < <= > >=))
107 (assert-error (funcall f
'feep
) type-error
)
109 ;; = accepts complex numbers
110 (assert-error (funcall f
#c
(0s0 1s0
)) type-error
))
112 (assert-error (funcall f
3 'feep
) type-error
)
113 (assert-error (funcall f
'feep
3) type-error
)
115 (assert-error (funcall f
0 0 'feep
) type-error
)
116 (assert-error (funcall f
0 1 'feep
) type-error
)
117 (assert-error (funcall f
1 0 'feep
) type-error
)
119 (assert-error (funcall f
0 0 0 'feep
) type-error
))
120 ;; Also MIN,MAX operate only on REAL
121 (dolist (f '(min max
))
122 (assert-error (funcall f
#c
(1s0 -
2s0
)) type-error
)))
124 ;;; (CEILING x 2^k) was optimized incorrectly
125 (with-test (:name
(ceiling :power-of-two
))
126 (loop for divisor in
'(-4 4)
127 for ceiler
= (checked-compile `(lambda (x)
129 (declare (optimize (speed 3)))
130 (ceiling x
,divisor
)))
131 do
(loop for i from -
5 to
5
132 for exact-q
= (/ i divisor
)
133 do
(multiple-value-bind (q r
)
135 (assert (= (+ (* q divisor
) r
) i
))
136 (assert (<= exact-q q
))
137 (assert (< q
(1+ exact-q
)))))))
139 ;;; (TRUNCATE x 2^k) was optimized incorrectly
140 (with-test (:name
(truncate :power-of-two
))
141 (loop for divisor in
'(-4 4)
142 for truncater
= (checked-compile `(lambda (x)
144 (declare (optimize (speed 3)))
145 (truncate x
,divisor
)))
146 do
(loop for i from -
9 to
9
147 for exact-q
= (/ i divisor
)
148 do
(multiple-value-bind (q r
)
149 (funcall truncater i
)
150 (assert (= (+ (* q divisor
) r
) i
))
151 (assert (<= (abs q
) (abs exact-q
)))
152 (assert (< (abs exact-q
) (1+ (abs q
))))))))
154 ;;; CEILING had a corner case, spotted by Paul Dietz
155 (with-test (:name
(ceiling :corner-case
))
156 (assert (= (ceiling most-negative-fixnum
(1+ most-positive-fixnum
)) -
1)))
158 ;;; give any optimizers of constant multiplication a light testing.
159 ;;; 100 may seem low, but (a) it caught CSR's initial errors, and (b)
160 ;;; before checking in, CSR tested with 10000. So one hundred
161 ;;; checkins later, we'll have doubled the coverage.
162 (with-test (:name
(* :multiplication
:constant
:optimization
))
164 (let* ((x (random most-positive-fixnum
))
169 (declare (optimize speed
) (type (integer 0 3) y
))
171 :allow-notes
(> x3 most-positive-fixnum
))))
172 (assert (= (funcall fn
0) 0))
173 (assert (= (funcall fn
1) x
))
174 (assert (= (funcall fn
2) x2
))
175 (assert (= (funcall fn
3) x3
)))))
177 ;;; Bugs reported by Paul Dietz:
179 ;;; (GCD 0 x) must return (abs x)
180 (with-test (:name
(gcd 0))
181 (dolist (x (list -
10 (* 3 most-negative-fixnum
)))
182 (assert (= (gcd 0 x
) (abs x
)))))
184 ;;; LCM returns a non-negative number
185 (with-test (:name
(lcm :non-negative
))
186 (assert (= (lcm 4 -
10) 20))
187 (assert (= (lcm 0 0) 0)))
189 ;;; PPC bignum arithmetic bug:
190 (with-test (:name
(truncate bignum
:ppc
))
191 (multiple-value-bind (quo rem
)
192 (truncate 291351647815394962053040658028983955 10000000000000000000000000)
193 (assert (= quo
29135164781))
194 (assert (= rem
5394962053040658028983955))))
197 (with-test (:name
(:x86
:lea
))
198 (checked-compile-and-assert ()
199 '(lambda (x) (declare (bit x
)) (+ x
#xf0000000
))
202 (with-test (:name
(logbitp bignum
))
203 (dolist (x '(((1+ most-positive-fixnum
) 1 nil
)
204 ((1+ most-positive-fixnum
) -
1 t
)
205 ((1+ most-positive-fixnum
) (1+ most-positive-fixnum
) nil
)
206 ((1+ most-positive-fixnum
) (1- most-negative-fixnum
) t
)
207 (1 (ash most-negative-fixnum
1) nil
)
208 (#.
(- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1) most-negative-fixnum t
)
209 (#.
(1+ (- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1)) (ash most-negative-fixnum
1) t
)
210 (#.
(+ 2 (- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1)) (ash most-negative-fixnum
1) t
)
211 (#.
(+ sb-vm
:n-word-bits
32) (ash most-negative-fixnum
#.
(+ 32 sb-vm
:n-fixnum-tag-bits
2)) nil
)
212 (#.
(+ sb-vm
:n-word-bits
33) (ash most-negative-fixnum
#.
(+ 32 sb-vm
:n-fixnum-tag-bits
2)) t
)))
213 (destructuring-bind (index int result
) x
214 (assert (eq (eval `(logbitp ,index
,int
)) result
)))))
216 ;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD:
217 (with-test (:name
(dpb deposit-field
:off-by-one
))
218 (checked-compile-and-assert ()
220 (integer-length (dpb b
(byte 4 28) -
1005)))
222 (checked-compile-and-assert ()
224 (integer-length (deposit-field b
(byte 4 28) -
1005)))
227 ;;; type inference leading to an internal compiler error:
228 (with-test (:name
(ldb byte
0 :type-inference
))
229 (checked-compile-and-assert ()
231 (declare (type fixnum x
))
234 ((most-positive-fixnum) 0)
237 ;;; Alpha bignum arithmetic bug:
238 (with-test (:name
(bignum :arithmetic
:alpha
))
239 (assert (= (* 966082078641 419216044685) 404997107848943140073085)))
241 ;;; Alpha smallnum arithmetic bug:
242 (with-test (:name
(fixnum :arithmetc
:alpha
))
243 (assert (= (ash -
129876 -
1026) -
1)))
245 ;;; Alpha middlenum (yes, really! Affecting numbers between 2^32 and
246 ;;; 2^64 :) arithmetic bug
247 (with-test (:name
(truncate :middlenum
))
248 (checked-compile-and-assert ()
250 (declare (type (integer -
1621 -
513) a
)
251 (type (integer -
3 34163) b
)
252 (type (integer -
9485132993 81272960) c
)
253 (type (integer -
255340814 519943) d
)
255 (truncate c
(min -
100 4149605)))
256 ((-1332 5864 -
6963328729 -
43789079) (values 69633287 -
29))))
258 ;;; Here's another fantastic Alpha backend bug: the code to load
259 ;;; immediate 64-bit constants into a register was wrong.
260 (with-test (:name
(dpb :constants
))
261 (checked-compile-and-assert ()
263 (declare (type (integer -
3563 2733564) a
)
264 (type (integer -
548947 7159) b
)
265 (type (integer -
19 0) c
)
266 (type (integer -
2546009 0) d
)
269 ((89 125 16) (ash a
(min 18 -
706)))
270 (t (dpb -
3 (byte 30 30) -
1))))
271 ((1227072 -
529823 -
18 -
792831) -
2147483649)))
273 ;;; ASH of a negative bignum by a bignum count would erroneously
274 ;;; return 0 prior to sbcl-0.8.4.4
275 (with-test (:name
(ash :negative bignum
))
276 (assert (= (ash (1- most-negative-fixnum
) (1- most-negative-fixnum
)) -
1)))
278 ;;; Whoops. Too much optimization in division operators for 0
280 (with-test (:name
(mod truncate rem
/ floor ceiling
:division-by-zero fixnum
))
282 (let ((fn (checked-compile
284 (declare (optimize speed
) (fixnum x
))
286 (assert-error (funcall fn
1) division-by-zero
))))
287 (mapc #'frob
'(mod truncate rem
/ floor ceiling
))))
289 ;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
290 ;; comparisons without rationalizing the floats still gives the right anwers
291 ;; in the edge cases (had a fencepost error).
292 (macrolet ((test (range type sign
)
295 (start (- ,(find-symbol (format nil
296 "MOST-~A-EXACTLY-~A-FIXNUM"
300 (dotimes (i (1+ (* ,range
2)))
301 (let* ((x (+ start i
))
302 (y (coerce x
',type
)))
307 (dolist (op '(< <= = >= >))
308 (unless (eq (funcall op i f
)
309 (funcall op i
(rationalize f
)))
310 (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
312 op i
(rationalize f
)))
313 (unless (eq (funcall op f i
)
314 (funcall op
(rationalize f
) i
))
315 (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
317 op
(rationalize f
) i
))))))))
318 (test 32 double-float negative
)
319 (test 32 double-float positive
)
320 (test 32 single-float negative
)
321 (test 32 single-float positive
))
323 ;; x86-64 sign-extension bug found using pfdietz's random tester.
324 (with-test (:name
(:x86-64
:sign-extension
))
327 (declare (notinline logxor
))
328 (min (logxor 0 0 0 286142502)))))))
330 ;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
331 ;; unnoticed, so check more thoroughly here.
332 (with-test (:name logcount
)
334 (unless (= (logcount x
) n
)
335 (error "logcount failure for ~a" x
))))
336 ;; Test with some patterns with well known number of ones/zeroes ...
342 ;; ... and with some random integers of varying length.
343 (flet ((test-logcount (x)
344 (declare (type integer x
))
345 (do ((result 0 (1+ result
))
350 ((zerop x
) result
))))
352 (let ((x (random (ash 1 i
))))
353 (test x
(test-logcount x
))
354 (test (- x
) (test-logcount (- x
))))))))
356 ;; 1.0 had a broken ATANH on win32
357 (with-test (:name atanh
)
358 (assert (= (atanh 0.9d0
) 1.4722194895832204d0
)))
360 ;; Test some cases of integer operations with constant arguments
361 (with-test (:name
:constant-integers
)
362 (labels ((test-forms (op x y header
&rest forms
)
363 (let ((val (funcall op x y
)))
365 (let ((new-val (funcall (checked-compile (append header form
)) x y
)))
366 (unless (eql val new-val
)
367 (error "~S /= ~S: ~S ~S ~S~%" val new-val
(append header form
) x y
))))))
368 (test-case (op x y type
)
369 (test-forms op x y
`(lambda (x y
&aux z
)
370 (declare (type ,type x y
)
373 (optimize speed
(safety 0))))
375 `((setf z
(,op x
,y
))
378 `((values (,op x
,y
) x
))
380 `((setf z
(,op
,x y
))
383 `((values (,op
,x y
) y
))
392 (values (,op x
,y
) x
))
400 (values (,op
,x y
) y
))))
402 (let ((ub `(unsigned-byte ,sb-vm
:n-word-bits
))
403 (sb `(signed-byte ,sb-vm
:n-word-bits
)))
408 (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum
)
409 (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub
)
410 (,(- -
2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb
)
411 ,@(when (> sb-vm
:n-word-bits
32)
412 `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum
)
413 (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub
)
414 (,(- -
2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb
)
415 (,(ash 1 40) ,(ash 1 39) fixnum
)
416 (,(ash 1 40) ,(ash 1 39) ,ub
)
417 (,(ash 1 40) ,(ash 1 39) ,sb
)))
418 ;; fixnums that can be represented as 32-bit
419 ;; sign-extended immediates on x86-64
420 ,@(when (and (> sb-vm
:n-word-bits
32)
421 (< sb-vm
:n-fixnum-tag-bits
3))
422 `((,(1+ (ash 1 (- 31 sb-vm
:n-fixnum-tag-bits
)))
423 ,(1- (ash 1 (- 32 sb-vm
:n-fixnum-tag-bits
)))
426 (test-case op x y type
)
427 (test-case op x x type
)))))
428 (mapc #'test-op
'(+ -
* truncate
433 ;; GCD used to sometimes return negative values. The following did, on 32 bit
435 (with-test (:name gcd
)
437 (assert (plusp (gcd 20286123923750474264166990598656
438 680564733841876926926749214863536422912)))
440 (assert (plusp (gcd 2596102012663483082521318626691873
441 2596148429267413814265248164610048))))
443 (with-test (:name
(expt 0 0))
444 ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but
445 ;; (expt 0.0 0) returns 1.0
446 (flet ((error-case (expr)
447 (checked-compile-and-assert (:allow-style-warnings t
)
449 (() (condition 'sb-int
:arguments-out-of-domain-error
)))))
450 (error-case '(expt 0.0 0.0))
451 (error-case '(expt 0 0.0)))
452 (checked-compile-and-assert (:allow-style-warnings t
)
453 `(lambda () (expt 0.0 0))
456 (with-test (:name
:multiple-constant-folding
)
457 (let ((*random-state
* (make-random-state t
)))
460 (loop repeat
(1+ (random 12))
461 do
(if (zerop (random 2))
462 (let ((var (gensym)))
465 (push (- (random 21) 10) args
)))
466 (values args vars
))))
467 (dolist (op '(+ * logior logxor logand logeqv gcd lcm -
/))
469 do
(multiple-value-bind (args vars
) (make-args)
470 (let ((fast (checked-compile
473 :allow-style-warnings
(eq op
'/)))
474 (slow (checked-compile
476 (declare (notinline ,op
))
478 :allow-style-warnings
(eq op
'/))))
480 do
(let* ((call-args (loop repeat
(length vars
)
481 collect
(- (random 21) 10)))
482 (fast-result (handler-case
483 (apply fast call-args
)
484 (division-by-zero () :div0
)))
485 (slow-result (handler-case
486 (apply slow call-args
)
487 (division-by-zero () :div0
))))
488 (if (not (eql fast-result slow-result
))
489 (error "oops: ~S, ~S" args call-args
)
490 #+nil
(print (list :ok
`(,op
,@args
) :=> fast-result
))
493 ;;; (TRUNCATE <unsigned-word> <constant unsigned-word>) is optimized
494 ;;; to use multiplication instead of division. This propagates to FLOOR,
495 ;;; MOD and REM. Test that the transform is indeed triggered and test
496 ;;; several cases for correct results.
497 (with-test (:name
(:integer-division-using-multiplication
:used
)
498 :skipped-on
(not (or :x86-64
:x86
)))
499 (dolist (fun '(truncate floor ceiling mod rem
))
500 (let* ((foo (checked-compile
502 (declare (optimize (speed 3)
504 (compilation-speed 0))
505 (type (unsigned-byte ,sb-vm
:n-word-bits
) x
))
507 (disassembly (with-output-to-string (s)
508 (disassemble foo
:stream s
))))
509 ;; KLUDGE copied from test :float-division-using-exact-reciprocal
510 ;; in compiler.pure.lisp.
511 (assert (and (not (search "DIV" disassembly
))
512 (search "MUL" disassembly
))))))
514 (with-test (:name
(:integer-division-using-multiplication
:correctness
))
515 (let ((*random-state
* (make-random-state t
)))
516 (dolist (dividend-type `((unsigned-byte ,sb-vm
:n-word-bits
)
517 (and fixnum unsigned-byte
)
518 (integer 10000 10100)))
519 (dolist (divisor `(;; Some special cases from the paper
523 ,most-positive-fixnum
524 ,(1- (expt 2 sb-vm
:n-word-bits
))
525 ;; Some random values
526 ,@(loop for i from
8 to sb-vm
:n-word-bits
527 for r
= (random (expt 2 i
))
528 ;; We don't want 0, 1 and powers of 2.
529 when
(not (zerop (logand r
(1- r
))))
531 (dolist (fun '(truncate ceiling floor mod rem
))
532 (let ((foo (checked-compile
534 (declare (optimize (speed 3)
536 (compilation-speed 0))
537 (type ,dividend-type x
))
538 (,fun x
,divisor
)))))
539 (dolist (dividend `(0 1 ,most-positive-fixnum
540 ,(1- divisor
) ,divisor
541 ,(1- (* divisor
2)) ,(* divisor
2)
543 collect
(+ 10000 (random 101)))
544 ,@(loop for i from
4 to sb-vm
:n-word-bits
545 for pow
= (expt 2 (1- i
))
546 for r
= (+ pow
(random pow
))
548 (when (typep dividend dividend-type
)
549 (multiple-value-bind (q1 r1
)
550 (funcall foo dividend
)
551 (multiple-value-bind (q2 r2
)
552 (funcall fun dividend divisor
)
553 (unless (and (= q1 q2
)
555 (error "bad results for ~s with dividend type ~s"
556 (list fun dividend divisor
)
557 dividend-type
))))))))))))
559 ;; The fast path for logbitp underestimated sb!vm:n-positive-fixnum-bits
560 ;; for > 61 bit fixnums.
561 (with-test (:name
(logbitp :wide fixnum
))
562 (assert (not (logbitp (1- (integer-length most-positive-fixnum
))
563 most-negative-fixnum
))))
565 ;; EXPT dispatches in a complicated way on the types of its arguments.
566 ;; Check that all possible combinations are covered.
567 (with-test (:name
(expt :argument-type-combinations
))
568 (let ((numbers '(2 ; fixnum
572 #c
(3/5 1/7) ; complex rational
573 #c
(1.2f0
1.3f0
) ; complex single-float
574 #c
(2.0d0
3.0d0
))) ; complex double-float
577 (dolist (base (cons bignum numbers
))
578 (dolist (power numbers
)
579 #+nil
(format t
"(expt ~s ~s) => " base power
)
580 (let ((result (expt base power
)))
581 #+nil
(format t
"~s~%" result
)
582 (push result results
))))
583 (assert (every #'numberp results
))))
585 (with-test (:name
:bug-741564
)
586 ;; The bug was that in (expt <fixnum> <(complex double-float)>) the
587 ;; calculation was partially done only to single-float precision,
588 ;; making the complex double-float result too unprecise. Some other
589 ;; combinations of argument types were affected, too; test that all
590 ;; of them are good to double-float precision.
591 (labels ((nearly-equal-p (x y
)
592 "Are the arguments equal to nearly double-float precision?"
593 (declare (type double-float x y
))
594 (< (/ (abs (- x y
)) (abs y
))
595 (* double-float-epsilon
4))) ; Differences in the two least
596 ; significant mantissa bits
599 (and (nearly-equal-p (realpart x
) (realpart y
))
600 (nearly-equal-p (imagpart x
) (imagpart y
))))
601 (print-result (msg base power got expected
)
602 (declare (ignorable msg base power got expected
))
604 (format t
"~a (expt ~s ~s)~%got ~s~%expected ~s~%"
605 msg base power got expected
)))
607 (flet ((test (base power coerce-to-type
)
608 (let* ((got (expt base power
))
609 (expected (expt (coerce base coerce-to-type
) power
))
610 (result (test-complex got expected
)))
611 (print-result (if result
"Good:" "Bad:")
612 base power got expected
)
615 (dolist (base (list 2 ; fixnum
618 2.0f0
)) ; single-float
619 (let ((power #c
(-2.5d0 -
4.5d0
))) ; complex double-float
620 (test base power
'double-float
)))
621 (dolist (base (list #c
(2.0f0
3.0f0
) ; complex single-float
622 #c
(2 3) ; complex fixnum
623 (complex (expt 2 64) (expt 2 65))
625 #c
(3/5 1/7))) ; complex ratio
626 (dolist (power (list #c
(-2.5d0 -
4.5d0
) ; complex double-float
627 -
2.5d0
)) ; double-float
628 (test base power
'(complex double-float
)))))
630 (error "Number of broken combinations: ~a" n-broken
)))))
632 (with-test (:name
(ldb :rlwinm
:ppc
))
633 (let ((one (checked-compile '(lambda (a) (ldb (byte 9 27) a
))))
634 (two (checked-compile '(lambda (a)
635 (declare (type (integer -
3 57216651) a
))
636 (ldb (byte 9 27) a
)))))
637 (assert (= 0 (- (funcall one
10) (funcall two
10))))))
639 ;; The ISQRT implementation is sufficiently complicated that it should
641 (with-test (:name isqrt
)
645 (s2 (expt (1+ r
) 2)))
646 (unless (and (<= r2 x
)
648 (error "isqrt failure for ~a" x
))))
651 (let ((x2 (expt x
2)))
655 (test most-positive-fixnum
)
656 (test (1+ most-positive-fixnum
))
657 (loop for i from
1 to
200
658 for pow
= (expt 2 (1- i
))
659 for j
= (+ pow
(random pow
))
664 (tests (random (expt 2 (+ 1000 (random 10000))))))))
666 ;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
667 (with-test (:name
:recursive-cut-to-width
)
668 (checked-compile-and-assert (:optimize
'(:speed t
:safety t
:debug t
:space t
))
670 (declare (type (integer 12417236377505266230
671 12417274239874990070)
673 (logand 8459622733968096971 x
))
674 ((12417237222845306758) 2612793697039849090)))
676 ;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
677 (with-test (:name
(:recursive-cut-to-width
:more
))
678 (checked-compile-and-assert ()
680 (logand (the (eql 16779072918521075607) a
)
681 (the (integer 21371810342718833225 21371810343571293860) b
)))
682 ((16779072918521075607 21371810342718833263) 2923729245085762055)))
684 (with-test (:name
(logand :complicated-identity
))
685 (loop for k from -
8 upto
8 do
686 (loop for min from -
16 upto
16 do
687 (loop for max from min upto
16 do
688 (let ((f (checked-compile `(lambda (x)
689 (declare (type (integer ,min
,max
) x
))
691 (loop for x from min upto max do
692 (assert (eql (logand x k
) (funcall f x
)))))))))
694 (with-test (:name
(logior :complicated-identity
))
695 (loop for k from -
8 upto
8 do
696 (loop for min from -
16 upto
16 do
697 (loop for max from min upto
16 do
698 (let ((f (checked-compile `(lambda (x)
699 (declare (type (integer ,min
,max
) x
))
701 (loop for x from min upto max do
702 (assert (eql (logior x k
) (funcall f x
)))))))))
704 (with-test (:name
(ldb :negative-index-no-error
))
705 (checked-compile-and-assert ()
706 '(lambda (x y
) (ldb (byte x y
) 100))
707 ((-1 -
2) (condition 'error
)))
708 (checked-compile-and-assert ()
709 '(lambda (x y
) (mask-field (byte x y
) 100))
710 ((-1 -
2) (condition 'error
)))
711 (checked-compile-and-assert ()
712 '(lambda (x y
) (dpb 0 (byte x y
) 100))
713 ((-1 -
2) (condition 'error
)))
714 (checked-compile-and-assert ()
715 '(lambda (x y
) (deposit-field 0 (byte x y
) 100))
716 ((-1 -
2) (condition 'error
))))
718 (with-test (:name
(mask-field setf
))
719 (checked-compile-and-assert ()
721 (setf (mask-field (byte 2 0) a
) 1) a
)
724 (with-test (:name
:complex-multiply
)
725 (checked-compile-and-assert ()
728 (expt (setf z
(complex -
0.123 -
0.789)) 2)))
729 (() #C
(-0.60739195
0.194094))))
731 (with-test (:name
(sqrt complex
))
732 (assert (= (expt (sqrt least-negative-double-float
) 2)
733 least-negative-double-float
)))
735 (with-test (:name
(ldb :sign
))
736 (checked-compile-and-assert ()
738 (ldb (byte ,(1- sb-vm
:n-word-bits
) 0) x
))
741 (with-test (:name
:mod-arith-large-constant
)
742 (checked-compile-and-assert ()
744 (declare (sb-ext:word x
))
745 (logand sb-ext
:most-positive-word
749 (with-test (:name
(bignum :ash
:left fixnum
))
750 (assert (= (eval '(ash most-negative-fixnum
(1- sb-vm
:n-word-bits
)))
751 (eval '(* most-negative-fixnum
(expt 2 (1- sb-vm
:n-word-bits
)))))))
753 (with-test (:name
(ldb fixnum
:sign-bits
))
754 (checked-compile-and-assert ()
757 (ldb (byte (/ sb-vm
:n-word-bits
2)
758 (/ sb-vm
:n-word-bits
2))
760 ((most-positive-fixnum) (ash most-positive-fixnum
(- (/ sb-vm
:n-word-bits
2))))
761 ((-1) (1- (expt 2 (/ sb-vm
:n-word-bits
2))))))
763 (with-test (:name
(dpb :sign-bits
))
764 (checked-compile-and-assert ()
767 (dpb 1 (byte (/ sb-vm
:n-word-bits
2)
768 (/ sb-vm
:n-word-bits
2))
771 (logior (ash 1 (/ sb-vm
:n-word-bits
2))
773 (mask-field (byte (/ sb-vm
:n-word-bits
2)
774 (/ sb-vm
:n-word-bits
2))
776 ((most-positive-fixnum)
777 (logior (ash 1 (/ sb-vm
:n-word-bits
2))
778 (logandc2 most-positive-fixnum
779 (mask-field (byte (/ sb-vm
:n-word-bits
2)
780 (/ sb-vm
:n-word-bits
2))
783 (with-test (:name
(dpb :position-zero
))
784 (checked-compile-and-assert ()
786 (declare (sb-vm:word x
))
787 (dpb 0 (byte (/ sb-vm
:n-word-bits
2) 0) x
))
789 ((sb-ext:most-positive-word
)
790 (logxor sb-ext
:most-positive-word
791 (1- (expt 2 (/ sb-vm
:n-word-bits
2)))))))
793 (with-test (:name
(logand :mask-word
))
794 (checked-compile-and-assert ()
796 (logand x
(ash sb-ext
:most-positive-word -
1)))
797 ((-1) (ash most-positive-word -
1))))
799 (with-test (:name
(/ complex real single-float
))
800 (checked-compile-and-assert ()
802 (declare (type single-float b
))
804 ((1.0
) #c
(1.0
2.0))))
806 (with-test (:name
(ash :unsigned
))
807 (checked-compile-and-assert ()
809 (declare (sb-vm:signed-word x
))