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 (assert-error (funcall (checked-compile
42 `(lambda () (/ 2/3 0))
43 :allow-style-warnings t
))
46 (with-test (:name
(/ :division-by-zero bignum
))
47 (assert-error (funcall (checked-compile
48 `(lambda () (/ (1+ most-positive-fixnum
) 0))
49 :allow-style-warnings t
))
52 ;;; In a bug reported by Raymond Toy on cmucl-imp 2002-07-18, (COERCE
53 ;;; <RATIONAL> '(COMPLEX FLOAT)) was failing to return a complex
54 ;;; float; a patch was given by Wolfhard Buss cmucl-imp 2002-07-19.
55 (assert (= (coerce 1 '(complex float
)) #c
(1.0
0.0)))
56 (assert (= (coerce 1/2 '(complex float
)) #c
(0.5
0.0)))
57 (assert (= (coerce 1.0d0
'(complex float
)) #c
(1.0d0
0.0d0
)))
59 ;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
60 ;;; an error up to 0.8.17.31
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 (assert-error (funcall (checked-compile
68 `(lambda () (coerce 1 '(float 2.0 3.0)))
69 :allow-style-warnings t
))
71 (assert-error (funcall (checked-compile
72 `(lambda () (coerce 1 '(single-float -
1.0 0.0)))
73 :allow-style-warnings t
))
75 (assert (eql (coerce 1 '(single-float -
1.0 2.0)) 1.0)))
77 ;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
78 ;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
79 ;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
80 (with-test (:name
(min max type-error
))
81 (assert (null (ignore-errors (funcall
82 (checked-compile `(lambda () (min '(1 2 3)))
83 :allow-style-warnings t
)))))
84 (assert (= (min -
1) -
1))
85 (assert (null (ignore-errors (funcall
86 (checked-compile `(lambda () (min 1 #(1 2 3)))
87 :allow-style-warnings t
)))))
88 (assert (= (min 10 11) 10))
89 (assert (null (ignore-errors (funcall
91 `(lambda () (min (find-package "CL") -
5.0))
92 :allow-style-warnings t
)))))
93 (assert (= (min 5.0 -
3) -
3))
94 (assert (null (ignore-errors (checked-compile `(lambda () (max #c
(4 3)))
95 :allow-style-warnings t
))))
96 (assert (= (max 0) 0))
97 (assert (null (ignore-errors (funcall
98 (checked-compile `(lambda () (max "MIX" 3))
99 :allow-style-warnings t
)))))
100 (assert (= (max -
1 10.0) 10.0))
101 (assert (null (ignore-errors (funcall
102 (checked-compile `(lambda () (max 3 #'max
))
103 :allow-style-warnings t
)))))
104 (assert (= (max -
3 0) 0)))
106 (with-test (:name
:numeric-inequality-
&rest-arguments
)
107 (dolist (f '(= < <= > >=))
109 (assert-error (funcall f
'feep
) type-error
)
111 ;; = accepts complex numbers
112 (assert-error (funcall f
#c
(0s0 1s0
)) type-error
))
114 (assert-error (funcall f
3 'feep
) type-error
)
115 (assert-error (funcall f
'feep
3) type-error
)
117 (assert-error (funcall f
0 0 'feep
) type-error
)
118 (assert-error (funcall f
0 1 'feep
) type-error
)
119 (assert-error (funcall f
1 0 'feep
) type-error
)
121 (assert-error (funcall f
0 0 0 'feep
) type-error
))
122 ;; Also MIN,MAX operate only on REAL
123 (dolist (f '(min max
))
124 (assert-error (funcall f
#c
(1s0 -
2s0
)) type-error
)))
126 ;;; (CEILING x 2^k) was optimized incorrectly
127 (loop for divisor in
'(-4 4)
128 for ceiler
= (compile nil
`(lambda (x)
130 (declare (optimize (speed 3)))
131 (ceiling x
,divisor
)))
132 do
(loop for i from -
5 to
5
133 for exact-q
= (/ i divisor
)
134 do
(multiple-value-bind (q r
)
136 (assert (= (+ (* q divisor
) r
) i
))
137 (assert (<= exact-q q
))
138 (assert (< q
(1+ exact-q
))))))
140 ;;; (TRUNCATE x 2^k) was optimized incorrectly
141 (loop for divisor in
'(-4 4)
142 for truncater
= (compile nil
`(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 (assert (= (ceiling most-negative-fixnum
(1+ most-positive-fixnum
)) -
1))
157 ;;; give any optimizers of constant multiplication a light testing.
158 ;;; 100 may seem low, but (a) it caught CSR's initial errors, and (b)
159 ;;; before checking in, CSR tested with 10000. So one hundred
160 ;;; checkins later, we'll have doubled the coverage.
161 (with-test (:name
(* :multiplication
:constant
:optimization
))
163 (let* ((x (random most-positive-fixnum
))
168 (declare (optimize speed
) (type (integer 0 3) y
))
170 :allow-notes
(> x3 most-positive-fixnum
))))
171 (assert (= (funcall fn
0) 0))
172 (assert (= (funcall fn
1) x
))
173 (assert (= (funcall fn
2) x2
))
174 (assert (= (funcall fn
3) x3
)))))
176 ;;; Bugs reported by Paul Dietz:
178 ;;; (GCD 0 x) must return (abs x)
179 (dolist (x (list -
10 (* 3 most-negative-fixnum
)))
180 (assert (= (gcd 0 x
) (abs x
))))
181 ;;; LCM returns a non-negative number
182 (assert (= (lcm 4 -
10) 20))
183 (assert (= (lcm 0 0) 0))
185 ;;; PPC bignum arithmetic bug:
186 (multiple-value-bind (quo rem
)
187 (truncate 291351647815394962053040658028983955 10000000000000000000000000)
188 (assert (= quo
29135164781))
189 (assert (= rem
5394962053040658028983955)))
193 (compile nil
'(lambda (x) (declare (bit x
)) (+ x
#xf0000000
)))
197 ;;; LOGBITP on bignums:
198 (dolist (x '(((1+ most-positive-fixnum
) 1 nil
)
199 ((1+ most-positive-fixnum
) -
1 t
)
200 ((1+ most-positive-fixnum
) (1+ most-positive-fixnum
) nil
)
201 ((1+ most-positive-fixnum
) (1- most-negative-fixnum
) t
)
202 (1 (ash most-negative-fixnum
1) nil
)
203 (#.
(- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1) most-negative-fixnum t
)
204 (#.
(1+ (- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1)) (ash most-negative-fixnum
1) t
)
205 (#.
(+ 2 (- sb-vm
:n-word-bits sb-vm
:n-fixnum-tag-bits
1)) (ash most-negative-fixnum
1) t
)
206 (#.
(+ sb-vm
:n-word-bits
32) (ash most-negative-fixnum
#.
(+ 32 sb-vm
:n-fixnum-tag-bits
2)) nil
)
207 (#.
(+ sb-vm
:n-word-bits
33) (ash most-negative-fixnum
#.
(+ 32 sb-vm
:n-fixnum-tag-bits
2)) t
)))
208 (destructuring-bind (index int result
) x
209 (assert (eq (eval `(logbitp ,index
,int
)) result
))))
211 ;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD:
212 (let ((f (compile nil
'(lambda (b)
213 (integer-length (dpb b
(byte 4 28) -
1005))))))
214 (assert (= (funcall f
1230070) 32)))
215 (let ((f (compile nil
'(lambda (b)
216 (integer-length (deposit-field b
(byte 4 28) -
1005))))))
217 (assert (= (funcall f
1230070) 32)))
219 ;;; type inference leading to an internal compiler error:
220 (let ((f (compile nil
'(lambda (x)
221 (declare (type fixnum x
))
222 (ldb (byte 0 0) x
)))))
223 (assert (= (funcall f
1) 0))
224 (assert (= (funcall f most-positive-fixnum
) 0))
225 (assert (= (funcall f -
1) 0)))
227 ;;; Alpha bignum arithmetic bug:
228 (assert (= (* 966082078641 419216044685) 404997107848943140073085))
230 ;;; Alpha smallnum arithmetic bug:
231 (assert (= (ash -
129876 -
1026) -
1))
233 ;;; Alpha middlenum (yes, really! Affecting numbers between 2^32 and
234 ;;; 2^64 :) arithmetic bug
235 (with-test (:name
(truncate :middlenum
))
236 (let ((fn (checked-compile
238 (declare (type (integer -
1621 -
513) a
)
239 (type (integer -
3 34163) b
)
240 (type (integer -
9485132993 81272960) c
)
241 (type (integer -
255340814 519943) d
)
243 (optimize (speed 3) (safety 1) (debug 1)))
244 (truncate c
(min -
100 4149605))))))
245 (assert (= (funcall fn -
1332 5864 -
6963328729 -
43789079) 69633287))))
247 ;;; Here's another fantastic Alpha backend bug: the code to load
248 ;;; immediate 64-bit constants into a register was wrong.
249 (with-test (:name
(dpb :constants
))
250 (let ((fn (checked-compile `(lambda (a b c d
)
251 (declare (type (integer -
3563 2733564) a
)
252 (type (integer -
548947 7159) b
)
253 (type (integer -
19 0) c
)
254 (type (integer -
2546009 0) d
)
256 (optimize (speed 3) (safety 1) (debug 1)))
258 ((89 125 16) (ash a
(min 18 -
706)))
259 (t (dpb -
3 (byte 30 30) -
1)))))))
260 (assert (= (funcall fn
1227072 -
529823 -
18 -
792831) -
2147483649))))
262 ;;; ASH of a negative bignum by a bignum count would erroneously
263 ;;; return 0 prior to sbcl-0.8.4.4
264 (assert (= (ash (1- most-negative-fixnum
) (1- most-negative-fixnum
)) -
1))
266 ;;; Whoops. Too much optimization in division operators for 0
268 (with-test (:name
(mod truncate rem
/ floor ceiling
:division-by-zero fixnum
))
270 (let ((fn (checked-compile
272 (declare (optimize speed
) (fixnum x
))
274 (assert-error (funcall fn
1) division-by-zero
))))
275 (mapc #'frob
'(mod truncate rem
/ floor ceiling
))))
277 ;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
278 ;; comparisons without rationalizing the floats still gives the right anwers
279 ;; in the edge cases (had a fencepost error).
280 (macrolet ((test (range type sign
)
283 (start (- ,(find-symbol (format nil
284 "MOST-~A-EXACTLY-~A-FIXNUM"
288 (dotimes (i (1+ (* ,range
2)))
289 (let* ((x (+ start i
))
290 (y (coerce x
',type
)))
295 (dolist (op '(< <= = >= >))
296 (unless (eq (funcall op i f
)
297 (funcall op i
(rationalize f
)))
298 (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
300 op i
(rationalize f
)))
301 (unless (eq (funcall op f i
)
302 (funcall op
(rationalize f
) i
))
303 (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
305 op
(rationalize f
) i
))))))))
306 (test 32 double-float negative
)
307 (test 32 double-float positive
)
308 (test 32 single-float negative
)
309 (test 32 single-float positive
))
311 ;; x86-64 sign-extension bug found using pfdietz's random tester.
314 (declare (notinline logxor
))
315 (min (logxor 0 0 0 286142502))))))
317 ;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
318 ;; unnoticed, so check more thoroughly here.
319 (with-test (:name
:logcount
)
321 (unless (= (logcount x
) n
)
322 (error "logcount failure for ~a" x
))))
323 ;; Test with some patterns with well known number of ones/zeroes ...
329 ;; ... and with some random integers of varying length.
330 (flet ((test-logcount (x)
331 (declare (type integer x
))
332 (do ((result 0 (1+ result
))
337 ((zerop x
) result
))))
339 (let ((x (random (ash 1 i
))))
340 (test x
(test-logcount x
))
341 (test (- x
) (test-logcount (- x
))))))))
343 ;; 1.0 had a broken ATANH on win32
344 (with-test (:name
:atanh
)
345 (assert (= (atanh 0.9d0
) 1.4722194895832204d0
)))
347 ;; Test some cases of integer operations with constant arguments
348 (with-test (:name
:constant-integers
)
349 (labels ((test-forms (op x y header
&rest forms
)
350 (let ((val (funcall op x y
)))
352 (let ((new-val (funcall (checked-compile (append header form
)) x y
)))
353 (unless (eql val new-val
)
354 (error "~S /= ~S: ~S ~S ~S~%" val new-val
(append header form
) x y
))))))
355 (test-case (op x y type
)
356 (test-forms op x y
`(lambda (x y
&aux z
)
357 (declare (type ,type x y
)
360 (optimize speed
(safety 0))))
362 `((setf z
(,op x
,y
))
365 `((values (,op x
,y
) x
))
367 `((setf z
(,op
,x y
))
370 `((values (,op
,x y
) y
))
379 (values (,op x
,y
) x
))
387 (values (,op
,x y
) y
))))
389 (let ((ub `(unsigned-byte ,sb-vm
:n-word-bits
))
390 (sb `(signed-byte ,sb-vm
:n-word-bits
)))
395 (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum
)
396 (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub
)
397 (,(- -
2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb
)
398 ,@(when (> sb-vm
:n-word-bits
32)
399 `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum
)
400 (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub
)
401 (,(- -
2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb
)
402 (,(ash 1 40) ,(ash 1 39) fixnum
)
403 (,(ash 1 40) ,(ash 1 39) ,ub
)
404 (,(ash 1 40) ,(ash 1 39) ,sb
)))
405 ;; fixnums that can be represented as 32-bit
406 ;; sign-extended immediates on x86-64
407 ,@(when (and (> sb-vm
:n-word-bits
32)
408 (< sb-vm
:n-fixnum-tag-bits
3))
409 `((,(1+ (ash 1 (- 31 sb-vm
:n-fixnum-tag-bits
)))
410 ,(1- (ash 1 (- 32 sb-vm
:n-fixnum-tag-bits
)))
413 (test-case op x y type
)
414 (test-case op x x type
)))))
415 (mapc #'test-op
'(+ -
* truncate
420 ;; GCD used to sometimes return negative values. The following did, on 32 bit
422 (with-test (:name
:gcd
)
424 (assert (plusp (gcd 20286123923750474264166990598656
425 680564733841876926926749214863536422912)))
427 (assert (plusp (gcd 2596102012663483082521318626691873
428 2596148429267413814265248164610048))))
430 (with-test (:name
:expt-zero-zero
)
431 ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but
432 ;; (expt 0.0 0) returns 1.0
433 (flet ((error-case (expr)
434 (assert-error (funcall (checked-compile `(lambda () ,expr
)
435 :allow-style-warnings t
))
436 sb-int
:arguments-out-of-domain-error
)))
437 (error-case '(expt 0.0 0.0))
438 (error-case '(expt 0 0.0)))
439 (assert (eql (expt 0.0 0) 1.0)))
441 (with-test (:name
:multiple-constant-folding
)
442 (let ((*random-state
* (make-random-state t
)))
445 (loop repeat
(1+ (random 12))
446 do
(if (zerop (random 2))
447 (let ((var (gensym)))
450 (push (- (random 21) 10) args
)))
451 (values args vars
))))
452 (dolist (op '(+ * logior logxor logand logeqv gcd lcm -
/))
454 do
(multiple-value-bind (args vars
) (make-args)
455 (let ((fast (checked-compile
458 :allow-style-warnings
(eq op
'/)))
459 (slow (checked-compile
461 (declare (notinline ,op
))
463 :allow-style-warnings
(eq op
'/))))
465 do
(let* ((call-args (loop repeat
(length vars
)
466 collect
(- (random 21) 10)))
467 (fast-result (handler-case
468 (apply fast call-args
)
469 (division-by-zero () :div0
)))
470 (slow-result (handler-case
471 (apply slow call-args
)
472 (division-by-zero () :div0
))))
473 (if (eql fast-result slow-result
)
474 (print (list :ok
`(,op
,@args
) :=> fast-result
))
475 (error "oops: ~S, ~S" args call-args
)))))))))))
477 ;;; (TRUNCATE <unsigned-word> <constant unsigned-word>) is optimized
478 ;;; to use multiplication instead of division. This propagates to FLOOR,
479 ;;; MOD and REM. Test that the transform is indeed triggered and test
480 ;;; several cases for correct results.
481 (with-test (:name
(:integer-division-using-multiplication
:used
)
482 :skipped-on
'(not (or :x86-64
:x86
)))
483 (dolist (fun '(truncate floor ceiling mod rem
))
484 (let* ((foo (checked-compile
486 (declare (optimize (speed 3)
488 (compilation-speed 0))
489 (type (unsigned-byte ,sb-vm
:n-word-bits
) x
))
491 (disassembly (with-output-to-string (s)
492 (disassemble foo
:stream s
))))
493 ;; KLUDGE copied from test :float-division-using-exact-reciprocal
494 ;; in compiler.pure.lisp.
495 (assert (and (not (search "DIV" disassembly
))
496 (search "MUL" disassembly
))))))
498 (with-test (:name
(:integer-division-using-multiplication
:correctness
))
499 (let ((*random-state
* (make-random-state t
)))
500 (dolist (dividend-type `((unsigned-byte ,sb-vm
:n-word-bits
)
501 (and fixnum unsigned-byte
)
502 (integer 10000 10100)))
503 (dolist (divisor `(;; Some special cases from the paper
507 ,most-positive-fixnum
508 ,(1- (expt 2 sb-vm
:n-word-bits
))
509 ;; Some random values
510 ,@(loop for i from
8 to sb-vm
:n-word-bits
511 for r
= (random (expt 2 i
))
512 ;; We don't want 0, 1 and powers of 2.
513 when
(not (zerop (logand r
(1- r
))))
515 (dolist (fun '(truncate ceiling floor mod rem
))
516 (let ((foo (checked-compile
518 (declare (optimize (speed 3)
520 (compilation-speed 0))
521 (type ,dividend-type x
))
522 (,fun x
,divisor
)))))
523 (dolist (dividend `(0 1 ,most-positive-fixnum
524 ,(1- divisor
) ,divisor
525 ,(1- (* divisor
2)) ,(* divisor
2)
527 collect
(+ 10000 (random 101)))
528 ,@(loop for i from
4 to sb-vm
:n-word-bits
529 for pow
= (expt 2 (1- i
))
530 for r
= (+ pow
(random pow
))
532 (when (typep dividend dividend-type
)
533 (multiple-value-bind (q1 r1
)
534 (funcall foo dividend
)
535 (multiple-value-bind (q2 r2
)
536 (funcall fun dividend divisor
)
537 (unless (and (= q1 q2
)
539 (error "bad results for ~s with dividend type ~s"
540 (list fun dividend divisor
)
541 dividend-type
))))))))))))
543 ;; The fast path for logbitp underestimated sb!vm:n-positive-fixnum-bits
544 ;; for > 61 bit fixnums.
545 (with-test (:name
:logbitp-wide-fixnum
)
546 (assert (not (logbitp (1- (integer-length most-positive-fixnum
))
547 most-negative-fixnum
))))
549 ;; EXPT dispatches in a complicated way on the types of its arguments.
550 ;; Check that all possible combinations are covered.
551 (with-test (:name
(:expt
:argument-type-combinations
))
552 (let ((numbers '(2 ; fixnum
556 #c
(3/5 1/7) ; complex rational
557 #c
(1.2f0
1.3f0
) ; complex single-float
558 #c
(2.0d0
3.0d0
))) ; complex double-float
561 (dolist (base (cons bignum numbers
))
562 (dolist (power numbers
)
563 (format t
"(expt ~s ~s) => " base power
)
564 (let ((result (expt base power
)))
565 (format t
"~s~%" result
)
566 (push result results
))))
567 (assert (every #'numberp results
))))
569 (with-test (:name
:bug-741564
)
570 ;; The bug was that in (expt <fixnum> <(complex double-float)>) the
571 ;; calculation was partially done only to single-float precision,
572 ;; making the complex double-float result too unprecise. Some other
573 ;; combinations of argument types were affected, too; test that all
574 ;; of them are good to double-float precision.
575 (labels ((nearly-equal-p (x y
)
576 "Are the arguments equal to nearly double-float precision?"
577 (declare (type double-float x y
))
578 (< (/ (abs (- x y
)) (abs y
))
579 (* double-float-epsilon
4))) ; Differences in the two least
580 ; significant mantissa bits
583 (and (nearly-equal-p (realpart x
) (realpart y
))
584 (nearly-equal-p (imagpart x
) (imagpart y
))))
585 (print-result (msg base power got expected
)
586 (format t
"~a (expt ~s ~s)~%got ~s~%expected ~s~%"
587 msg base power got expected
)))
589 (flet ((test (base power coerce-to-type
)
590 (let* ((got (expt base power
))
591 (expected (expt (coerce base coerce-to-type
) power
))
592 (result (test-complex got expected
)))
593 (print-result (if result
"Good:" "Bad:")
594 base power got expected
)
597 (dolist (base (list 2 ; fixnum
600 2.0f0
)) ; single-float
601 (let ((power #c
(-2.5d0 -
4.5d0
))) ; complex double-float
602 (test base power
'double-float
)))
603 (dolist (base (list #c
(2.0f0
3.0f0
) ; complex single-float
604 #c
(2 3) ; complex fixnum
605 (complex (expt 2 64) (expt 2 65))
607 #c
(3/5 1/7))) ; complex ratio
608 (dolist (power (list #c
(-2.5d0 -
4.5d0
) ; complex double-float
609 -
2.5d0
)) ; double-float
610 (test base power
'(complex double-float
)))))
612 (error "Number of broken combinations: ~a" n-broken
)))))
614 (with-test (:name
(:ldb
:rlwinm
:ppc
))
615 (let ((one (checked-compile `(lambda (a) (ldb (byte 9 27) a
))))
616 (two (checked-compile `(lambda (a)
617 (declare (type (integer -
3 57216651) a
))
618 (ldb (byte 9 27) a
)))))
619 (assert (= 0 (- (funcall one
10) (funcall two
10))))))
621 ;; The ISQRT implementation is sufficiently complicated that it should
623 (with-test (:name
:isqrt
)
627 (s2 (expt (1+ r
) 2)))
628 (unless (and (<= r2 x
)
630 (error "isqrt failure for ~a" x
))))
633 (let ((x2 (expt x
2)))
637 (test most-positive-fixnum
)
638 (test (1+ most-positive-fixnum
))
639 (loop for i from
1 to
200
640 for pow
= (expt 2 (1- i
))
641 for j
= (+ pow
(random pow
))
646 (tests (random (expt 2 (+ 1000 (random 10000))))))))
648 ;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
649 (with-test (:name
:recursive-cut-to-width
)
650 (assert (eql (funcall
653 (declare (optimize (space 3))
654 (type (integer 12417236377505266230
655 12417274239874990070)
657 (logand 8459622733968096971 x
)))
658 12417237222845306758)
659 2612793697039849090)))
661 ;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
662 (with-test (:name
:more-recursive-cut-to-width
)
663 (assert (eql (funcall
666 (declare (optimize (speed 2) (safety 0)))
667 (logand (the (eql 16779072918521075607) a
)
668 (the (integer 21371810342718833225 21371810343571293860) b
))))
669 16779072918521075607 21371810342718833263)
670 2923729245085762055)))
672 (with-test (:name
:complicated-logand-identity
)
673 (loop for k from -
8 upto
8 do
674 (loop for min from -
16 upto
16 do
675 (loop for max from min upto
16 do
676 (let ((f (checked-compile `(lambda (x)
677 (declare (type (integer ,min
,max
) x
))
679 (loop for x from min upto max do
680 (assert (eql (logand x k
) (funcall f x
)))))))))
682 (with-test (:name
:complicated-logior-identity
)
683 (loop for k from -
8 upto
8 do
684 (loop for min from -
16 upto
16 do
685 (loop for max from min upto
16 do
686 (let ((f (checked-compile `(lambda (x)
687 (declare (type (integer ,min
,max
) x
))
689 (loop for x from min upto max do
690 (assert (eql (logior x k
) (funcall f x
)))))))))
692 (with-test (:name
:ldb-negative-index-no-error
)
694 (funcall (checked-compile `(lambda (x y
)
695 (ldb (byte x y
) 100)))
698 (funcall (checked-compile `(lambda (x y
)
699 (mask-field (byte x y
) 100)))
702 (funcall (checked-compile `(lambda (x y
)
703 (dpb 0 (byte x y
) 100)))
706 (funcall (checked-compile `(lambda (x y
)
707 (deposit-field 0 (byte x y
) 100)))
710 (with-test (:name
:setf-mask-field
)
712 (checked-compile `(lambda (a)
713 (setf (mask-field (byte 2 0) a
) 1) a
))
716 (with-test (:name
:complex-multiply
)
720 (declare (optimize speed
))
722 (expt (setf z
(complex -
0.123 -
0.789)) 2)))))
723 #C
(-0.60739195
0.194094))))
725 (with-test (:name
:complex-sqrt
)
726 (assert (= (expt (sqrt least-negative-double-float
) 2)
727 least-negative-double-float
)))
729 (with-test (:name
:ldb-sign
)
730 (assert (= (funcall (compile nil
732 (ldb (byte ,(1- sb-vm
:n-word-bits
) 0) x
)))