Make bignums work better when EMACS_INT is larger than long

* lisp/international/ccl.el (ccl-fixnum): New function.
(ccl-embed-data, ccl-embed-current-address, ccl-dump): Use it.
* src/alloc.c (make_number): Handle case where EMACS_INT is
larger than long.
* src/data.c (bignumcompare): Handle case where EMACS_INT is
larger than long.
(arith_driver): Likewise.  Coerce markers.
(float_arith_driver): Coerce markers.
(Flogcount): Use mpz_sgn.
(ash_lsh_impl): Fix bugs.
(Fsub1): Fix underflow check.
* src/lisp.h (NUMBERP): Don't check BIGNUMP.
(CHECK_FIXNUM_OR_FLOAT_COERCE_MARKER): Fix indentation.
* test/lisp/international/ccl-tests.el: New file.

5 files changed, 340 insertions, 23 deletions

diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index d2f490d59cd..d1b82ceb9ce 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -184,11 +184,17 @@
 (defvar ccl-current-ic 0
   "The current index for `ccl-program-vector'.")
 
+;; This is needed because CCL assumes the pre-bigint (wrapping)
+;; semantics of integer overflow.
+(defun ccl-fixnum (code)
+  "Convert a CCL code word to a fixnum value."
+  (- (logxor (logand code #x0fffffff) #x08000000) #x08000000))
+
 (defun ccl-embed-data (data &optional ic)
   "Embed integer DATA in `ccl-program-vector' at `ccl-current-ic' and
 increment it.  If IC is specified, embed DATA at IC."
   (if ic
-      (aset ccl-program-vector ic data)
+      (aset ccl-program-vector ic (ccl-fixnum data))
     (let ((len (length ccl-program-vector)))
       (if (>= ccl-current-ic len)
           (let ((new (make-vector (* len 2) nil)))
@@ -196,7 +202,7 @@ increment it.  If IC is specified, embed DATA at IC."
               (setq len (1- len))
               (aset new len (aref ccl-program-vector len)))
             (setq ccl-program-vector new))))
-    (aset ccl-program-vector ccl-current-ic data)
+    (aset ccl-program-vector ccl-current-ic (ccl-fixnum data))
     (setq ccl-current-ic (1+ ccl-current-ic))))
 
 (defun ccl-embed-symbol (symbol prop)
@@ -230,7 +236,8 @@ proper index number for SYMBOL.  PROP should be
 `ccl-program-vector' at IC without altering the other bit field."
   (let ((relative (- ccl-current-ic (1+ ic))))
     (aset ccl-program-vector ic
-          (logior (aref ccl-program-vector ic) (ash relative 8)))))
+          (logior (aref ccl-program-vector ic)
+                  (ccl-fixnum (ash relative 8))))))
 
 (defun ccl-embed-code (op reg data &optional reg2)
   "Embed CCL code for the operation OP and arguments REG and DATA in
@@ -986,7 +993,8 @@ is a list of CCL-BLOCKs."
 (defun ccl-get-next-code ()
   "Return a CCL code in `ccl-code' at `ccl-current-ic'."
   (prog1
-      (aref ccl-code ccl-current-ic)
+      (let ((code (aref ccl-code ccl-current-ic)))
+        (if (numberp code) (ccl-fixnum code) code))
     (setq ccl-current-ic (1+ ccl-current-ic))))
 
 (defun ccl-dump-1 ()
diff --git a/src/alloc.c b/src/alloc.c
index 1dc1bbb031a..367bb73fc15 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3815,6 +3815,34 @@ make_number (mpz_t value)
         }
     }
 
+  /* Check if fixnum can be larger than long.  */
+  if (sizeof (EMACS_INT) > sizeof (long))
+    {
+      size_t bits = mpz_sizeinbase (value, 2);
+      int sign = mpz_sgn (value);
+
+      if (bits < FIXNUM_BITS + (sign < 0))
+        {
+          EMACS_INT v = 0;
+          size_t limbs = mpz_size (value);
+          mp_size_t i;
+
+          for (i = 0; i < limbs; i++)
+            {
+              mp_limb_t limb = mpz_getlimbn (value, i);
+              v |= (EMACS_INT) ((EMACS_UINT) limb << (i * GMP_NUMB_BITS));
+            }
+          if (sign < 0)
+            v = -v;
+
+          if (!FIXNUM_OVERFLOW_P (v))
+            {
+              XSETINT (obj, v);
+              return obj;
+            }
+        }
+    }
+
   obj = allocate_misc (Lisp_Misc_Bignum);
   b = XBIGNUM (obj);
   /* We could mpz_init + mpz_swap here, to avoid a copy, but the
diff --git a/src/data.c b/src/data.c
index 0deebdca1ae..3d55d9d17d5 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2409,7 +2409,18 @@ bignumcompare (Lisp_Object num1, Lisp_Object num2,
       if (FLOATP (num2))
         cmp = mpz_cmp_d (XBIGNUM (num1)->value, XFLOAT_DATA (num2));
       else if (FIXNUMP (num2))
-        cmp = mpz_cmp_si (XBIGNUM (num1)->value, XINT (num2));
+        {
+          if (sizeof (EMACS_INT) > sizeof (long) && XINT (num2) > LONG_MAX)
+            {
+              mpz_t tem;
+              mpz_init (tem);
+              mpz_set_intmax (tem, XINT (num2));
+              cmp = mpz_cmp (XBIGNUM (num1)->value, tem);
+              mpz_clear (tem);
+            }
+          else
+            cmp = mpz_cmp_si (XBIGNUM (num1)->value, XINT (num2));
+        }
       else
         {
           eassume (BIGNUMP (num2));
@@ -2422,10 +2433,19 @@ bignumcompare (Lisp_Object num1, Lisp_Object num2,
       if (FLOATP (num1))
         cmp = - mpz_cmp_d (XBIGNUM (num2)->value, XFLOAT_DATA (num1));
       else
-        {
+        {
           eassume (FIXNUMP (num1));
-          cmp = - mpz_cmp_si (XBIGNUM (num2)->value, XINT (num1));
-        }
+          if (sizeof (EMACS_INT) > sizeof (long) && XINT (num1) > LONG_MAX)
+            {
+              mpz_t tem;
+              mpz_init (tem);
+              mpz_set_intmax (tem, XINT (num1));
+              cmp = - mpz_cmp (XBIGNUM (num2)->value, tem);
+              mpz_clear (tem);
+            }
+          else
+            cmp = - mpz_cmp_si (XBIGNUM (num2)->value, XINT (num1));
+        }
     }
 
   switch (comparison)
@@ -2860,7 +2880,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
     {
       /* Using args[argnum] as argument to CHECK_NUMBER... */
       val = args[argnum];
-      CHECK_NUMBER (val);
+      CHECK_NUMBER_COERCE_MARKER (val);
 
       if (FLOATP (val))
         return unbind_to (count,
@@ -2871,7 +2891,15 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
         case Aadd:
           if (BIGNUMP (val))
             mpz_add (accum, accum, XBIGNUM (val)->value);
-          else if (XINT (val) < 0)
+          else if (sizeof (EMACS_INT) > sizeof (long))
+            {
+              mpz_t tem;
+              mpz_init (tem);
+              mpz_set_intmax (tem, XINT (val));
+              mpz_add (accum, accum, tem);
+              mpz_clear (tem);
+            }
+          else if (XINT (val) < 0)
             mpz_sub_ui (accum, accum, - XINT (val));
           else
             mpz_add_ui (accum, accum, XINT (val));
@@ -2888,6 +2916,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
             }
           else if (BIGNUMP (val))
             mpz_sub (accum, accum, XBIGNUM (val)->value);
+          else if (sizeof (EMACS_INT) > sizeof (long))
+            {
+              mpz_t tem;
+              mpz_init (tem);
+              mpz_set_intmax (tem, XINT (val));
+              mpz_sub (accum, accum, tem);
+              mpz_clear (tem);
+            }
           else if (XINT (val) < 0)
             mpz_add_ui (accum, accum, - XINT (val));
           else
@@ -2896,6 +2932,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
         case Amult:
           if (BIGNUMP (val))
             mpz_mul (accum, accum, XBIGNUM (val)->value);
+          else if (sizeof (EMACS_INT) > sizeof (long))
+            {
+              mpz_t tem;
+              mpz_init (tem);
+              mpz_set_intmax (tem, XINT (val));
+              mpz_mul (accum, accum, tem);
+              mpz_clear (tem);
+            }
           else
             mpz_mul_si (accum, accum, XINT (val));
           break;
@@ -2915,6 +2959,14 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
                 xsignal0 (Qarith_error);
               if (BIGNUMP (val))
                 mpz_tdiv_q (accum, accum, XBIGNUM (val)->value);
+              else if (sizeof (EMACS_INT) > sizeof (long))
+                {
+                  mpz_t tem;
+                  mpz_init (tem);
+                  mpz_set_intmax (tem, XINT (val));
+                  mpz_tdiv_q (accum, accum, tem);
+                  mpz_clear (tem);
+                }
               else
                 {
                   EMACS_INT value = XINT (val);
@@ -2982,8 +3034,9 @@ float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code,
 
   for (; argnum < nargs; argnum++)
     {
-      val = args[argnum];    /* using args[argnum] as argument to CHECK_FIXNUM_... */
-      CHECK_FIXNUM_OR_FLOAT_COERCE_MARKER (val);
+      /* using args[argnum] as argument to CHECK_NUMBER_... */
+      val = args[argnum];
+      CHECK_NUMBER_COERCE_MARKER (val);
 
       if (FLOATP (val))
         {
@@ -3277,7 +3330,7 @@ representation.  */)
 
   if (BIGNUMP (value))
     {
-      if (mpz_cmp_si (XBIGNUM (value)->value, 0) >= 0)
+      if (mpz_sgn (XBIGNUM (value)->value) >= 0)
         return make_fixnum (mpz_popcount (XBIGNUM (value)->value));
       mpz_t tem;
       mpz_init (tem);
@@ -3314,8 +3367,10 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
       mpz_init (result);
       if (XINT (count) >= 0)
         mpz_mul_2exp (result, XBIGNUM (value)->value, XINT (count));
-      else
+      else if (lsh)
         mpz_tdiv_q_2exp (result, XBIGNUM (value)->value, - XINT (count));
+      else
+        mpz_fdiv_q_2exp (result, XBIGNUM (value)->value, - XINT (count));
       val = make_number (result);
       mpz_clear (result);
     }
@@ -3325,14 +3380,21 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
       mpz_t result;
       eassume (FIXNUMP (value));
       mpz_init (result);
-      if (lsh)
-        mpz_set_uintmax (result, XUINT (value));
-      else
-        mpz_set_intmax (result, XINT (value));
+
+      mpz_set_intmax (result, XINT (value));
+
       if (XINT (count) >= 0)
         mpz_mul_2exp (result, result, XINT (count));
-      else
-        mpz_tdiv_q_2exp (result, result, - XINT (count));
+      else if (lsh)
+        {
+          if (mpz_sgn (result) > 0)
+            mpz_fdiv_q_2exp (result, result, - XINT (count));
+          else
+            mpz_fdiv_q_2exp (result, result, - XINT (count));
+        }
+      else /* ash */
+        mpz_fdiv_q_2exp (result, result, - XINT (count));
+
       val = make_number (result);
       mpz_clear (result);
     }
@@ -3414,7 +3476,7 @@ Markers are converted to integers.  */)
   else
     {
       eassume (FIXNUMP (number));
-      if (XINT (number) > MOST_POSITIVE_FIXNUM)
+      if (XINT (number) > MOST_NEGATIVE_FIXNUM)
         XSETINT (number, XINT (number) - 1);
       else
         {
diff --git a/src/lisp.h b/src/lisp.h
index 4208634fa95..b404f9d89aa 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2778,7 +2778,7 @@ NATNUMP (Lisp_Object x)
 INLINE bool
 NUMBERP (Lisp_Object x)
 {
-  return INTEGERP (x) || FLOATP (x) || BIGNUMP (x);
+  return INTEGERP (x) || FLOATP (x);
 }
 
 INLINE bool
@@ -2947,7 +2947,7 @@ CHECK_INTEGER (Lisp_Object x)
     if (MARKERP (x))                                                    \
       XSETFASTINT (x, marker_position (x));                             \
     else                                                                \
-      CHECK_TYPE (FIXED_OR_FLOATP (x), Qnumber_or_marker_p, x);                 \
+      CHECK_TYPE (FIXED_OR_FLOATP (x), Qnumber_or_marker_p, x);         \
   } while (false)
 
 #define CHECK_NUMBER_COERCE_MARKER(x)                                   \
diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el
new file mode 100644
index 00000000000..d0c254ce91b
--- /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))))