diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index d2f490d59c..3529dd9c30 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -184,11 +184,15 @@ ccl-program-vector (defvar ccl-current-ic 0 "The current index for `ccl-program-vector'.") +(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 +200,7 @@ ccl-embed-data (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 +234,8 @@ ccl-embed-current-address `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 +991,8 @@ ccl-dump (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 1dc1bbb031..4c794048be 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 0deebdca1a..6ca868a938 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,18 @@ 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 +2879,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 +2890,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 +2915,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 +2931,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 +2958,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 +3033,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 +3329,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 +3366,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 +3379,19 @@ 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 +3473,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 4208634fa9..b404f9d89a 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) \