From: Mattias Engdegård <mattiase@acm.org>
Date: Sat, 10 Oct 2020 16:02:49 +0000 (+0200)
Subject: Calc: allow infinite binary word size (bug#43764)
X-Git-Tag: emacs-28.0.90~5652
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=cf407958886e46881216a510efebb8bc029de50c;p=emacs.git

Calc: allow infinite binary word size (bug#43764)

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, math-format-twos-complement): 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.
* doc/misc/calc.texi (Binary Functions): Update manual.
* etc/NEWS: Announce the change.
---

diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index a356cecf2b7..6a6f585ce20 100644
--- a/doc/misc/calc.texi
+++ b/doc/misc/calc.texi
@@ -18077,7 +18077,7 @@ zeros with @kbd{d z}.  @xref{Radix Modes}.
 
 @cindex Word size for binary operations
 The Calculator maintains a current @dfn{word size} @expr{w}, an
-arbitrary positive or negative integer.  For a positive word size, all
+arbitrary integer.  For a positive word size, all
 of the binary operations described here operate modulo @expr{2^w}.  In
 particular, negative arguments are converted to positive integers modulo
 @expr{2^w} by all binary functions.
@@ -18092,6 +18092,9 @@ to
 inclusive.  Either mode accepts inputs in any range; the sign of
 @expr{w} affects only the results produced.
 
+If the word size is zero, binary operations work on the entire number
+without clipping, as if the word size had been negative infinity.
+
 @kindex b c
 @pindex calc-clip
 @tindex clip
@@ -18221,6 +18224,10 @@ and @samp{rash} operations is totally independent from whether the word
 size is positive or negative.)  With a negative prefix argument, this
 performs a standard left shift.
 
+When the word size is zero, logical and arithmetic shift operations
+are identical: a negative value shifted right remains negative, since
+there is an infinite supply of ones to shift in.
+
 @kindex b t
 @pindex calc-rotate-binary
 @tindex rot
@@ -18230,6 +18237,8 @@ word size) is dropped off the left and shifted in on the right.  With a
 numeric prefix argument, the number is rotated that many bits to the left
 or right.
 
+Rotation is not possible with a zero word size.
+
 @xref{Set Operations}, for the @kbd{b p} and @kbd{b u} commands that
 pack and unpack binary integers into sets.  (For example, @kbd{b u}
 unpacks the number @samp{2#11001} to the set of bit-numbers
diff --git a/etc/NEWS b/etc/NEWS
index 79a8d119f3a..aab96cae8fd 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1101,6 +1101,13 @@ work more traditionally, with 'C-d' deleting the next character.
 Likewise, point isn't moved to the end of the string before inserting
 digits.
 
++++
+*** Setting the word size to zero disables word clipping.
+The word size normally clips the results of certain bit-oriented
+operations such as shifts and bitwise XOR.  A word size of zero, set
+by 'b w', makes the operation have effect on the whole argument values
+and the result is not truncated in any way.
+
 ** term-mode
 
 ---
diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index 20dd1d441bc..60dd17e5ed2 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -145,9 +145,10 @@
    (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 @@
 (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 @@
     (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 @@
 	(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 @@
 	    (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 @@
   (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 @@
 	 (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)
@@ -682,6 +690,8 @@
 
 (defun math-format-twos-complement (a)
   "Format an integer in two's complement mode."
+  (when (zerop calc-word-size)
+    (error "Nonzero word size required"))
   (let* (;(calc-leading-zeros t)
          (num
           (cond
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index fd161027a96..b59f4dc988f 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -569,15 +569,35 @@ An existing calc stack is reused, otherwise a new one is created."
                                           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."
@@ -611,6 +631,8 @@ An existing calc stack is reused, otherwise a new one is created."
 
 (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)))
@@ -618,7 +640,7 @@ An existing calc stack is reused, otherwise a new one is created."
                       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
@@ -633,8 +655,38 @@ An existing calc stack is reused, otherwise a new one is created."
                        (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)))))))
 
 (ert-deftest calc-latex-input ()
   ;; Check precedence of "/" in LaTeX input mode.