tests/arith.pure.lisp

   1 ;;;; arithmetic tests with no side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  14 (cl:in-package :cl-user)
  15
  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)
  22                `(progn
  23                   (assert (= (,op 4 2) ,res1))
  24                   (assert (= (,op 2 4) ,res2))
  25                   (assert (= (funcall (checked-compile '(lambda (x y) (,op x y)))
  26                                       4 2)
  27                              ,res1))
  28                   (assert (= (funcall (checked-compile '(lambda (x y) (,op x y)))
  29                                       2 4)
  30                              ,res2)))))
  31     (test + 6 6)
  32     (test - 2 -2)
  33     (test * 8 8)
  34     (test / 2 1/2)
  35     (test expt 16 16)))
  36
  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))
  44                 division-by-zero))
  45
  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))
  50                 division-by-zero))
  51
  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)))
  58
  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)))
  62
  63 ;;; COERCE also sometimes failed to verify that a particular coercion
  64 ;;; was possible (in particular coercing rationals to bounded float
  65 ;;; types.
  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))
  70                 type-error)
  71   (assert-error (funcall (checked-compile
  72                           `(lambda () (coerce 1 '(single-float -1.0 0.0)))
  73                           :allow-style-warnings t))
  74                 type-error)
  75   (assert (eql (coerce 1 '(single-float -1.0 2.0)) 1.0)))
  76
  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
  90                                 (checked-compile
  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)))
 105
 106 (with-test (:name :numeric-inequality-&rest-arguments)
 107   (dolist (f '(= < <= > >=))
 108     ;; 1 arg
 109     (assert-error (funcall f 'feep) type-error)
 110     (unless (eq f '=)
 111       ;; = accepts complex numbers
 112       (assert-error (funcall f #c(0s0 1s0)) type-error))
 113     ;; 2 arg
 114     (assert-error (funcall f 3 'feep) type-error)
 115     (assert-error (funcall f 'feep 3) type-error)
 116     ;; 3 arg
 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)
 120     ;; 4 arg
 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)))
 125
 126 ;;; (CEILING x 2^k) was optimized incorrectly
 127 (loop for divisor in '(-4 4)
 128       for ceiler = (compile nil `(lambda (x)
 129                                    (declare (fixnum 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)
 135                       (funcall ceiler i)
 136                     (assert (= (+ (* q divisor) r) i))
 137                     (assert (<= exact-q q))
 138                     (assert (< q (1+ exact-q))))))
 139
 140 ;;; (TRUNCATE x 2^k) was optimized incorrectly
 141 (loop for divisor in '(-4 4)
 142       for truncater = (compile nil `(lambda (x)
 143                                       (declare (fixnum 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)))))))
 153
 154 ;;; CEILING had a corner case, spotted by Paul Dietz
 155 (assert (= (ceiling most-negative-fixnum (1+ most-positive-fixnum)) -1))
 156
 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))
 162   (dotimes (i 100)
 163     (let* ((x (random most-positive-fixnum))
 164            (x2 (* x 2))
 165            (x3 (* x 3))
 166            (fn (checked-compile
 167                 `(lambda (y)
 168                    (declare (optimize speed) (type (integer 0 3) y))
 169                    (* y ,x))
 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)))))
 175
 176 ;;; Bugs reported by Paul Dietz:
 177
 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))
 184
 185 ;;; PPC bignum arithmetic bug:
 186 (multiple-value-bind (quo rem)
 187     (truncate 291351647815394962053040658028983955 10000000000000000000000000)
 188   (assert (= quo 29135164781))
 189   (assert (= rem 5394962053040658028983955)))
 190
 191 ;;; x86 LEA bug:
 192 (assert (= (funcall
 193             (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000)))
 194             1)
 195            #xf0000001))
 196
 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))))
 210
 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)))
 218
 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)))
 226
 227 ;;; Alpha bignum arithmetic bug:
 228 (assert (= (* 966082078641 419216044685) 404997107848943140073085))
 229
 230 ;;; Alpha smallnum arithmetic bug:
 231 (assert (= (ash -129876 -1026) -1))
 232
 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
 237              `(lambda (a b c d)
 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)
 242                          (ignorable a b c d)
 243                          (optimize (speed 3) (safety 1) (debug 1)))
 244                 (truncate c (min -100 4149605))))))
 245     (assert (= (funcall fn -1332 5864 -6963328729 -43789079) 69633287))))
 246
 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)
 255                                          (ignorable a b c d)
 256                                          (optimize (speed 3) (safety 1) (debug 1)))
 257                                 (case a
 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))))
 261
 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))
 265
 266 ;;; Whoops.  Too much optimization in division operators for 0
 267 ;;; divisor.
 268 (with-test (:name (mod truncate rem / floor ceiling :division-by-zero fixnum))
 269   (flet ((frob (name)
 270            (let ((fn (checked-compile
 271                       `(lambda (x)
 272                          (declare (optimize speed) (fixnum x))
 273                          (,name x 0)))))
 274              (assert-error (funcall fn 1) division-by-zero))))
 275     (mapc #'frob '(mod truncate rem / floor ceiling))))
 276
 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)
 281              `(let (ints
 282                     floats
 283                     (start (- ,(find-symbol (format nil
 284                                                     "MOST-~A-EXACTLY-~A-FIXNUM"
 285                                                     sign type)
 286                                             :sb-kernel)
 287                               ,range)))
 288                 (dotimes (i (1+ (* ,range 2)))
 289                   (let* ((x (+ start i))
 290                          (y (coerce x ',type)))
 291                     (push x ints)
 292                     (push y floats)))
 293                 (dolist (i ints)
 294                   (dolist (f floats)
 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)))~%"
 299                                op i f
 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)))~%"
 304                                op f i
 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))
 310
 311 ;; x86-64 sign-extension bug found using pfdietz's random tester.
 312 (assert (= 286142502
 313            (funcall (lambda ()
 314                       (declare (notinline logxor))
 315                       (min (logxor 0 0 0 286142502))))))
 316
 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)
 320   (flet ((test (x n)
 321            (unless (= (logcount x) n)
 322              (error "logcount failure for ~a" x))))
 323     ;; Test with some patterns with well known number of ones/zeroes ...
 324     (dotimes (i 128)
 325       (let ((x (ash 1 i)))
 326         (test x 1)
 327         (test (- x) i)
 328         (test (1- x) i)))
 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))
 333                   (x (if (minusp x)
 334                          (lognot x)
 335                          x)
 336                      (logand x (1- x))))
 337                  ((zerop x) result))))
 338       (dotimes (i 200)
 339         (let ((x (random (ash 1 i))))
 340           (test x (test-logcount x))
 341           (test (- x) (test-logcount (- x))))))))
 342
 343 ;; 1.0 had a broken ATANH on win32
 344 (with-test (:name :atanh)
 345   (assert (= (atanh 0.9d0) 1.4722194895832204d0)))
 346
 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)))
 351                (dolist (form forms)
 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)
 358                                             (ignorable x y z)
 359                                             (notinline identity)
 360                                             (optimize speed (safety 0))))
 361                          `((,op x ,y))
 362                          `((setf z (,op x ,y))
 363                            (identity x)
 364                            z)
 365                          `((values (,op x ,y) x))
 366                          `((,op ,x y))
 367                          `((setf z (,op ,x y))
 368                            (identity y)
 369                            z)
 370                          `((values (,op ,x y) y))
 371
 372                          `((identity x)
 373                            (,op x ,y))
 374                          `((identity x)
 375                            (setf z (,op x ,y))
 376                            (identity x)
 377                            z)
 378                          `((identity x)
 379                            (values (,op x ,y) x))
 380                          `((identity y)
 381                            (,op ,x y))
 382                          `((identity y)
 383                            (setf z (,op ,x y))
 384                            (identity y)
 385                            z)
 386                          `((identity y)
 387                            (values (,op ,x y) y))))
 388            (test-op (op)
 389              (let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
 390                    (sb `(signed-byte ,sb-vm:n-word-bits)))
 391                (loop for (x y type)
 392                      in `((2 1 fixnum)
 393                           (2 1 ,ub)
 394                           (2 1 ,sb)
 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)))
 411                                  fixnum))))
 412                      do
 413                   (test-case op x y type)
 414                   (test-case op x x type)))))
 415     (mapc #'test-op '(+ - * truncate
 416                       < <= = >= >
 417                       eql
 418                       eq))))
 419
 420 ;; GCD used to sometimes return negative values. The following did, on 32 bit
 421 ;; builds.
 422 (with-test (:name :gcd)
 423   ;; from lp#413680
 424   (assert (plusp (gcd 20286123923750474264166990598656
 425                       680564733841876926926749214863536422912)))
 426   ;; from lp#516750
 427   (assert (plusp (gcd 2596102012663483082521318626691873
 428                       2596148429267413814265248164610048))))
 429
 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)))
 440
 441 (with-test (:name :multiple-constant-folding)
 442   (let ((*random-state* (make-random-state t)))
 443     (flet ((make-args ()
 444              (let (args vars)
 445                (loop repeat (1+ (random 12))
 446                      do (if (zerop (random 2))
 447                             (let ((var (gensym)))
 448                               (push var args)
 449                               (push var vars))
 450                             (push (- (random 21) 10) args)))
 451                (values args vars))))
 452       (dolist (op '(+ * logior logxor logand logeqv gcd lcm - /))
 453         (loop repeat 10
 454               do (multiple-value-bind (args vars) (make-args)
 455                    (let ((fast (checked-compile
 456                                 `(lambda ,vars
 457                                    (,op ,@args))
 458                                 :allow-style-warnings (eq op '/)))
 459                          (slow (checked-compile
 460                                 `(lambda ,vars
 461                                    (declare (notinline ,op))
 462                                    (,op ,@args))
 463                                 :allow-style-warnings (eq op '/))))
 464                      (loop repeat 3
 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)))))))))))
 476
 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
 485                  `(lambda (x)
 486                     (declare (optimize (speed 3)
 487                                        (space 1)
 488                                        (compilation-speed 0))
 489                              (type (unsigned-byte ,sb-vm:n-word-bits) x))
 490                     (,fun x 9))))
 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))))))
 497
 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
 504                          7 10 14 641 274177
 505                          ;; Range extremes
 506                          3
 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))))
 514                                  collect r)))
 515         (dolist (fun '(truncate ceiling floor mod rem))
 516           (let ((foo (checked-compile
 517                       `(lambda (x)
 518                          (declare (optimize (speed 3)
 519                                             (space 1)
 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)
 526                                 ,@(loop repeat 4
 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))
 531                                         collect r)))
 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)
 538                                  (eql r1 r2))
 539                       (error "bad results for ~s with dividend type ~s"
 540                              (list fun dividend divisor)
 541                              dividend-type))))))))))))
 542
 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))))
 548
 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
 553                    3/5               ; ratio
 554                    1.2f0             ; single-float
 555                    2.0d0             ; double-float
 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
 559         (bignum (expt 2 64))
 560         results)
 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))))
 568
 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
 581                                              ; are OK.
 582            (test-complex (x y)
 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)))
 588     (let ((n-broken 0))
 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)
 595                  (unless result
 596                    (incf n-broken)))))
 597         (dolist (base (list 2                    ; fixnum
 598                             (expt 2 64)          ; bignum
 599                             3/5                  ; ratio
 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))
 606                                                  ; complex bignum
 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)))))
 611       (when (> n-broken 0)
 612         (error "Number of broken combinations: ~a" n-broken)))))
 613
 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))))))
 620
 621 ;; The ISQRT implementation is sufficiently complicated that it should
 622 ;; be tested.
 623 (with-test (:name :isqrt)
 624   (labels ((test (x)
 625              (let* ((r (isqrt x))
 626                     (r2 (expt r 2))
 627                     (s2 (expt (1+ r) 2)))
 628                (unless (and (<= r2 x)
 629                             (> s2 x))
 630                  (error "isqrt failure for ~a" x))))
 631            (tests (x)
 632              (test x)
 633              (let ((x2 (expt x 2)))
 634                (test x2)
 635                (test (1+ x2))
 636                (test (1- x2)))))
 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))
 642           do
 643           (tests i)
 644           (tests j))
 645     (dotimes (i 10)
 646       (tests (random (expt 2 (+ 1000 (random 10000))))))))
 647
 648 ;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
 649 (with-test (:name :recursive-cut-to-width)
 650   (assert (eql (funcall
 651                 (checked-compile
 652                  `(lambda (x)
 653                     (declare (optimize (space 3))
 654                              (type (integer 12417236377505266230
 655                                             12417274239874990070)
 656                                    x))
 657                     (logand 8459622733968096971 x)))
 658                 12417237222845306758)
 659                2612793697039849090)))
 660
 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
 664                 (checked-compile
 665                  `(lambda (a b)
 666                     (declare (optimize (speed 2) (safety 0)))
 667                     (logand (the (eql 16779072918521075607) a)
 668                             (the (integer 21371810342718833225 21371810343571293860) b))))
 669                 16779072918521075607 21371810342718833263)
 670                2923729245085762055)))
 671
 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))
 678                                      (logand x ,k)))))
 679           (loop for x from min upto max do
 680             (assert (eql (logand x k) (funcall f x)))))))))
 681
 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))
 688                                      (logior x ,k)))))
 689           (loop for x from min upto max do
 690             (assert (eql (logior x k) (funcall f x)))))))))
 691
 692 (with-test (:name :ldb-negative-index-no-error)
 693   (assert-error
 694    (funcall (checked-compile `(lambda (x y)
 695                                 (ldb (byte x y) 100)))
 696             -1 -2))
 697   (assert-error
 698    (funcall (checked-compile `(lambda (x y)
 699                                 (mask-field (byte x y) 100)))
 700             -1 -2))
 701   (assert-error
 702    (funcall (checked-compile `(lambda (x y)
 703                                 (dpb 0 (byte x y) 100)))
 704             -1 -2))
 705   (assert-error
 706    (funcall (checked-compile `(lambda (x y)
 707                                 (deposit-field 0 (byte x y) 100)))
 708             -1 -2)))
 709
 710 (with-test (:name :setf-mask-field)
 711   (assert (= (funcall
 712               (checked-compile `(lambda (a)
 713                                   (setf (mask-field (byte 2 0) a) 1) a))
 714               15))))
 715
 716 (with-test (:name :complex-multiply)
 717   (assert (= (funcall
 718               (checked-compile
 719                `(lambda ()
 720                   (declare (optimize speed))
 721                   (let (z)
 722                     (expt (setf z (complex -0.123 -0.789)) 2)))))
 723              #C(-0.60739195 0.194094))))
 724
 725 (with-test (:name :complex-sqrt)
 726   (assert (= (expt (sqrt least-negative-double-float) 2)
 727              least-negative-double-float)))
 728
 729 (with-test (:name :ldb-sign)
 730   (assert (= (funcall (checked-compile
 731                        `(lambda (x)
 732                           (ldb (byte ,(1- sb-vm:n-word-bits) 0) x)))
 733                       12)
 734              12)))
 735
 736 (with-test (:name :mod-arith-large-constant)
 737   (assert (= (funcall (checked-compile
 738                        '(lambda (x)
 739                          (declare ((unsigned-byte 64) x))
 740                          (logand sb-ext:most-positive-word
 741                           (+ x 23124234234))))
 742                       12)
 743              23124234246)))