summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/lispref/numbers.texi7
-rw-r--r--lisp/subr.el12
-rw-r--r--src/data.c60
-rw-r--r--test/lisp/international/ccl-tests.el21
-rw-r--r--test/src/data-tests.el16
5 files changed, 59 insertions, 57 deletions
diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi
index 37d2c316490..ee6456b1be1 100644
--- a/doc/lispref/numbers.texi
+++ b/doc/lispref/numbers.texi
@@ -844,7 +844,9 @@ bits in @var{integer1} to the left @var{count} places, or to the right
if @var{count} is negative, bringing zeros into the vacated bits. If
@var{count} is negative, @code{lsh} shifts zeros into the leftmost
(most-significant) bit, producing a nonnegative result even if
-@var{integer1} is negative. Contrast this with @code{ash}, below.
+@var{integer1} is negative fixnum. (If @var{integer1} is a negative
+bignum, @var{count} must be nonnegative.) Contrast this with
+@code{ash}, below.
Here are two examples of @code{lsh}, shifting a pattern of bits one
place to the left. We show only the low-order eight bits of the binary
@@ -913,7 +915,8 @@ is negative.
@code{ash} gives the same results as @code{lsh} except when
@var{integer1} and @var{count} are both negative. In that case,
@code{ash} puts ones in the empty bit positions on the left, while
-@code{lsh} puts zeros in those bit positions.
+@code{lsh} puts zeros in those bit positions and requires
+@var{integer1} to be a fixnum.
Thus, with @code{ash}, shifting the pattern of bits one place to the right
looks like this:
diff --git a/lisp/subr.el b/lisp/subr.el
index fbb3e49a35c..cafa4835eaf 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -366,6 +366,18 @@ was called."
(declare (compiler-macro (lambda (_) `(= 0 ,number))))
(= 0 number))
+(defun lsh (value count)
+ "Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, if VALUE is a negative fixnum treat it as unsigned,
+i.e., subtract 2 * most-negative-fixnum from VALUE before shifting it."
+ (when (and (< value 0) (< count 0))
+ (when (< value most-negative-fixnum)
+ (signal 'args-out-of-range (list value count)))
+ (setq value (logand (ash value -1) most-positive-fixnum))
+ (setq count (1+ count)))
+ (ash value count))
+
;;;; List functions.
diff --git a/src/data.c b/src/data.c
index 5a355d9787c..a39978ab1dc 100644
--- a/src/data.c
+++ b/src/data.c
@@ -3365,30 +3365,44 @@ representation. */)
: count_one_bits_ll (v));
}
-static Lisp_Object
-ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
+DEFUN ("ash", Fash, Sash, 2, 2, 0,
+ doc: /* Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, the sign bit is duplicated. */)
+ (Lisp_Object value, Lisp_Object count)
{
- /* This code assumes that signed right shifts are arithmetic. */
- verify ((EMACS_INT) -1 >> 1 == -1);
-
Lisp_Object val;
+ /* The negative of the minimum value of COUNT that fits into a fixnum,
+ such that mpz_fdiv_q_exp supports -COUNT. */
+ EMACS_INT minus_count_min = min (-MOST_NEGATIVE_FIXNUM,
+ TYPE_MAXIMUM (mp_bitcnt_t));
CHECK_INTEGER (value);
- CHECK_FIXNUM (count);
+ CHECK_RANGED_INTEGER (count, - minus_count_min, TYPE_MAXIMUM (mp_bitcnt_t));
if (BIGNUMP (value))
{
+ if (XFIXNUM (count) == 0)
+ return value;
mpz_t result;
mpz_init (result);
- if (XFIXNUM (count) >= 0)
+ if (XFIXNUM (count) > 0)
mpz_mul_2exp (result, XBIGNUM (value)->value, XFIXNUM (count));
- else if (lsh)
- mpz_tdiv_q_2exp (result, XBIGNUM (value)->value, - XFIXNUM (count));
else
mpz_fdiv_q_2exp (result, XBIGNUM (value)->value, - XFIXNUM (count));
val = make_number (result);
mpz_clear (result);
}
+ else if (XFIXNUM (count) <= 0)
+ {
+ /* This code assumes that signed right shifts are arithmetic. */
+ verify ((EMACS_INT) -1 >> 1 == -1);
+
+ EMACS_INT shift = -XFIXNUM (count);
+ EMACS_INT result = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
+ : XFIXNUM (value) < 0 ? -1 : 0);
+ val = make_fixnum (result);
+ }
else
{
/* Just do the work as bignums to make the code simpler. */
@@ -3400,14 +3414,7 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
if (XFIXNUM (count) >= 0)
mpz_mul_2exp (result, result, XFIXNUM (count));
- else if (lsh)
- {
- if (mpz_sgn (result) > 0)
- mpz_fdiv_q_2exp (result, result, - XFIXNUM (count));
- else
- mpz_fdiv_q_2exp (result, result, - XFIXNUM (count));
- }
- else /* ash */
+ else
mpz_fdiv_q_2exp (result, result, - XFIXNUM (count));
val = make_number (result);
@@ -3417,24 +3424,6 @@ ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh)
return val;
}
-DEFUN ("ash", Fash, Sash, 2, 2, 0,
- doc: /* Return VALUE with its bits shifted left by COUNT.
-If COUNT is negative, shifting is actually to the right.
-In this case, the sign bit is duplicated. */)
- (register Lisp_Object value, Lisp_Object count)
-{
- return ash_lsh_impl (value, count, false);
-}
-
-DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
- doc: /* Return VALUE with its bits shifted left by COUNT.
-If COUNT is negative, shifting is actually to the right.
-In this case, zeros are shifted in on the left. */)
- (register Lisp_Object value, Lisp_Object count)
-{
- return ash_lsh_impl (value, count, true);
-}
-
DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
Markers are converted to integers. */)
@@ -4235,7 +4224,6 @@ syms_of_data (void)
defsubr (&Slogior);
defsubr (&Slogxor);
defsubr (&Slogcount);
- defsubr (&Slsh);
defsubr (&Sash);
defsubr (&Sadd1);
defsubr (&Ssub1);
diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el
index b41b8c1ff64..7dd7224726b 100644
--- a/test/lisp/international/ccl-tests.el
+++ b/test/lisp/international/ccl-tests.el
@@ -37,18 +37,9 @@
;; 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)
- ))
+ (should (= (lsh -5628 -8)
+ (ash (- -5628 (ash most-negative-fixnum 1)) -8)
+ (ash (logand (ash -5628 -1) most-positive-fixnum) -7))))
;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el
(defconst prog-pgg-source
@@ -177,11 +168,11 @@ At EOF:
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.
+(concat "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 12 15 18 22 ""
11:[jump] jump to 2(-9)
12:[set-register] r1 = r0
13:[set-register] r0 = r4
@@ -227,7 +218,7 @@ Main-body:
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)))
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index a4c6b0e4915..85cbab26106 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -598,7 +598,9 @@ comparing the subr with a much slower lisp implementation."
(should (fixnump (1- (1+ most-positive-fixnum)))))
(ert-deftest data-tests-logand ()
- (should (= -1 (logand -1)))
+ (should (= -1 (logand) (logand -1) (logand -1 -1)))
+ (let ((n (1+ most-positive-fixnum)))
+ (should (= (logand -1 n) n)))
(let ((n (* 2 most-negative-fixnum)))
(should (= (logand -1 n) n))))
@@ -606,11 +608,11 @@ comparing the subr with a much slower lisp implementation."
(should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128)))
(ert-deftest data-tests-logior ()
- (should (= -1 (logior -1)))
+ (should (= -1 (logior -1) (logior -1 -1)))
(should (= -1 (logior most-positive-fixnum most-negative-fixnum))))
(ert-deftest data-tests-logxor ()
- (should (= -1 (logxor -1)))
+ (should (= -1 (logxor -1) (logxor -1 -1 -1)))
(let ((n (1+ most-positive-fixnum)))
(should (= (logxor -1 n) (lognot n)))))
@@ -642,6 +644,12 @@ comparing the subr with a much slower lisp implementation."
(should (= (ash most-negative-fixnum 1)
(* most-negative-fixnum 2)))
(should (= (lsh most-negative-fixnum 1)
- (* most-negative-fixnum 2))))
+ (* most-negative-fixnum 2)))
+ (should (= (ash (* 2 most-negative-fixnum) -1)
+ most-negative-fixnum))
+ (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2)))
+ (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1)))
+ (should (= (lsh -1 -1) most-positive-fixnum))
+ (should-error (lsh (1- most-negative-fixnum) -1)))
;;; data-tests.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-22 21:04:46 +0000