master cf40795 3/3: Calc: allow infinite binary word size (bug#43764)

[Mattias Engdeg�rd]

branch: master
commit cf407958886e46881216a510efebb8bc029de50c
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    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.
---
 doc/misc/calc.texi           | 11 ++++++-
 etc/NEWS                     |  7 +++++
 lisp/calc/calc-bin.el        | 32 +++++++++++++-------
 test/lisp/calc/calc-tests.el | 70 ++++++++++++++++++++++++++++++++++++++------
 4 files changed, 99 insertions(+), 21 deletions(-)

diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index a356cec..6a6f585 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 79a8d11..aab96ca 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 20dd1d4..60dd17e 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 fd16102..b59f4dc 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.