master 35478f3: Calc: fix arithmetic right shift sign bit detection

[Mattias Engdegård]

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

    Calc: fix arithmetic right shift sign bit detection
    
    Arithmetic right shift didn't compute the bit to shift in correctly.
    For example, #x600000000 right-shifted 8 steps (with 32 bit word size)
    resulted in #xff000000 rather than 0. (Bug#43764)
    
    * lisp/calc/calc-bin.el (calcFunc-ash): Fix condition.
    * test/lisp/calc/calc-tests.el (calc-tests--clip, calc-tests--lsh)
    (calc-tests--rsh, calc-tests--ash, calc-tests--rash, calc-tests--rot):
    New.
    (calc-shift-binary): New test.
---
 lisp/calc/calc-bin.el        |  2 +-
 test/lisp/calc/calc-tests.el | 62 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 63 insertions(+), 1 deletion(-)

diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index 33fd1af..aa10d55 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -403,7 +403,7 @@
            (setq a (math-clip a w)))
        (let ((two-to-sizem1 (math-power-of-2 (1- w)))
              (sh (calcFunc-lsh a n w)))
-         (cond ((Math-natnum-lessp a two-to-sizem1)
+         (cond ((zerop (logand a two-to-sizem1))
                 sh)
                ((Math-lessp n (- 1 w))
                 (math-add (math-mul two-to-sizem1 2) -1))
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index 0df96a0..4bced28 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -574,6 +574,68 @@ 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:
+
+(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)))))
+
+(defun calc-tests--lsh (x n w)
+  "Logical shift left X by N steps, word size W."
+  (if (< n 0)
+      (calc-tests--rsh x (- n) w)
+    (calc-tests--clip (ash x n) w)))
+
+(defun calc-tests--rsh (x n w)
+  "Logical shift right X by N steps, word size W."
+  (if (< n 0)
+      (calc-tests--lsh x (- n) w)
+    (ash (calc-tests--clip x w) (- n))))
+
+(defun calc-tests--ash (x n w)
+  "Arithmetic shift left X by N steps, word size W."
+  (if (< n 0)
+      (calc-tests--rash x (- n) w)
+    (calc-tests--clip (ash x n) w)))
+
+(defun calc-tests--rash (x n w)
+  "Arithmetic shift right X by N steps, word size W."
+  (if (< n 0)
+      (calc-tests--ash x (- n) w)
+    ;; First sign-extend, then shift.
+    (let ((x-sext (calc-tests--clip x (- (abs w)))))
+      (calc-tests--clip (ash x-sext (- n)) w))))
+
+(defun calc-tests--rot (x n w)
+  "Rotate X left by N steps, word size W."
+  (let* ((aw (abs w))
+         (y (calc-tests--clip x aw))
+         (steps (mod n aw)))
+    (calc-tests--clip (logior (ash y steps) (ash y (- steps aw)))
+                      w)))
+
+(ert-deftest calc-shift-binary ()
+  (dolist (w '(16 32))
+    (dolist (x '(0 1 #x1234 #x8000 #xabcd #xffff
+                 #x12345678 #xabcdef12 #x80000000 #xffffffff
+                 #x1234567890ab #x1234967890ab
+                 -1 -14))
+      (dolist (n '(0 1 4 16 32 -1 -4 -16 -32))
+        (should (equal (calcFunc-lsh x n w)
+                       (calc-tests--lsh x n w)))
+        (should (equal (calcFunc-rsh x n w)
+                       (calc-tests--rsh x n w)))
+        (should (equal (calcFunc-ash x n w)
+                       (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)))))))
+
 (provide 'calc-tests)
 ;;; calc-tests.el ends here