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 (macrolet ((test (op res1 res2)
  21              `(progn
  22                (assert (= (,op 4 2) ,res1))
  23                (assert (= (,op 2 4) ,res2))
  24                (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 4 2)
  25                         ,res1))
  26                (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 2 4)
  27                         ,res2)))))
  28   (test + 6 6)
  29   (test - 2 -2)
  30   (test * 8 8)
  31   (test / 2 1/2)
  32   (test expt 16 16))
  33
  34 ;;; In a bug reported by Wolfhard Buss on cmucl-imp 2002-06-18 (BUG
  35 ;;; 184), sbcl didn't catch all divisions by zero, notably divisions
  36 ;;; of bignums and ratios by 0.  Fixed in sbcl-0.7.6.13.
  37 (assert-error (/ 2/3 0) division-by-zero)
  38 (assert-error (/ (1+ most-positive-fixnum) 0) division-by-zero)
  39
  40 ;;; In a bug reported by Raymond Toy on cmucl-imp 2002-07-18, (COERCE
  41 ;;; <RATIONAL> '(COMPLEX FLOAT)) was failing to return a complex
  42 ;;; float; a patch was given by Wolfhard Buss cmucl-imp 2002-07-19.
  43 (assert (= (coerce 1 '(complex float)) #c(1.0 0.0)))
  44 (assert (= (coerce 1/2 '(complex float)) #c(0.5 0.0)))
  45 (assert (= (coerce 1.0d0 '(complex float)) #c(1.0d0 0.0d0)))
  46
  47 ;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
  48 ;;; an error up to 0.8.17.31
  49 (assert (= (coerce #c(1 2) '(complex float)) #c(1.0 2.0)))
  50
  51 ;;; COERCE also sometimes failed to verify that a particular coercion
  52 ;;; was possible (in particular coercing rationals to bounded float
  53 ;;; types.
  54 (assert-error (coerce 1 '(float 2.0 3.0)) type-error)
  55 (assert-error (coerce 1 '(single-float -1.0 0.0)) type-error)
  56 (assert (eql (coerce 1 '(single-float -1.0 2.0)) 1.0))
  57
  58 ;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
  59 ;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
  60 ;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
  61 (assert (null (ignore-errors (min '(1 2 3)))))
  62 (assert (= (min -1) -1))
  63 (assert (null (ignore-errors (min 1 #(1 2 3)))))
  64 (assert (= (min 10 11) 10))
  65 (assert (null (ignore-errors (min (find-package "CL") -5.0))))
  66 (assert (= (min 5.0 -3) -3))
  67 (assert (null (ignore-errors (max #c(4 3)))))
  68 (assert (= (max 0) 0))
  69 (assert (null (ignore-errors (max "MIX" 3))))
  70 (assert (= (max -1 10.0) 10.0))
  71 (assert (null (ignore-errors (max 3 #'max))))
  72 (assert (= (max -3 0) 0))
  73
  74 (with-test (:name :numeric-inequality-&rest-arguments)
  75   (dolist (f '(= < <= > >=))
  76     ;; 1 arg
  77     (assert-error (funcall f 'feep) type-error)
  78     (unless (eq f '=)
  79       ;; = accepts complex numbers
  80       (assert-error (funcall f #c(0s0 1s0)) type-error))
  81     ;; 2 arg
  82     (assert-error (funcall f 3 'feep) type-error)
  83     (assert-error (funcall f 'feep 3) type-error)
  84     ;; 3 arg
  85     (assert-error (funcall f 0 0 'feep) type-error)
  86     (assert-error (funcall f 0 1 'feep) type-error)
  87     (assert-error (funcall f 1 0 'feep) type-error)
  88     ;; 4 arg
  89     (assert-error (funcall f 0 0 0 'feep) type-error))
  90   ;; Also MIN,MAX operate only on REAL
  91   (dolist (f '(min max))
  92     (assert-error (funcall f #c(1s0 -2s0)) type-error)))
  93
  94 ;;; (CEILING x 2^k) was optimized incorrectly
  95 (loop for divisor in '(-4 4)
  96       for ceiler = (compile nil `(lambda (x)
  97                                    (declare (fixnum x))
  98                                    (declare (optimize (speed 3)))
  99                                    (ceiling x ,divisor)))
 100       do (loop for i from -5 to 5
 101                for exact-q = (/ i divisor)
 102                do (multiple-value-bind (q r)
 103                       (funcall ceiler i)
 104                     (assert (= (+ (* q divisor) r) i))
 105                     (assert (<= exact-q q))
 106                     (assert (< q (1+ exact-q))))))
 107
 108 ;;; (TRUNCATE x 2^k) was optimized incorrectly
 109 (loop for divisor in '(-4 4)
 110       for truncater = (compile nil `(lambda (x)
 111                                       (declare (fixnum x))
 112                                       (declare (optimize (speed 3)))
 113                                       (truncate x ,divisor)))
 114       do (loop for i from -9 to 9
 115                for exact-q = (/ i divisor)
 116                do (multiple-value-bind (q r)
 117                       (funcall truncater i)
 118                     (assert (= (+ (* q divisor) r) i))
 119                     (assert (<= (abs q) (abs exact-q)))
 120                     (assert (< (abs exact-q) (1+ (abs q)))))))
 121
 122 ;;; CEILING had a corner case, spotted by Paul Dietz
 123 (assert (= (ceiling most-negative-fixnum (1+ most-positive-fixnum)) -1))
 124
 125 ;;; give any optimizers of constant multiplication a light testing.
 126 ;;; 100 may seem low, but (a) it caught CSR's initial errors, and (b)
 127 ;;; before checking in, CSR tested with 10000.  So one hundred
 128 ;;; checkins later, we'll have doubled the coverage.
 129 (dotimes (i 100)
 130   (let* ((x (random most-positive-fixnum))
 131          (x2 (* x 2))
 132          (x3 (* x 3)))
 133     (let ((fn (handler-bind ((sb-ext:compiler-note
 134                               (lambda (c)
 135                                 (when (<= x3 most-positive-fixnum)
 136                                   (error c)))))
 137                 (compile nil
 138                          `(lambda (y)
 139                             (declare (optimize speed) (type (integer 0 3) y))
 140                             (* y ,x))))))
 141       (unless (and (= (funcall fn 0) 0)
 142                    (= (funcall fn 1) x)
 143                    (= (funcall fn 2) x2)
 144                    (= (funcall fn 3) x3))
 145         (error "bad results for ~D" x)))))
 146
 147 ;;; Bugs reported by Paul Dietz:
 148
 149 ;;; (GCD 0 x) must return (abs x)
 150 (dolist (x (list -10 (* 3 most-negative-fixnum)))
 151   (assert (= (gcd 0 x) (abs x))))
 152 ;;; LCM returns a non-negative number
 153 (assert (= (lcm 4 -10) 20))
 154 (assert (= (lcm 0 0) 0))
 155
 156 ;;; PPC bignum arithmetic bug:
 157 (multiple-value-bind (quo rem)
 158     (truncate 291351647815394962053040658028983955 10000000000000000000000000)
 159   (assert (= quo 29135164781))
 160   (assert (= rem 5394962053040658028983955)))
 161
 162 ;;; x86 LEA bug:
 163 (assert (= (funcall
 164             (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000)))
 165             1)
 166            #xf0000001))
 167
 168 ;;; LOGBITP on bignums:
 169 (dolist (x '(((1+ most-positive-fixnum) 1 nil)
 170              ((1+ most-positive-fixnum) -1 t)
 171              ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
 172              ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
 173              (1 (ash most-negative-fixnum 1) nil)
 174              (#.(- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1) most-negative-fixnum t)
 175              (#.(1+ (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1)) (ash most-negative-fixnum 1) t)
 176              (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits 1)) (ash most-negative-fixnum 1) t)
 177              (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-fixnum-tag-bits 2)) nil)
 178              (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-fixnum-tag-bits 2)) t)))
 179   (destructuring-bind (index int result) x
 180     (assert (eq (eval `(logbitp ,index ,int)) result))))
 181
 182 ;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD:
 183 (let ((f (compile nil '(lambda (b)
 184                         (integer-length (dpb b (byte 4 28) -1005))))))
 185   (assert (= (funcall f 1230070) 32)))
 186 (let ((f (compile nil '(lambda (b)
 187                         (integer-length (deposit-field b (byte 4 28) -1005))))))
 188   (assert (= (funcall f 1230070) 32)))
 189
 190 ;;; type inference leading to an internal compiler error:
 191 (let ((f (compile nil '(lambda (x)
 192                         (declare (type fixnum x))
 193                         (ldb (byte 0 0) x)))))
 194   (assert (= (funcall f 1) 0))
 195   (assert (= (funcall f most-positive-fixnum) 0))
 196   (assert (= (funcall f -1) 0)))
 197
 198 ;;; Alpha bignum arithmetic bug:
 199 (assert (= (* 966082078641 419216044685) 404997107848943140073085))
 200
 201 ;;; Alpha smallnum arithmetic bug:
 202 (assert (= (ash -129876 -1026) -1))
 203
 204 ;;; Alpha middlenum (yes, really! Affecting numbers between 2^32 and
 205 ;;; 2^64 :) arithmetic bug
 206 (let ((fn (compile nil '(LAMBDA (A B C D)
 207           (DECLARE (TYPE (INTEGER -1621 -513) A)
 208                    (TYPE (INTEGER -3 34163) B)
 209                    (TYPE (INTEGER -9485132993 81272960) C)
 210                    (TYPE (INTEGER -255340814 519943) D)
 211                    (IGNORABLE A B C D)
 212                    (OPTIMIZE (SPEED 3) (SAFETY 1) (DEBUG 1)))
 213           (TRUNCATE C (MIN -100 4149605))))))
 214   (assert (= (funcall fn -1332 5864 -6963328729 -43789079) 69633287)))
 215
 216 ;;; Here's another fantastic Alpha backend bug: the code to load
 217 ;;; immediate 64-bit constants into a register was wrong.
 218 (let ((fn (compile nil '(LAMBDA (A B C D)
 219           (DECLARE (TYPE (INTEGER -3563 2733564) A)
 220                    (TYPE (INTEGER -548947 7159) B)
 221                    (TYPE (INTEGER -19 0) C)
 222                    (TYPE (INTEGER -2546009 0) D)
 223                    (IGNORABLE A B C D)
 224                    (OPTIMIZE (SPEED 3) (SAFETY 1) (DEBUG 1)))
 225           (CASE A
 226             ((89 125 16) (ASH A (MIN 18 -706)))
 227             (T (DPB -3 (BYTE 30 30) -1)))))))
 228   (assert (= (funcall fn 1227072 -529823 -18 -792831) -2147483649)))
 229
 230 ;;; ASH of a negative bignum by a bignum count would erroneously
 231 ;;; return 0 prior to sbcl-0.8.4.4
 232 (assert (= (ash (1- most-negative-fixnum) (1- most-negative-fixnum)) -1))
 233
 234 ;;; Whoops.  Too much optimization in division operators for 0
 235 ;;; divisor.
 236 (macrolet ((frob (name)
 237              `(let ((fn (compile nil '(lambda (x)
 238                                        (declare (optimize speed) (fixnum x))
 239                                        (,name x 0)))))
 240                 (assert-error (funcall fn 1) division-by-zero))))
 241   (frob mod)
 242   (frob truncate)
 243   (frob rem)
 244   (frob /)
 245   (frob floor)
 246   (frob ceiling))
 247
 248 ;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
 249 ;; comparisons without rationalizing the floats still gives the right anwers
 250 ;; in the edge cases (had a fencepost error).
 251 (macrolet ((test (range type sign)
 252              `(let (ints
 253                     floats
 254                     (start (- ,(find-symbol (format nil
 255                                                     "MOST-~A-EXACTLY-~A-FIXNUM"
 256                                                     sign type)
 257                                             :sb-kernel)
 258                               ,range)))
 259                 (dotimes (i (1+ (* ,range 2)))
 260                   (let* ((x (+ start i))
 261                          (y (coerce x ',type)))
 262                     (push x ints)
 263                     (push y floats)))
 264                 (dolist (i ints)
 265                   (dolist (f floats)
 266                     (dolist (op '(< <= = >= >))
 267                       (unless (eq (funcall op i f)
 268                                   (funcall op i (rationalize f)))
 269                         (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
 270                                op i f
 271                                op i (rationalize f)))
 272                       (unless (eq (funcall op f i)
 273                                   (funcall op (rationalize f) i))
 274                         (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
 275                                op f i
 276                                op (rationalize f) i))))))))
 277   (test 32 double-float negative)
 278   (test 32 double-float positive)
 279   (test 32 single-float negative)
 280   (test 32 single-float positive))
 281
 282 ;; x86-64 sign-extension bug found using pfdietz's random tester.
 283 (assert (= 286142502
 284            (funcall (lambda ()
 285                       (declare (notinline logxor))
 286                       (min (logxor 0 0 0 286142502))))))
 287
 288 ;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
 289 ;; unnoticed, so check more thoroughly here.
 290 (with-test (:name :logcount)
 291   (flet ((test (x n)
 292            (unless (= (logcount x) n)
 293              (error "logcount failure for ~a" x))))
 294     ;; Test with some patterns with well known number of ones/zeroes ...
 295     (dotimes (i 128)
 296       (let ((x (ash 1 i)))
 297         (test x 1)
 298         (test (- x) i)
 299         (test (1- x) i)))
 300     ;; ... and with some random integers of varying length.
 301     (flet ((test-logcount (x)
 302              (declare (type integer x))
 303              (do ((result 0 (1+ result))
 304                   (x (if (minusp x)
 305                          (lognot x)
 306                          x)
 307                      (logand x (1- x))))
 308                  ((zerop x) result))))
 309       (dotimes (i 200)
 310         (let ((x (random (ash 1 i))))
 311           (test x (test-logcount x))
 312           (test (- x) (test-logcount (- x))))))))
 313
 314 ;; 1.0 had a broken ATANH on win32
 315 (with-test (:name :atanh)
 316   (assert (= (atanh 0.9d0) 1.4722194895832204d0)))
 317
 318 ;; Test some cases of integer operations with constant arguments
 319 (with-test (:name :constant-integers)
 320   (labels ((test-forms (op x y header &rest forms)
 321              (let ((val (funcall op x y)))
 322                (dolist (form forms)
 323                  (let ((new-val (funcall (compile nil (append header form)) x y)))
 324                    (unless (eql val new-val)
 325                      (error "~S /= ~S: ~S ~S ~S~%" val new-val (append header form) x y))))))
 326            (test-case (op x y type)
 327              (test-forms op x y `(lambda (x y &aux z)
 328                                    (declare (type ,type x y)
 329                                             (ignorable x y z)
 330                                             (notinline identity)
 331                                             (optimize speed (safety 0))))
 332                          `((,op x ,y))
 333                          `((setf z (,op x ,y))
 334                            (identity x)
 335                            z)
 336                          `((values (,op x ,y) x))
 337                          `((,op ,x y))
 338                          `((setf z (,op ,x y))
 339                            (identity y)
 340                            z)
 341                          `((values (,op ,x y) y))
 342
 343                          `((identity x)
 344                            (,op x ,y))
 345                          `((identity x)
 346                            (setf z (,op x ,y))
 347                            (identity x)
 348                            z)
 349                          `((identity x)
 350                            (values (,op x ,y) x))
 351                          `((identity y)
 352                            (,op ,x y))
 353                          `((identity y)
 354                            (setf z (,op ,x y))
 355                            (identity y)
 356                            z)
 357                          `((identity y)
 358                            (values (,op ,x y) y))))
 359            (test-op (op)
 360              (let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
 361                    (sb `(signed-byte ,sb-vm:n-word-bits)))
 362                (loop for (x y type)
 363                      in `((2 1 fixnum)
 364                           (2 1 ,ub)
 365                           (2 1 ,sb)
 366                           (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
 367                           (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
 368                           (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
 369                           ,@(when (> sb-vm:n-word-bits 32)
 370                               `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
 371                                 (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
 372                                 (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
 373                                 (,(ash 1 40) ,(ash 1 39) fixnum)
 374                                 (,(ash 1 40) ,(ash 1 39) ,ub)
 375                                 (,(ash 1 40) ,(ash 1 39) ,sb)))
 376                           ;; fixnums that can be represented as 32-bit
 377                           ;; sign-extended immediates on x86-64
 378                           ,@(when (and (> sb-vm:n-word-bits 32)
 379                                        (< sb-vm:n-fixnum-tag-bits 3))
 380                               `((,(1+ (ash 1 (- 31 sb-vm:n-fixnum-tag-bits)))
 381                                  ,(1- (ash 1 (- 32 sb-vm:n-fixnum-tag-bits)))
 382                                  fixnum))))
 383                      do
 384                   (test-case op x y type)
 385                   (test-case op x x type)))))
 386     (mapc #'test-op '(+ - * truncate
 387                       < <= = >= >
 388                       eql
 389                       eq))))
 390
 391 ;; GCD used to sometimes return negative values. The following did, on 32 bit
 392 ;; builds.
 393 (with-test (:name :gcd)
 394   ;; from lp#413680
 395   (assert (plusp (gcd 20286123923750474264166990598656
 396                       680564733841876926926749214863536422912)))
 397   ;; from lp#516750
 398   (assert (plusp (gcd 2596102012663483082521318626691873
 399                       2596148429267413814265248164610048))))
 400
 401 (with-test (:name :expt-zero-zero)
 402   ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but (expt 0.0 0)
 403   ;; returns 1.0
 404   (assert-error (expt 0.0 0.0) sb-int:arguments-out-of-domain-error)
 405   (assert-error (expt 0 0.0) sb-int:arguments-out-of-domain-error)
 406   (assert (eql (expt 0.0 0) 1.0)))
 407
 408 (with-test (:name :multiple-constant-folding)
 409   (let ((*random-state* (make-random-state t)))
 410     (flet ((make-args ()
 411              (let (args vars)
 412                (loop repeat (1+ (random 12))
 413                      do (if (zerop (random 2))
 414                             (let ((var (gensym)))
 415                               (push var args)
 416                               (push var vars))
 417                             (push (- (random 21) 10) args)))
 418                (values args vars))))
 419       (dolist (op '(+ * logior logxor logand logeqv gcd lcm - /))
 420         (loop repeat 10
 421               do (multiple-value-bind (args vars) (make-args)
 422                    (let ((fast (compile nil `(lambda ,vars
 423                                                (,op ,@args))))
 424                          (slow (compile nil `(lambda ,vars
 425                                                (declare (notinline ,op))
 426                                                (,op ,@args)))))
 427                      (loop repeat 3
 428                            do (let* ((call-args (loop repeat (length vars)
 429                                                       collect (- (random 21) 10)))
 430                                      (fast-result (handler-case
 431                                                       (apply fast call-args)
 432                                                     (division-by-zero () :div0)))
 433                                      (slow-result (handler-case
 434                                                       (apply slow call-args)
 435                                                     (division-by-zero () :div0))))
 436                                 (if (eql fast-result slow-result)
 437                                     (print (list :ok `(,op ,@args) :=> fast-result))
 438                                     (error "oops: ~S, ~S" args call-args)))))))))))
 439
 440 ;;; (TRUNCATE <unsigned-word> <constant unsigned-word>) is optimized
 441 ;;; to use multiplication instead of division. This propagates to FLOOR,
 442 ;;; MOD and REM. Test that the transform is indeed triggered and test
 443 ;;; several cases for correct results.
 444 (with-test (:name (:integer-division-using-multiplication :used)
 445                   :skipped-on '(not (or :x86-64 :x86)))
 446   (dolist (fun '(truncate floor ceiling mod rem))
 447     (let* ((foo (compile nil `(lambda (x)
 448                                 (declare (optimize (speed 3)
 449                                                    (space 1)
 450                                                    (compilation-speed 0))
 451                                          (type (unsigned-byte
 452                                                 ,sb-vm:n-word-bits) x))
 453                                 (,fun x 9))))
 454            (disassembly (with-output-to-string (s)
 455                           (disassemble foo :stream s))))
 456       ;; KLUDGE copied from test :float-division-using-exact-reciprocal
 457       ;; in compiler.pure.lisp.
 458       (assert (and (not (search "DIV" disassembly))
 459                    (search "MUL" disassembly))))))
 460
 461 (with-test (:name (:integer-division-using-multiplication :correctness))
 462   (let ((*random-state* (make-random-state t)))
 463     (dolist (dividend-type `((unsigned-byte ,sb-vm:n-word-bits)
 464                              (and fixnum unsigned-byte)
 465                              (integer 10000 10100)))
 466       (dolist (divisor `(;; Some special cases from the paper
 467                          7 10 14 641 274177
 468                          ;; Range extremes
 469                          3
 470                          ,most-positive-fixnum
 471                          ,(1- (expt 2 sb-vm:n-word-bits))
 472                          ;; Some random values
 473                          ,@(loop for i from 8 to sb-vm:n-word-bits
 474                                  for r = (random (expt 2 i))
 475                                  ;; We don't want 0, 1 and powers of 2.
 476                                  when (not (zerop (logand r (1- r))))
 477                                  collect r)))
 478         (dolist (fun '(truncate ceiling floor mod rem))
 479           (let ((foo (compile nil `(lambda (x)
 480                                      (declare (optimize (speed 3)
 481                                                         (space 1)
 482                                                         (compilation-speed 0))
 483                                               (type ,dividend-type x))
 484                                      (,fun x ,divisor)))))
 485             (dolist (dividend `(0 1 ,most-positive-fixnum
 486                                 ,(1- divisor) ,divisor
 487                                 ,(1- (* divisor 2)) ,(* divisor 2)
 488                                 ,@(loop repeat 4
 489                                         collect (+ 10000 (random 101)))
 490                                 ,@(loop for i from 4 to sb-vm:n-word-bits
 491                                         for pow = (expt 2 (1- i))
 492                                         for r = (+ pow (random pow))
 493                                         collect r)))
 494               (when (typep dividend dividend-type)
 495                 (multiple-value-bind (q1 r1)
 496                     (funcall foo dividend)
 497                   (multiple-value-bind (q2 r2)
 498                       (funcall fun dividend divisor)
 499                     (unless (and (= q1 q2)
 500                                  (eql r1 r2))
 501                       (error "bad results for ~s with dividend type ~s"
 502                              (list fun dividend divisor)
 503                              dividend-type))))))))))))
 504
 505 ;; The fast path for logbitp underestimated sb!vm:n-positive-fixnum-bits
 506 ;; for > 61 bit fixnums.
 507 (with-test (:name :logbitp-wide-fixnum)
 508   (assert (not (logbitp (1- (integer-length most-positive-fixnum))
 509                         most-negative-fixnum))))
 510
 511 ;; EXPT dispatches in a complicated way on the types of its arguments.
 512 ;; Check that all possible combinations are covered.
 513 (with-test (:name (:expt :argument-type-combinations))
 514   (let ((numbers '(2                 ; fixnum
 515                    3/5               ; ratio
 516                    1.2f0             ; single-float
 517                    2.0d0             ; double-float
 518                    #c(3/5 1/7)       ; complex rational
 519                    #c(1.2f0 1.3f0)   ; complex single-float
 520                    #c(2.0d0 3.0d0))) ; complex double-float
 521         (bignum (expt 2 64))
 522         results)
 523     (dolist (base (cons bignum numbers))
 524       (dolist (power numbers)
 525         (format t "(expt ~s ~s) => " base power)
 526         (let ((result (expt base power)))
 527           (format t "~s~%" result)
 528           (push result results))))
 529     (assert (every #'numberp results))))
 530
 531 (with-test (:name :bug-741564)
 532   ;; The bug was that in (expt <fixnum> <(complex double-float)>) the
 533   ;; calculation was partially done only to single-float precision,
 534   ;; making the complex double-float result too unprecise. Some other
 535   ;; combinations of argument types were affected, too; test that all
 536   ;; of them are good to double-float precision.
 537   (labels ((nearly-equal-p (x y)
 538              "Are the arguments equal to nearly double-float precision?"
 539              (declare (type double-float x y))
 540              (< (/ (abs (- x y)) (abs y))
 541                 (* double-float-epsilon 4))) ; Differences in the two least
 542                                              ; significant mantissa bits
 543                                              ; are OK.
 544            (test-complex (x y)
 545              (and (nearly-equal-p (realpart x) (realpart y))
 546                   (nearly-equal-p (imagpart x) (imagpart y))))
 547            (print-result (msg base power got expected)
 548              (format t "~a (expt ~s ~s)~%got      ~s~%expected ~s~%"
 549                      msg base power got expected)))
 550     (let ((n-broken 0))
 551       (flet ((test (base power coerce-to-type)
 552                (let* ((got (expt base power))
 553                       (expected (expt (coerce base coerce-to-type) power))
 554                       (result (test-complex got expected)))
 555                  (print-result (if result "Good:" "Bad:")
 556                                base power got expected)
 557                  (unless result
 558                    (incf n-broken)))))
 559         (dolist (base (list 2                    ; fixnum
 560                             (expt 2 64)          ; bignum
 561                             3/5                  ; ratio
 562                             2.0f0))              ; single-float
 563           (let ((power #c(-2.5d0 -4.5d0)))       ; complex double-float
 564             (test base power 'double-float)))
 565         (dolist (base (list #c(2.0f0 3.0f0)      ; complex single-float
 566                             #c(2 3)              ; complex fixnum
 567                             (complex (expt 2 64) (expt 2 65))
 568                                                  ; complex bignum
 569                             #c(3/5 1/7)))        ; complex ratio
 570           (dolist (power (list #c(-2.5d0 -4.5d0) ; complex double-float
 571                                -2.5d0))          ; double-float
 572             (test base power '(complex double-float)))))
 573       (when (> n-broken 0)
 574         (error "Number of broken combinations: ~a" n-broken)))))
 575
 576 (with-test (:name (:ldb :rlwinm :ppc))
 577   (let ((one (compile nil '(lambda (a) (ldb (byte 9 27) a))))
 578         (two (compile nil '(lambda (a)
 579                             (declare (type (integer -3 57216651) a))
 580                             (ldb (byte 9 27) a)))))
 581     (assert (= 0 (- (funcall one 10) (funcall two 10))))))
 582
 583 ;; The ISQRT implementation is sufficiently complicated that it should
 584 ;; be tested.
 585 (with-test (:name :isqrt)
 586   (labels ((test (x)
 587              (let* ((r (isqrt x))
 588                     (r2 (expt r 2))
 589                     (s2 (expt (1+ r) 2)))
 590                (unless (and (<= r2 x)
 591                             (> s2 x))
 592                  (error "isqrt failure for ~a" x))))
 593            (tests (x)
 594              (test x)
 595              (let ((x2 (expt x 2)))
 596                (test x2)
 597                (test (1+ x2))
 598                (test (1- x2)))))
 599     (test most-positive-fixnum)
 600     (test (1+ most-positive-fixnum))
 601     (loop for i from 1 to 200
 602           for pow = (expt 2 (1- i))
 603           for j = (+ pow (random pow))
 604           do
 605           (tests i)
 606           (tests j))
 607     (dotimes (i 10)
 608       (tests (random (expt 2 (+ 1000 (random 10000))))))))
 609
 610 ;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
 611 (with-test (:name :recursive-cut-to-width)
 612   (assert (eql (funcall
 613                 (compile nil
 614                          `(lambda (x)
 615                             (declare (optimize (space 3))
 616                                      (type (integer 12417236377505266230
 617                                                     12417274239874990070) x))
 618                             (logand 8459622733968096971 x)))
 619                 12417237222845306758)
 620                2612793697039849090)))
 621
 622 ;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
 623 (with-test (:name :more-recursive-cut-to-width)
 624   (assert (eql (funcall
 625                 (compile nil `(lambda (a b)
 626                                 (declare (optimize (speed 2) (safety 0)))
 627                                 (logand (the (eql 16779072918521075607) a)
 628                                         (the (integer 21371810342718833225 21371810343571293860) b))))
 629                 16779072918521075607 21371810342718833263)
 630                2923729245085762055)))
 631
 632 (with-test (:name :complicated-logand-identity)
 633   (loop for k from -8 upto 8 do
 634     (loop for min from -16 upto 16 do
 635       (loop for max from min upto 16 do
 636         (let ((f (compile nil `(lambda (x)
 637                                  (declare (type (integer ,min ,max) x))
 638                                  (logand x ,k)))))
 639           (loop for x from min upto max do
 640             (assert (eql (logand x k) (funcall f x)))))))))
 641
 642 (with-test (:name :complicated-logior-identity)
 643   (loop for k from -8 upto 8 do
 644     (loop for min from -16 upto 16 do
 645       (loop for max from min upto 16 do
 646         (let ((f (compile nil `(lambda (x)
 647                                  (declare (type (integer ,min ,max) x))
 648                                  (logior x ,k)))))
 649           (loop for x from min upto max do
 650             (assert (eql (logior x k) (funcall f x)))))))))
 651
 652 (with-test (:name :ldb-negative-index-no-error)
 653   (assert-error
 654    (funcall (compile nil
 655                      `(lambda (x y)
 656                         (ldb (byte x y) 100)))
 657             -1 -2))
 658   (assert-error
 659    (funcall (compile nil
 660                      `(lambda (x y)
 661                         (mask-field (byte x y) 100)))
 662             -1 -2))
 663   (assert-error
 664    (funcall (compile nil
 665                      `(lambda (x y)
 666                         (dpb 0 (byte x y) 100)))
 667             -1 -2))
 668   (assert-error
 669    (funcall (compile nil
 670                      `(lambda (x y)
 671                         (deposit-field 0 (byte x y) 100)))
 672             -1 -2)))
 673
 674 (with-test (:name :setf-mask-field)
 675   (assert (= (funcall
 676               (compile nil
 677                        `(lambda (a)
 678                           (setf (mask-field (byte 2 0) a) 1) a))
 679               15))))