bug#43764: Calc shift right broken

["Mattias Engdegård" <mattiase@acm.org>]

[-- Attachment #1: Type: text/plain, Size: 278 bytes --]

10 okt. 2020 kl. 18.24 skrev Mattias Engdegård <mattiase@acm.org>:

> This seems both useful and straightforward to implement and understand. I've attached a patch (lacking documentation but otherwise complete) -- is it what you had in mind?

Sorry, here is that patch.


[-- Attachment #2: 0001-Calc-allow-infinite-binary-word-size-bug.patch --]
[-- Type: application/octet-stream, Size: 8138 bytes --]

From ec880e30d82e13ff5c6cb36f7736280be45ee9e0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sat, 10 Oct 2020 18:02:49 +0200
Subject: [PATCH] Calc: allow infinite binary word size (bug#
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Setting the word size ("b w") to 0 removes the word size clipping for
all bit operations (effectively as if a word size of -∞ had been set).
Rotation is disallowed; logical and arithmetic shifts behave
identically.

After a suggestion by Vincent Belaïche.

* lisp/calc/calc-bin.el (calc-word-size, math-binary-arg)
(math-binary-modulo-args, calcFunc-lsh, calcFunc-ash, calcFunc-rot)
(math-clip): Allow a word size of 0, meaning -∞.
* test/lisp/calc/calc-tests.el
(calc-tests--not, calc-tests--and, calc-tests--or, calc-tests--xor)
(calc-tests--diff): New functions.
(calc-tests--clip, calc-tests--rot, calc-shift-binary): Extend to
cover word size 0.
(calc-bit-ops): New test.
---
 lisp/calc/calc-bin.el        | 30 ++++++++++------
 test/lisp/calc/calc-tests.el | 70 +++++++++++++++++++++++++++++++-----
 2 files changed, 80 insertions(+), 20 deletions(-)

diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index aa10d55e52..3570b890ab 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -145,9 +145,10 @@ calc-word-size
    (setq math-half-2-word-size (math-power-of-2 (1- (math-abs n))))
    (calc-do-refresh)
    (calc-refresh-evaltos)
-   (if (< n 0)
-       (message "Binary word size is %d bits (two's complement)" (- n))
-     (message "Binary word size is %d bits" n))))
+   (cond
+    ((< n 0) (message "Binary word size is %d bits (two's complement)" (- n)))
+    ((> n 0) (message "Binary word size is %d bits" n))
+    (t (message "No fixed binary word size")))))
 
 
 
@@ -262,9 +263,10 @@ calcFunc-and
 (defun math-binary-arg (a w)
   (if (not (Math-integerp a))
       (setq a (math-trunc a)))
-  (if (< a 0)
-      (logand a (1- (ash 1 (if w (math-trunc w) calc-word-size))))
-    a))
+  (let ((w (if w (math-trunc w) calc-word-size)))
+    (if (and (< a 0) (not (zerop w)))
+        (logand a (1- (ash 1 w)))
+      a)))
 
 (defun math-binary-modulo-args (f a b w)
   (let (mod)
@@ -285,7 +287,7 @@ math-binary-modulo-args
     (let ((bits (math-integer-log2 mod)))
       (if bits
 	  (if w
-	      (if (/= w bits)
+	      (if (and (/= w bits) (not (zerop w)))
 		  (calc-record-why
 		   "*Warning: Modulus inconsistent with word size"))
 	    (setq w bits))
@@ -371,11 +373,12 @@ calcFunc-lsh
 	(math-clip (calcFunc-lsh a n (- w)) w)
       (if (Math-integer-negp a)
 	  (setq a (math-clip a w)))
-      (cond ((or (Math-lessp n (- w))
-		 (Math-lessp w n))
+      (cond ((and (or (Math-lessp n (- w))
+		      (Math-lessp w n))
+                  (not (zerop w)))
 	     0)
 	    ((< n 0)
-	     (math-quotient (math-clip a w) (math-power-of-2 (- n))))
+	     (ash (math-clip a w) n))
 	    (t
 	     (math-clip (math-mul a (math-power-of-2 n)) w))))))
 
@@ -403,7 +406,8 @@ calcFunc-ash
 	    (setq a (math-clip a w)))
 	(let ((two-to-sizem1 (math-power-of-2 (1- w)))
 	      (sh (calcFunc-lsh a n w)))
-	  (cond ((zerop (logand a two-to-sizem1))
+	  (cond ((or (zerop w)
+                     (zerop (logand a two-to-sizem1)))
 		 sh)
 		((Math-lessp n (- 1 w))
 		 (math-add (math-mul two-to-sizem1 2) -1))
@@ -421,6 +425,8 @@ calcFunc-rot
   (if (eq (car-safe a) 'mod)
       (math-binary-modulo-args 'calcFunc-rot a n w)
     (setq w (if w (math-trunc w) calc-word-size))
+    (when (zerop w)
+      (error "Rotation requires a nonzero word size"))
     (or (integerp w)
 	(math-reject-arg w 'fixnump))
     (or (Math-integerp a)
@@ -452,6 +458,8 @@ math-clip
 	 (if (Math-natnum-lessp a (math-power-of-2 (- -1 w)))
 	     a
 	   (math-sub a (math-power-of-2 (- w)))))
+        ((math-zerop w)
+         a)
 	((Math-negp a)
 	 (math-binary-arg a w))
 	((integerp a)
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index fe37c424d5..f8c4925c2f 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -574,15 +574,35 @@ calc-unix-date
                                           86400))))
       (should (equal (math-format-date d-1991-01-09-0600) "663400800")))))
 
-;; Reference implementations of binary shift functions:
+;; Reference implementations of bit operations:
 
 (defun calc-tests--clip (x w)
   "Clip X to W bits, signed if W is negative, otherwise unsigned."
-  (if (>= w 0)
-      (logand x (- (ash 1 w) 1))
-    (let ((y (calc-tests--clip x (- w)))
-          (msb (ash 1 (- (- w) 1))))
-      (- y (ash (logand y msb) 1)))))
+  (cond ((zerop w) x)
+        ((> w 0) (logand x (- (ash 1 w) 1)))
+        (t (let ((y (calc-tests--clip x (- w)))
+                 (msb (ash 1 (- (- w) 1))))
+             (- y (ash (logand y msb) 1))))))
+
+(defun calc-tests--not (x w)
+  "Bitwise complement of X, word size W."
+  (calc-tests--clip (lognot x) w))
+
+(defun calc-tests--and (x y w)
+  "Bitwise AND of X and W, word size W."
+  (calc-tests--clip (logand x y) w))
+
+(defun calc-tests--or (x y w)
+  "Bitwise OR of X and Y, word size W."
+  (calc-tests--clip (logior x y) w))
+
+(defun calc-tests--xor (x y w)
+  "Bitwise XOR of X and Y, word size W."
+  (calc-tests--clip (logxor x y) w))
+
+(defun calc-tests--diff (x y w)
+  "Bitwise AND of X and NOT Y, word size W."
+  (calc-tests--clip (logand x (lognot y)) w))
 
 (defun calc-tests--lsh (x n w)
   "Logical shift left X by N steps, word size W."
@@ -616,6 +636,8 @@ calc-tests--rash
 
 (defun calc-tests--rot (x n w)
   "Rotate X left by N steps, word size W."
+  (when (zerop w)
+    (error "Undefined"))
   (let* ((aw (abs w))
          (y (calc-tests--clip x aw))
          (steps (mod n aw)))
@@ -623,7 +645,7 @@ calc-tests--rot
                       w)))
 
 (ert-deftest calc-shift-binary ()
-  (dolist (w '(16 32 -16 -32))
+  (dolist (w '(16 32 -16 -32 0))
     (dolist (x '(0 1 #x1234 #x8000 #xabcd #xffff
                  #x12345678 #xabcdef12 #x80000000 #xffffffff
                  #x1234567890ab #x1234967890ab
@@ -638,8 +660,38 @@ calc-shift-binary
                        (calc-tests--ash x n w)))
         (should (equal (calcFunc-rash x n w)
                        (calc-tests--rash x n w)))
-        (should (equal (calcFunc-rot x n w)
-                       (calc-tests--rot x n w)))))))
+        (unless (zerop w)
+          (should (equal (calcFunc-rot x n w)
+                         (calc-tests--rot x n w)))))))
+  (should-error (calcFunc-rot 1 1 0)))
+
+(ert-deftest calc-bit-ops ()
+  (dolist (w '(16 32 -16 -32 0))
+    (dolist (x '(0 1 #x1234 #x8000 #xabcd #xffff
+                 #x12345678 #xabcdef12 #x80000000 #xffffffff
+                 #x1234567890ab #x1234967890ab
+                 -1 -14 #x-8000 #x-ffff #x-8001 #x-10000
+                 #x-80000000 #x-ffffffff #x-80000001 #x-100000000))
+      (should (equal (calcFunc-not x w)
+                     (calc-tests--not x w)))
+
+      (dolist (n '(0 1 4 16 32 -1 -4 -16 -32))
+        (equal (calcFunc-clip x n)
+               (calc-tests--clip x n)))
+
+      (dolist (y '(0 1 #x1234 #x8000 #xabcd #xffff
+                     #x12345678 #xabcdef12 #x80000000 #xffffffff
+                     #x1234567890ab #x1234967890ab
+                     -1 -14 #x-8000 #x-ffff #x-8001 #x-10000
+                     #x-80000000 #x-ffffffff #x-80000001 #x-100000000))
+        (should (equal (calcFunc-and x y w)
+                       (calc-tests--and x y w)))
+        (should (equal (calcFunc-or x y w)
+                       (calc-tests--or x y w)))
+        (should (equal (calcFunc-xor x y w)
+                       (calc-tests--xor x y w)))
+        (should (equal (calcFunc-diff x y w)
+                       (calc-tests--diff x y w)))))))
 
 (provide 'calc-tests)
 ;;; calc-tests.el ends here
-- 
2.21.1 (Apple Git-122.3)