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