X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Farith.impure.lisp;h=71b57343ad65b81e9d3c672e29cffe50e6f1d729;hb=062283b901155792f65775491aea51481c56faaa;hp=e4c7e7d6b46b331554bbefddc8ad9c018ec4ca2d;hpb=32d188868633a7c7db73da03f20ee5a107ed6f31;p=sbcl.git

diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp
index e4c7e7d..71b5734 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,17 +79,71 @@
 
 (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))
 
+
+(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)))))
+
+(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*))))))
+  (defun nc-ash (x)
+    (macrolet ((frob (y)
+                 `(list x ,y (ash x ,y))))
+      (nc-list)))
+  (defun c-ash (x)
+    (macrolet ((frob (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)))))
+      (nc-list)))
+  (defun c-modular-ash-ub (x)
+    (declare (type (and fixnum unsigned-byte) x)
+             (optimize speed))
+    (macrolet ((frob (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))))
+  (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))))
+    (loop for x in values do
+         (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))))
+
+
 (defun 64-bit-logcount (x)
   (declare (optimize speed) (type (unsigned-byte 54) x))
   (logcount x))
@@ -98,4 +152,29 @@
 (assert (= (64-bit-logcount (1- (ash 1 48))) 48))
 (assert (= (64-bit-logcount (1- (ash 1 54))) 54))
 
-(sb-ext:quit :unix-status 104)
+(declaim (inline ppc-ldb-2))
+
+(defun ppc-ldb-2 (fun value)
+  (declare (type stream socket)
+           (type (signed-byte 32) value)
+           (optimize (speed 3) (safety 0) (space 1) (debug 1)
+                     (compilation-speed 0)))
+  (funcall fun (ldb (byte 8 24) value))
+  (funcall fun (ldb (byte 8 16) value))
+  (funcall fun (ldb (byte 8 8) value))
+  (funcall fun (ldb (byte 8 0) value))
+  (values))
+
+(defun ppc-ldb-1 (fun)
+  (declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
+                     (compilation-speed 0)))
+  (loop
+     for param :across (make-array 1 :initial-element nil)
+     for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
+     do (ppc-ldb-2 fun (if param size -1))))
+
+(let ((acc '()))
+  (ppc-ldb-1 (lambda (x)
+         (push x acc)))
+  (assert (equal acc '(#xff #xff #xff #xff))))
+