Commit bc8ff54e authored by Andy Moreton's avatar Andy Moreton Committed by Tom Tromey
Browse files

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.
parent 76715f89
......@@ -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 ()
......
......@@ -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
......
......@@ -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))
{
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));
......@@ -2424,6 +2435,15 @@ bignumcompare (Lisp_Object num1, Lisp_Object num2,
else
{
eassume (FIXNUMP (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));
}
}
......@@ -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,6 +2891,14 @@ 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 (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
......@@ -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));
if (XINT (count) >= 0)
mpz_mul_2exp (result, result, XINT (count));
else if (lsh)
{
if (mpz_sgn (result) > 0)
mpz_fdiv_q_2exp (result, result, - XINT (count));
else
mpz_tdiv_q_2exp (result, result, - XINT (count));
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
{
......
......@@ -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
......
(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))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment