Merge branch 'feature/bignum'

8 files changed, 392 insertions, 17 deletions

diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el
new file mode 100644
index 00000000000..ba6d2040e8c
--- /dev/null
+++ b/test/lisp/international/ccl-tests.el
@@ -0,0 +1,219 @@
+(require 'ert)
+(require 'ccl)
+(require 'seq)
+
+
+(ert-deftest shift ()
+  ;; shift left +ve                      5628     #x00000000000015fc
+  (should (= (ash  5628  8)           1440768)) ; #x000000000015fc00
+  (should (= (lsh  5628  8)           1440768)) ; #x000000000015fc00
+
+  ;; shift left -ve                     -5628     #x3fffffffffffea04
+  (should (= (ash -5628  8)          -1440768)) ; #x3fffffffffea0400
+  (should (= (lsh -5628  8)          -1440768)) ; #x3fffffffffea0400
+
+  ;; shift right +ve                     5628     #x00000000000015fc
+  (should (= (ash  5628 -8)                21)) ; #x0000000000000015
+  (should (= (lsh  5628 -8)                21)) ; #x0000000000000015
+
+  ;; shift right -ve                    -5628     #x3fffffffffffea04
+  (should (= (ash -5628 -8)               -22)) ; #x3fffffffffffffea
+
+  ;; shift right                       -5628      #x3fffffffffffea04
+  (cond
+   ((fboundp 'bignump)
+    (should (= (lsh -5628 -8)            -22))) ; #x3fffffffffffffea  bignum
+   ((= (logb most-negative-fixnum) 61)
+    (should (= (lsh -5628 -8)
+               (string-to-number
+                "18014398509481962"))))         ; #x003fffffffffffea  master (64bit)
+   ((= (logb most-negative-fixnum) 29)
+    (should (= (lsh -5628 -8)        4194282))) ; #x003fffea          master (32bit)
+   ))
+
+;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el
+(defconst prog-pgg-source
+  '(1
+    ((loop
+      (read r0) (r1 ^= r0) (r2 ^= 0)
+      (r5 = 0)
+      (loop
+       (r1 <<= 1)
+       (r1 += ((r2 >> 15) & 1))
+       (r2 <<= 1)
+       (if (r1 & 256)
+           ((r1 ^= 390) (r2 ^= 19707)))
+       (if (r5 < 7)
+           ((r5 += 1)
+            (repeat))))
+      (repeat)))))
+
+(defconst prog-pgg-code
+  [1 30 14 114744 114775 0 161 131127 1 148217 15 82167
+     1 1848 131159 1 1595 5 256 114743 390 114775 19707
+     1467 16 7 183 1 -5628 -7164 22])
+
+(defconst prog-pgg-dump
+"Out-buffer must be as large as in-buffer.
+Main-body:
+    2:[read-register] read r0 (0 remaining)
+    3:[set-assign-expr-register] r1 ^= r0
+    4:[set-assign-expr-const] r2 ^= 0
+    6:[set-short-const] r5 = 0
+    7:[set-assign-expr-const] r1 <<= 1
+    9:[set-expr-const] r7 = r2 >> 15
+   11:[set-assign-expr-const] r7 &= 1
+   13:[set-assign-expr-register] r1 += r7
+   14:[set-assign-expr-const] r2 <<= 1
+   16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7)
+   19:[set-assign-expr-const] r1 ^= 390
+   21:[set-assign-expr-const] r2 ^= 19707
+   23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6)
+   26:[set-assign-expr-const] r5 += 1
+   28:[jump] jump to 7(-21)
+   29:[jump] jump to 2(-27)
+At EOF:
+   30:[end] end
+")
+
+(ert-deftest ccl-compile-pgg ()
+  (should (equal (ccl-compile prog-pgg-source) prog-pgg-code)))
+
+(ert-deftest ccl-dump-pgg ()
+  (with-temp-buffer
+    (ccl-dump prog-pgg-code)
+    (should (equal (buffer-string) prog-pgg-dump))))
+
+(ert-deftest pgg-parse-crc24 ()
+  ;; Compiler
+  (require 'pgg)
+  (should (equal pgg-parse-crc24 prog-pgg-code))
+  ;; Interpreter
+  (should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55])))
+  (should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53])))
+  (should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a]))))
+
+(ert-deftest pgg-parse-crc24-dump ()
+  ;; Disassembler
+  (require 'pgg)
+  (with-temp-buffer
+    (ccl-dump pgg-parse-crc24)
+    (should (equal (buffer-string) prog-pgg-dump))))
+
+;;----------------------------------------------------------------------------
+;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package
+(defconst prog-midi-source
+  '(2
+    (loop
+     (loop
+      ;; central message receiver loop here.
+      ;; When it exits, the command to deal with is in r0
+      ;; Any arguments are in r1 and r2
+      ;; r3 contains: 0 if no arguments are accepted
+      ;;              1 if 1 argument can be accepted
+      ;;              2 if 2 arguments can be accepted
+      ;;              3 if the first of two arguments has been accepted
+      ;; Arguments are read into r1 and r2.
+      ;; r4 contains the current running status byte if any.
+      (read-if (r0 < #x80)
+               (branch r3
+                       (repeat)
+                       ((r1 = r0) (r0 = r4) (break))
+                       ((r1 = r0) (r3 = 3) (repeat))
+                       ((r2 = r0) (r3 = 2) (r0 = r4) (break))))
+      (if (r0 >= #xf8) ; real time message
+          (break))
+      (if (r0 < #xf0) ; channel command
+          ((r4 = r0)
+           (if ((r0 & #xe0) == #xc0)
+               ;; program change and channel pressure take only 1 argument
+               (r3 = 1)
+             (r3 = 2))
+           (repeat)))
+      ;; system common message, we swallow those for now
+      (r3 = 0)
+      (repeat))
+     (if ((r0 & #xf0) == #x90)
+         (if (r2 == 0)              ; Some Midi devices use velocity 0
+                                        ; for switching notes off,
+                                        ; so translate into note-off
+                                        ; and fall through
+             (r0 -= #x10)
+           ((r0 &= #xf)
+            (write 0)
+            (write r0 r1 r2)
+            (repeat))))
+     (if ((r0 & #xf0) == #x80)
+         ((r0 &= #xf)
+          (write 1)
+          (write r0 r1 r2)
+          (repeat)))
+     (repeat))))
+
+(defconst prog-midi-code
+  [2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865
+     -4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169
+     224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091
+     18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588
+     82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22])
+
+(defconst prog-midi-dump
+"Out-buffer must be 2 times bigger than in-buffer.
+Main-body:
+    2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20)
+    5:[branch] jump to array[r3] of length 4
+        11 12 15 18 22 
+   11:[jump] jump to 2(-9)
+   12:[set-register] r1 = r0
+   13:[set-register] r0 = r4
+   14:[jump] jump to 41(+27)
+   15:[set-register] r1 = r0
+   16:[set-short-const] r3 = 3
+   17:[jump] jump to 2(-15)
+   18:[set-register] r2 = r0
+   19:[set-short-const] r3 = 2
+   20:[set-register] r0 = r4
+   21:[jump] jump to 41(+20)
+   22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4)
+   25:[jump] jump to 41(+16)
+   26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13)
+   29:[set-register] r4 = r0
+   30:[set-expr-const] r7 = r0 & 224
+   32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5)
+   35:[set-short-const] r3 = 1
+   36:[jump] jump to 38(+2)
+   37:[set-short-const] r3 = 2
+   38:[jump] jump to 2(-36)
+   39:[set-short-const] r3 = 0
+   40:[jump] jump to 2(-38)
+   41:[set-expr-const] r7 = r0 & 240
+   43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16)
+   46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6)
+   49:[set-assign-expr-const] r0 -= 16
+   51:[jump] jump to 59(+8)
+   52:[set-assign-expr-const] r0 &= 15
+   54:[write-const-string] write char \"\x00\"
+   55:[write-register] write r0 (2 remaining)
+   56:[write-register] write r1 (1 remaining)
+   57:[write-register] write r2 (0 remaining)
+   58:[jump] jump to 2(-56)
+   59:[set-expr-const] r7 = r0 & 240
+   61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10)
+   64:[set-assign-expr-const] r0 &= 15
+   66:[write-const-string] write char \"\x01\"
+   67:[write-register] write r0 (2 remaining)
+   68:[write-register] write r1 (1 remaining)
+   69:[write-register] write r2 (0 remaining)
+   70:[jump] jump to 2(-68)
+   71:[jump] jump to 2(-69)
+At EOF:
+   72:[end] end
+")
+
+(ert-deftest ccl-compile-midi ()
+  (should (equal (ccl-compile prog-midi-source) prog-midi-code)))
+
+(ert-deftest ccl-dump-midi ()
+  (with-temp-buffer
+    (ccl-dump prog-midi-code)
+    (should (equal (buffer-string) prog-midi-dump))))
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 3cd537859fd..ee6a3eb9222 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -105,7 +105,9 @@
   (should (isnan (min 0.0e+NaN)))
   (should (isnan (min 0.0e+NaN 1 2)))
   (should (isnan (min 1.0 0.0e+NaN)))
-  (should (isnan (min 1.0 0.0e+NaN 1.1))))
+  (should (isnan (min 1.0 0.0e+NaN 1.1)))
+  (should (isnan (min 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum))))
+  (should (isnan (max 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum)))))
 
 (defun data-tests-popcnt (byte)
   "Calculate the Hamming weight of BYTE."
@@ -515,4 +517,109 @@ comparing the subr with a much slower lisp implementation."
                        (bound-and-true-p data-tests-foo2)
                        (bound-and-true-p data-tests-foo3)))))))
 
+(ert-deftest data-tests-bignum ()
+  (should (bignump (+ most-positive-fixnum 1)))
+  (let ((f0 (+ (float most-positive-fixnum) 1))
+        (f-1 (- (float most-negative-fixnum) 1))
+        (b0 (+ most-positive-fixnum 1))
+        (b-1 (- most-negative-fixnum 1)))
+    (should (> b0 -1))
+    (should (> b0 f-1))
+    (should (> b0 b-1))
+    (should (>= b0 -1))
+    (should (>= b0 f-1))
+    (should (>= b0 b-1))
+    (should (>= b-1 b-1))
+
+    (should (< -1 b0))
+    (should (< f-1 b0))
+    (should (< b-1 b0))
+    (should (<= -1 b0))
+    (should (<= f-1 b0))
+    (should (<= b-1 b0))
+    (should (<= b-1 b-1))
+
+    (should (= b0 f0))
+    (should (= b0 b0))
+
+    (should (/= b0 f-1))
+    (should (/= b0 b-1))))
+
+(ert-deftest data-tests-+ ()
+  (should-not (fixnump (+ most-positive-fixnum most-positive-fixnum)))
+  (should (> (+ most-positive-fixnum most-positive-fixnum) most-positive-fixnum))
+  (should (eq (- (+ most-positive-fixnum most-positive-fixnum)
+                 (+ most-positive-fixnum most-positive-fixnum))
+              0)))
+
+(ert-deftest data-tests-/ ()
+  (let* ((x (* most-positive-fixnum 8))
+         (y (* most-negative-fixnum 8))
+         (z (- y)))
+    (should (= most-positive-fixnum (/ x 8)))
+    (should (= most-negative-fixnum (/ y 8)))
+    (should (= -1 (/ y z)))
+    (should (= -1 (/ z y)))
+    (should (= 0 (/ x (* 2 x))))
+    (should (= 0 (/ y (* 2 y))))
+    (should (= 0 (/ z (* 2 z))))))
+
+(ert-deftest data-tests-number-predicates ()
+  (should (fixnump 0))
+  (should (fixnump most-negative-fixnum))
+  (should (fixnump most-positive-fixnum))
+  (should (integerp (+ most-positive-fixnum 1)))
+  (should (integer-or-marker-p (+ most-positive-fixnum 1)))
+  (should (numberp (+ most-positive-fixnum 1)))
+  (should (number-or-marker-p (+ most-positive-fixnum 1)))
+  (should (natnump (+ most-positive-fixnum 1)))
+  (should-not (fixnump (+ most-positive-fixnum 1)))
+  (should (bignump (+ most-positive-fixnum 1))))
+
+(ert-deftest data-tests-number-to-string ()
+  (let* ((s "99999999999999999999999999999")
+         (v (read s)))
+    (should (equal (number-to-string v) s))))
+
+(ert-deftest data-tests-1+ ()
+  (should (> (1+ most-positive-fixnum) most-positive-fixnum))
+  (should (fixnump (1+ (1- most-negative-fixnum)))))
+
+(ert-deftest data-tests-1- ()
+  (should (< (1- most-negative-fixnum) most-negative-fixnum))
+  (should (fixnump (1- (1+ most-positive-fixnum)))))
+
+(ert-deftest data-tests-logcount ()
+  (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128)))
+
+(ert-deftest data-tests-minmax ()
+  (let ((a (- most-negative-fixnum 1))
+        (b (+ most-positive-fixnum 1))
+        (c 0))
+    (should (= (min a b c) a))
+    (should (= (max a b c) b))))
+
+(defun data-tests-check-sign (x y)
+  (should (eq (cl-signum x) (cl-signum y))))
+
+(ert-deftest data-tests-%-mod ()
+  (let* ((b1 (+ most-positive-fixnum 1))
+         (nb1 (- b1))
+         (b3 (+ most-positive-fixnum 3))
+         (nb3 (- b3)))
+    (data-tests-check-sign (% 1 3) (% b1 b3))
+    (data-tests-check-sign (mod 1 3) (mod b1 b3))
+    (data-tests-check-sign (% 1 -3) (% b1 nb3))
+    (data-tests-check-sign (mod 1 -3) (mod b1 nb3))
+    (data-tests-check-sign (% -1 3) (% nb1 b3))
+    (data-tests-check-sign (mod -1 3) (mod nb1 b3))
+    (data-tests-check-sign (% -1 -3) (% nb1 nb3))
+    (data-tests-check-sign (mod -1 -3) (mod nb1 nb3))))
+
+(ert-deftest data-tests-ash-lsh ()
+  (should (= (ash most-negative-fixnum 1)
+             (* most-negative-fixnum 2)))
+  (should (= (lsh most-negative-fixnum 1)
+             (* most-negative-fixnum 2))))
+
 ;;; data-tests.el ends here
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index aa896b06499..964ff088360 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -173,20 +173,23 @@
   (should-error (format "%x" 18446744073709551616.0)
                 :type 'overflow-error))
 (ert-deftest read-large-integer ()
-  (should-error (read (format "%d0" most-negative-fixnum))
-                :type 'overflow-error)
-  (should-error (read (format "%+d" (* -8.0 most-negative-fixnum)))
-                :type 'overflow-error)
-  (should-error (read (substring (format "%d" most-negative-fixnum) 1))
-                :type 'overflow-error)
+  (should (eq (type-of (read (format "%d0" most-negative-fixnum))) 'integer))
+  (should (eq (type-of (read (format "%+d" (* -8.0 most-negative-fixnum))))
+              'integer))
+  (should (eq (type-of (read (substring (format "%d" most-negative-fixnum) 1)))
+              'integer))
+  (should (eq (type-of (read (format "#x%x" most-negative-fixnum)))
+              'integer))
+  (should (eq (type-of (read (format "#o%o" most-negative-fixnum)))
+              'integer))
+  (should (eq (type-of (read (format "#32rG%x" most-positive-fixnum)))
+              'integer))
   (let ((binary-as-unsigned nil))
     (dolist (fmt '("%d" "%s" "#o%o" "#x%x"))
       (dolist (val (list most-negative-fixnum (1+ most-negative-fixnum)
                          -1 0 1
                          (1- most-positive-fixnum) most-positive-fixnum))
-        (should (eq val (read (format fmt val)))))))
-  (should-error (read (format "#32rG%x" most-positive-fixnum))
-                :type 'overflow-error))
+        (should (eq val (read (format fmt val))))))))
 
 (ert-deftest format-%o-invalid-float ()
   (should-error (format "%o" -1e-37)
@@ -374,4 +377,14 @@
     (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker))
     (garbage-collect)))
 
+(ert-deftest format-bignum ()
+  (let* ((s1 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF")
+         (v1 (read (concat "#x" s1)))
+         (s2 "99999999999999999999999999999999")
+         (v2 (read s2)))
+    (should (> v1 most-positive-fixnum))
+    (should (equal (format "%X" v1) s1))
+    (should (> v2 most-positive-fixnum))
+    (should (equal (format "%d" v2) s2))))
+
 ;;; editfns-tests.el ends here
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 9ef5a47b159..90cd37a98a5 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -68,10 +68,10 @@
                (1+ #x1fffffff)))
     (should (= (mod-test-sum -1 (1+ #x1fffffff))
                #x1fffffff)))
-  (should-error (mod-test-sum 1 most-positive-fixnum)
-                :type 'overflow-error)
-  (should-error (mod-test-sum -1 most-negative-fixnum)
-                :type 'overflow-error))
+  (should (= (mod-test-sum 1 most-positive-fixnum)
+             (1+ most-positive-fixnum)))
+  (should (= (mod-test-sum -1 most-negative-fixnum)
+             (1- most-negative-fixnum))))
 
 (ert-deftest mod-test-sum-docstring ()
   (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn a b)")))
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index cb173eea76d..7714c05d60a 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -34,4 +34,16 @@
   (should-error (ftruncate 0) :type 'wrong-type-argument)
   (should-error (fround 0) :type 'wrong-type-argument))
 
+(ert-deftest bignum-to-float ()
+  (should (eql (float (+ most-positive-fixnum 1))
+               (+ (float most-positive-fixnum) 1))))
+
+(ert-deftest bignum-abs ()
+  (should (= most-positive-fixnum
+             (- (abs most-negative-fixnum) 1))))
+
+(ert-deftest bignum-logb ()
+  (should (= (+ (logb most-positive-fixnum) 1)
+             (logb (+ most-positive-fixnum 1)))))
+
 (provide 'floatfns-tests)
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index e4b9cbe25a4..f722ed6333e 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -604,4 +604,24 @@
   (should (equal 1 (string-distance "ab" "a我b")))
   (should (equal 1 (string-distance "我" "她"))))
 
+(ert-deftest test-bignum-eql ()
+  "Test that `eql' works for bignums."
+  (let ((x (+ most-positive-fixnum 1))
+        (y (+ most-positive-fixnum 1)))
+    (should (eq x x))
+    (should (eql x y))
+    (should (equal x y))
+    (should-not (eql x 0.0e+NaN))))
+
+(ert-deftest test-bignum-hash ()
+  "Test that hash tables work for bignums."
+  ;; Make two bignums that are eql but not eq.
+  (let ((b1 (1+ most-positive-fixnum))
+        (b2 (1+ most-positive-fixnum)))
+    (dolist (test '(eq eql equal))
+      (let ((hash (make-hash-table :test test)))
+        (puthash b1 t hash)
+        (should (eq (gethash b2 hash)
+                    (funcall test b1 b2)))))))
+
 (provide 'fns-tests)
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 639a6da93ae..17381340c7b 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -195,9 +195,7 @@ literals (Bug#20852)."
     (should (eq x (cdr x)))))
 
 (ert-deftest lread-long-hex-integer ()
-  (should-error
-   (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff")
-   :type 'overflow-error))
+  (should (bignump (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff"))))
 
 (ert-deftest lread-test-bug-31186 ()
   (with-temp-buffer
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index c96cb5d2b69..091f1aa1afb 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -98,5 +98,11 @@ otherwise, use a different charset."
   (let ((sym '\’bar))
     (should (eq (read (prin1-to-string sym)) sym))))
 
+(ert-deftest print-bignum ()
+  (let* ((str "999999999999999999999999999999999")
+         (val (read str)))
+    (should (> val most-positive-fixnum))
+    (should (equal (prin1-to-string val) str))))
+
 (provide 'print-tests)
 ;;; print-tests.el ends here