From 35478f3f76d55f640372028889c570647432859c Mon Sep 17 00:00:00 2001
From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Fri, 9 Oct 2020 11:12:53 +0200
Subject: [PATCH] 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 33fd1af6ffb..aa10d55e52c 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 0df96a0e2db..4bced28a64f 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
 
-- 
2.39.5