suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

repairs for arithmetic-shift

Browse Source 
Produce 0, -1, or out-of-memory for bignum shifts. For large fixnum
shifts, check memory limits.

The repairs are mostly for Racket CS, but traditional Racket
incorrectly reported out-of-memory for 0 shifted by a positive bignum.
This commit is contained in:
Matthew Flatt 2020-01-26 08:14:56 -07:00
parent 04af7b3b2d
commit c48afdb16b
3 changed files with 35 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-test-core/tests/racket/number.rktl
View File

@ -1289,14 +1289,20 @@
(test 0 arithmetic-shift 42 (+ i (- (expt 2 31))))
(test 0 arithmetic-shift 42 (+ i (- (expt 2 63)))))
(test 0 arithmetic-shift 0 (expt 2 100))
(test 0 arithmetic-shift 0 (- (expt 2 100)))
(test 0 arithmetic-shift 1 (- (expt 2 100)))
(test 0 arithmetic-shift (expt 2 100) (- (expt 2 100)))
(test -1 arithmetic-shift -1 (- (expt 2 100)))
(test -1 arithmetic-shift (- (expt 2 100)) (- (expt 2 100)))
(arity-test arithmetic-shift 2 2)
(err/rt-test (arithmetic-shift "a" 1))
(err/rt-test (arithmetic-shift 1 "a"))
(err/rt-test (arithmetic-shift 1.0 1))
(err/rt-test (arithmetic-shift 1 1.0))
(err/rt-test (arithmetic-shift 1 1.0+0.0i))
(unless (eq? 'chez-scheme (system-type 'vm))
(err/rt-test (eval '(arithmetic-shift 1 (expt 2 80))) exn:fail:out-of-memory?))
(err/rt-test (eval '(arithmetic-shift 1 (expt 2 80))) exn:fail:out-of-memory?)
(test #f bitwise-bit-set? 13 1)
(test #t bitwise-bit-set? 13 2)

29
racket/src/cs/rumble/number.ss
View File

@ -36,14 +36,35 @@
(#3%fxsra x max-fx-shift)
(#3%fxsra x (#3%fx- n)))
(if (#3%fx> n max-fx-shift)
(#3%bitwise-arithmetic-shift x n)
(general-arithmetic-shift x n)
(let ([m (#3%fxsll x n)])
(if (#3%fx= (#3%fxsra m n) x)
m
(#3%bitwise-arithmetic-shift x n))))))
(#2%bitwise-arithmetic-shift x n)))]
[(_ expr ...) #'(#2%bitwise-arithmetic-shift expr ...)]
[_ #'#2%bitwise-arithmetic-shift]))
(general-arithmetic-shift x n)))]
[(_ expr ...) #'(general-arithmetic-shift expr ...)]
[_ #'general-arithmetic-shift]))
(define general-arithmetic-shift
(|#%name|
arithmetic-shift
(lambda (x n)
(cond
[(not (exact-integer? x))
(#2%bitwise-arithmetic-shift x n)]
[(fixnum? n)
(unless (or (eqv? x 0) (fx< n 1000))
(guard-large-allocation 'arithmetic-shift 'number n 1))
(#2%bitwise-arithmetic-shift x n)]
[(and (not (eqv? x 0))
(bignum? n)
(positive? n))
(raise (|#%app|
exn:fail:out-of-memory
"arithmetic-shift: out of memory"
(current-continuation-marks)))]
[else
(#2%bitwise-arithmetic-shift x n)]))))
(define-syntax-rule (define-bitwise op fxop)
(...

2
racket/src/racket/src/number.c
View File

@ -4281,6 +4281,8 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[])
return scheme_make_integer(-1);
else
return scheme_make_integer(0);
} else if (SAME_OBJ(v, scheme_exact_zero)) {
return scheme_make_integer(0);
} else
scheme_raise_out_of_memory("arithmetic-shift", NULL);
} else