tests/arith.impure.lisp

   1 ;;;; arithmetic tests with 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 (load "assertoid.lisp")
  15 (use-package "ASSERTOID")
  16
  17 (defmacro define-compiled-fun (fun name)
  18   `(progn
  19     (declaim (notinline ,name))
  20     (defun ,name (&rest args)
  21      (declare (optimize safety))
  22      (case (length args)
  23        (0 (,fun))
  24        (1 (,fun (car args)))
  25        (2 (,fun (car args) (cadr args)))
  26        (t (apply #',fun args))))))
  27
  28 (define-compiled-fun min compiled-min)
  29 (define-compiled-fun max compiled-max)
  30 (define-compiled-fun + compiled-+)
  31 (define-compiled-fun * compiled-*)
  32 (define-compiled-fun logand compiled-logand)
  33 (define-compiled-fun logior compiled-logior)
  34 (define-compiled-fun logxor compiled-logxor)
  35
  36 (assert (null (ignore-errors (compiled-min '(1 2 3)))))
  37 (assert (= (compiled-min -1) -1))
  38 (assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
  39 (assert (= (compiled-min 10 11) 10))
  40 (assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
  41 (assert (= (compiled-min 5.0 -3) -3))
  42 (assert (null (ignore-errors (compiled-max #c(4 3)))))
  43 (assert (= (compiled-max 0) 0))
  44 (assert (null (ignore-errors (compiled-max "MIX" 3))))
  45 (assert (= (compiled-max -1 10.0) 10.0))
  46 (assert (null (ignore-errors (compiled-max 3 #'max))))
  47 (assert (= (compiled-max -3 0) 0))
  48
  49 (assert (null (ignore-errors (compiled-+ "foo"))))
  50 (assert (= (compiled-+ 3f0) 3f0))
  51 (assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
  52 (assert (= (compiled-+ 1 2) 3))
  53 (assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
  54 (assert (= (compiled-+ 3f0 4f0) 7f0))
  55 (assert (null (ignore-errors (compiled-* "foo"))))
  56 (assert (= (compiled-* 3f0) 3f0))
  57 (assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
  58 (assert (= (compiled-* 1 2) 2))
  59 (assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
  60 (assert (= (compiled-* 3f0 4f0) 12f0))
  61
  62 (assert (null (ignore-errors (compiled-logand #(1)))))
  63 (assert (= (compiled-logand 1) 1))
  64 (assert (null (ignore-errors (compiled-logior 3f0))))
  65 (assert (= (compiled-logior 4) 4))
  66 (assert (null (ignore-errors (compiled-logxor #c(2 3)))))
  67 (assert (= (compiled-logxor -6) -6))
  68
  69 (with-test (:name (coerce :overflow))
  70   (assert-error (coerce (expt 10 1000) 'single-float) floating-point-overflow))
  71 \f
  72 (defun are-we-getting-ash-right (x y)
  73   (declare (optimize speed)
  74            (type (unsigned-byte 32) x)
  75            (type (integer -40 0) y))
  76   (ash x y))
  77 (defun what-about-with-constants (x)
  78   (declare (optimize speed) (type (unsigned-byte 32) x))
  79   (ash x -32))
  80
  81 (dotimes (i 41)
  82   (assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i))
  83              (if (< i 32)
  84                  (1- (ash 1 (- 32 i)))
  85                  0))))
  86 (assert (= (what-about-with-constants (1- (ash 1 32))) 0))
  87
  88 (defun one-more-test-case-to-catch-sparc (x y)
  89   (declare (optimize speed (safety 0))
  90            (type (unsigned-byte 32) x) (type (integer -40 2) y))
  91   (the (unsigned-byte 32) (ash x y)))
  92 (assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0))
  93
  94
  95 (eval-when (:compile-toplevel :load-toplevel :execute)
  96   (defvar *n-fixnum-bits* (- sb-vm::n-word-bits sb-vm::n-fixnum-tag-bits))
  97   (defvar *shifts* (let ((list (list 0
  98                                      1
  99                                      (1- sb-vm::n-word-bits)
 100                                      sb-vm::n-word-bits
 101                                      (1+ sb-vm::n-word-bits))))
 102                      (append list (mapcar #'- list)))))
 103
 104 (macrolet ((nc-list ()
 105              `(list ,@(loop for i from 0 below (length *shifts*)
 106                          collect `(frob (nth ,i *shifts*)))))
 107            (c-list ()
 108              `(list ,@(loop for i from 0 below (length *shifts*)
 109                          collect `(frob ,(nth i *shifts*))))))
 110   (defun nc-ash (x)
 111     (macrolet ((frob (y)
 112                  `(list x ,y (ash x ,y))))
 113       (nc-list)))
 114   (defun c-ash (x)
 115     (macrolet ((frob (y)
 116                  `(list x ,y (ash x ,y))))
 117       (c-list)))
 118   (defun nc-modular-ash-ub (x)
 119     (macrolet ((frob (y)
 120                  `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
 121       (nc-list)))
 122   (defun c-modular-ash-ub (x)
 123     (declare (type (and fixnum unsigned-byte) x)
 124              (optimize speed))
 125     (macrolet ((frob (y)
 126                  `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
 127       (c-list))))
 128
 129 (let* ((values (list 0 1 most-positive-fixnum))
 130        (neg-values (cons most-negative-fixnum
 131                          (mapcar #'- values))))
 132   (labels ((test (value fun1 fun2)
 133              (let ((res1 (funcall fun1 value))
 134                    (res2 (funcall fun2 value)))
 135                (mapcar (lambda (a b)
 136                          (unless (equalp a b)
 137                            (error "ash failure for ~A vs ~A: ~A not EQUALP ~A"
 138                                   fun1 fun2
 139                                   a b)))
 140                        res1 res2))))
 141     (loop for x in values do
 142          (test x 'nc-ash 'c-ash)
 143          (test x 'nc-modular-ash-ub 'c-modular-ash-ub))
 144     (loop for x in neg-values do
 145          (test x 'nc-ash 'c-ash))))
 146
 147
 148 (defun 64-bit-logcount (x)
 149   (declare (optimize speed) (type (unsigned-byte 54) x))
 150   (logcount x))
 151 (assert (= (64-bit-logcount (1- (ash 1 24))) 24))
 152 (assert (= (64-bit-logcount (1- (ash 1 32))) 32))
 153 (assert (= (64-bit-logcount (1- (ash 1 48))) 48))
 154 (assert (= (64-bit-logcount (1- (ash 1 54))) 54))
 155 \f
 156 (declaim (inline ppc-ldb-2))
 157
 158 (defun ppc-ldb-2 (fun value)
 159   (declare (type stream socket)
 160            (type (signed-byte 32) value)
 161            (optimize (speed 3) (safety 0) (space 1) (debug 1)
 162                      (compilation-speed 0)))
 163   (funcall fun (ldb (byte 8 24) value))
 164   (funcall fun (ldb (byte 8 16) value))
 165   (funcall fun (ldb (byte 8 8) value))
 166   (funcall fun (ldb (byte 8 0) value))
 167   (values))
 168
 169 (defun ppc-ldb-1 (fun)
 170   (declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
 171                      (compilation-speed 0)))
 172   (loop
 173      for param :across (make-array 1 :initial-element nil)
 174      for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
 175      do (ppc-ldb-2 fun (if param size -1))))
 176
 177 (let ((acc '()))
 178   (ppc-ldb-1 (lambda (x)
 179          (push x acc)))
 180   (assert (equal acc '(#xff #xff #xff #xff))))
 181 \f