* 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.
(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)))
(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)
`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
(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 ()
}
}
+ /* 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
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));
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)
{
/* 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,
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));
}
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
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;
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);
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))
{
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);
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);
}
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);
}
else
{
eassume (FIXNUMP (number));
- if (XINT (number) > MOST_POSITIVE_FIXNUM)
+ if (XINT (number) > MOST_NEGATIVE_FIXNUM)
XSETINT (number, XINT (number) - 1);
else
{
INLINE bool
NUMBERP (Lisp_Object x)
{
- return INTEGERP (x) || FLOATP (x) || BIGNUMP (x);
+ return INTEGERP (x) || FLOATP (x);
}
INLINE bool
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) \
--- /dev/null
+(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))))
projects / emacs.git / commitdiff