X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Farith.impure.lisp;h=dc11f8bf803e8796065bab5af8d348bafdba1d35;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=fb6b7d9cfb53d38cd6285f938bf1a3fc43dbd169;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp index fb6b7d9..dc11f8b 100644 --- a/tests/arith.impure.lisp +++ b/tests/arith.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -70,8 +70,8 @@ (defun are-we-getting-ash-right (x y) (declare (optimize speed) - (type (unsigned-byte 32) x) - (type (integer -40 0) y)) + (type (unsigned-byte 32) x) + (type (integer -40 0) y)) (ash x y)) (defun what-about-with-constants (x) (declare (optimize speed) (type (unsigned-byte 32) x)) @@ -79,14 +79,14 @@ (dotimes (i 41) (assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i)) - (if (< i 32) - (1- (ash 1 (- 32 i))) - 0)))) + (if (< i 32) + (1- (ash 1 (- 32 i))) + 0)))) (assert (= (what-about-with-constants (1- (ash 1 32))) 0)) (defun one-more-test-case-to-catch-sparc (x y) (declare (optimize speed (safety 0)) - (type (unsigned-byte 32) x) (type (integer -40 2) y)) + (type (unsigned-byte 32) x) (type (integer -40 2) y)) (the (unsigned-byte 32) (ash x y))) (assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0)) @@ -94,54 +94,54 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *n-fixnum-bits* (- sb-vm::n-word-bits sb-vm::n-fixnum-tag-bits)) (defvar *shifts* (let ((list (list 0 - 1 - (1- sb-vm::n-word-bits) - sb-vm::n-word-bits - (1+ sb-vm::n-word-bits)))) - (append list (mapcar #'- list))))) + 1 + (1- sb-vm::n-word-bits) + sb-vm::n-word-bits + (1+ sb-vm::n-word-bits)))) + (append list (mapcar #'- list))))) (macrolet ((nc-list () - `(list ,@(loop for i from 0 below (length *shifts*) - collect `(frob (nth ,i *shifts*))))) - (c-list () - `(list ,@(loop for i from 0 below (length *shifts*) - collect `(frob ,(nth i *shifts*)))))) + `(list ,@(loop for i from 0 below (length *shifts*) + collect `(frob (nth ,i *shifts*))))) + (c-list () + `(list ,@(loop for i from 0 below (length *shifts*) + collect `(frob ,(nth i *shifts*)))))) (defun nc-ash (x) (macrolet ((frob (y) - `(list x ,y (ash x ,y)))) + `(list x ,y (ash x ,y)))) (nc-list))) (defun c-ash (x) (macrolet ((frob (y) - `(list x ,y (ash x ,y)))) + `(list x ,y (ash x ,y)))) (c-list))) (defun nc-modular-ash-ub (x) (macrolet ((frob (y) - `(list x ,y (logand most-positive-fixnum (ash x ,y))))) + `(list x ,y (logand most-positive-fixnum (ash x ,y))))) (nc-list))) (defun c-modular-ash-ub (x) (declare (type (and fixnum unsigned-byte) x) - (optimize speed)) + (optimize speed)) (macrolet ((frob (y) - `(list x ,y (logand most-positive-fixnum (ash x ,y))))) + `(list x ,y (logand most-positive-fixnum (ash x ,y))))) (c-list)))) (let* ((values (list 0 1 most-positive-fixnum)) (neg-values (cons most-negative-fixnum - (mapcar #'- values)))) + (mapcar #'- values)))) (labels ((test (value fun1 fun2) - (let ((res1 (funcall fun1 value)) - (res2 (funcall fun2 value))) - (mapcar (lambda (a b) - (unless (equalp a b) - (error "ash failure for ~A vs ~A: ~A not EQUALP ~A" - fun1 fun2 - a b))) - res1 res2)))) + (let ((res1 (funcall fun1 value)) + (res2 (funcall fun2 value))) + (mapcar (lambda (a b) + (unless (equalp a b) + (error "ash failure for ~A vs ~A: ~A not EQUALP ~A" + fun1 fun2 + a b))) + res1 res2)))) (loop for x in values do - (test x 'nc-ash 'c-ash) - (test x 'nc-modular-ash-ub 'c-modular-ash-ub)) + (test x 'nc-ash 'c-ash) + (test x 'nc-modular-ash-ub 'c-modular-ash-ub)) (loop for x in neg-values do - (test x 'nc-ash 'c-ash)))) + (test x 'nc-ash 'c-ash)))) (defun 64-bit-logcount (x)