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(assert-error (coerce (expt 10 1000) 'single-float) type-error)
70
71(defun are-we-getting-ash-right (x y)
72  (declare (optimize speed)
73           (type (unsigned-byte 32) x)
74           (type (integer -40 0) y))
75  (ash x y))
76(defun what-about-with-constants (x)
77  (declare (optimize speed) (type (unsigned-byte 32) x))
78  (ash x -32))
79
80(dotimes (i 41)
81  (assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i))
82             (if (< i 32)
83                 (1- (ash 1 (- 32 i)))
84                 0))))
85(assert (= (what-about-with-constants (1- (ash 1 32))) 0))
86
87(defun one-more-test-case-to-catch-sparc (x y)
88  (declare (optimize speed (safety 0))
89           (type (unsigned-byte 32) x) (type (integer -40 2) y))
90  (the (unsigned-byte 32) (ash x y)))
91(assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0))
92
93
94(eval-when (:compile-toplevel :load-toplevel :execute)
95  (defvar *n-fixnum-bits* (- sb-vm::n-word-bits sb-vm::n-fixnum-tag-bits))
96  (defvar *shifts* (let ((list (list 0
97                                     1
98                                     (1- sb-vm::n-word-bits)
99                                     sb-vm::n-word-bits
100                                     (1+ sb-vm::n-word-bits))))
101                     (append list (mapcar #'- list)))))
102
103(macrolet ((nc-list ()
104             `(list ,@(loop for i from 0 below (length *shifts*)
105                         collect `(frob (nth ,i *shifts*)))))
106           (c-list ()
107             `(list ,@(loop for i from 0 below (length *shifts*)
108                         collect `(frob ,(nth i *shifts*))))))
109  (defun nc-ash (x)
110    (macrolet ((frob (y)
111                 `(list x ,y (ash x ,y))))
112      (nc-list)))
113  (defun c-ash (x)
114    (macrolet ((frob (y)
115                 `(list x ,y (ash x ,y))))
116      (c-list)))
117  (defun nc-modular-ash-ub (x)
118    (macrolet ((frob (y)
119                 `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
120      (nc-list)))
121  (defun c-modular-ash-ub (x)
122    (declare (type (and fixnum unsigned-byte) x)
123             (optimize speed))
124    (macrolet ((frob (y)
125                 `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
126      (c-list))))
127
128(let* ((values (list 0 1 most-positive-fixnum))
129       (neg-values (cons most-negative-fixnum
130                         (mapcar #'- values))))
131  (labels ((test (value fun1 fun2)
132             (let ((res1 (funcall fun1 value))
133                   (res2 (funcall fun2 value)))
134               (mapcar (lambda (a b)
135                         (unless (equalp a b)
136                           (error "ash failure for ~A vs ~A: ~A not EQUALP ~A"
137                                  fun1 fun2
138                                  a b)))
139                       res1 res2))))
140    (loop for x in values do
141         (test x 'nc-ash 'c-ash)
142         (test x 'nc-modular-ash-ub 'c-modular-ash-ub))
143    (loop for x in neg-values do
144         (test x 'nc-ash 'c-ash))))
145
146
147(defun 64-bit-logcount (x)
148  (declare (optimize speed) (type (unsigned-byte 54) x))
149  (logcount x))
150(assert (= (64-bit-logcount (1- (ash 1 24))) 24))
151(assert (= (64-bit-logcount (1- (ash 1 32))) 32))
152(assert (= (64-bit-logcount (1- (ash 1 48))) 48))
153(assert (= (64-bit-logcount (1- (ash 1 54))) 54))
154
155(declaim (inline ppc-ldb-2))
156
157(defun ppc-ldb-2 (fun value)
158  (declare (type stream socket)
159           (type (signed-byte 32) value)
160           (optimize (speed 3) (safety 0) (space 1) (debug 1)
161                     (compilation-speed 0)))
162  (funcall fun (ldb (byte 8 24) value))
163  (funcall fun (ldb (byte 8 16) value))
164  (funcall fun (ldb (byte 8 8) value))
165  (funcall fun (ldb (byte 8 0) value))
166  (values))
167
168(defun ppc-ldb-1 (fun)
169  (declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
170                     (compilation-speed 0)))
171  (loop
172     for param :across (make-array 1 :initial-element nil)
173     for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
174     do (ppc-ldb-2 fun (if param size -1))))
175
176(let ((acc '()))
177  (ppc-ldb-1 (lambda (x)
178         (push x acc)))
179  (assert (equal acc '(#xff #xff #xff #xff))))
180
181