conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixed the bahavior of fxaithmetic-shift{-left,-right,} when the 

shift amount is not in range and when the result overflows.
This commit is contained in:
Abdulaziz Ghuloum 2009-08-26 18:04:18 +03:00
parent b1c9fda05c
commit c0233db219
7 changed files with 87 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.4.prebuilt
View File

Binary file not shown.

BIN
scheme/ikarus.boot.8.prebuilt
View File

Binary file not shown.

91
scheme/ikarus.fixnums.ss
View File

@ -27,7 +27,9 @@
fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
fxmin fxmax fxmin fxmax
error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1 error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1
error@fxarithmetic-shift-left error@fxarithmetic-shift-left
error@fxarithmetic-shift-right
) )
(import (import
(ikarus system $fx) (ikarus system $fx)
@ -47,6 +49,14 @@
fxmin fxmax fxmin fxmax
fixnum->string)) fixnum->string))
(define (die/overflow who . args)
(raise
(condition
(make-implementation-restriction-violation)
(make-who-condition who)
(make-message-condition "overflow")
(make-irritants-condition args))))
(define fxzero? (define fxzero?
(lambda (x) (lambda (x)
(cond (cond
@ -67,27 +77,24 @@
(die 'fxnot "not a fixnum" x)) (die 'fxnot "not a fixnum" x))
($fxlognot x))) ($fxlognot x)))
(define (make-fx-error who msg) (define (make-fx-error who)
(case-lambda (case-lambda
[(x y) [(x y)
(if (fixnum? x) (if (fixnum? x)
(if (fixnum? y) (if (fixnum? y)
(die who msg x y) (die/overflow who x y)
(die who "not a fixnum" y)) (die who "not a fixnum" y))
(die who "not a fixnum" x))] (die who "not a fixnum" x))]
[(x) [(x)
(if (fixnum? x) (if (fixnum? x)
(die who msg x) (die/overflow who x)
(die who "not a fixnum" x))])) (die who "not a fixnum" x))]))
(define error@fx+ (define error@fx+ (make-fx-error 'fx+))
(make-fx-error 'fx+ "overflow during addition")) (define error@fx- (make-fx-error 'fx-))
(define error@fx* (make-fx-error 'fx*))
(define error@fx- (define error@fxadd1 (make-fx-error 'fxadd1))
(make-fx-error 'fx- "overflow during subtraction")) (define error@fxsub1 (make-fx-error 'fxsub1))
(define error@fx*
(make-fx-error 'fx* "overflow during multiplication"))
(define (fx+ x y) (sys:fx+ x y)) (define (fx+ x y) (sys:fx+ x y))
@ -98,12 +105,6 @@
[(x y) (sys:fx- x y)] [(x y) (sys:fx- x y)]
[(x) (sys:fx- x)])) [(x) (sys:fx- x)]))
(define error@fxadd1
(make-fx-error 'fxadd1 "overflow during addition"))
(define error@fxsub1
(make-fx-error 'fxsub1 "overflow during subtraction"))
(define fxadd1 (define fxadd1
(lambda (n) (lambda (n)
(import (ikarus)) (import (ikarus))
@ -173,7 +174,7 @@
(die 'fxquotient "zero dividend" y)) (die 'fxquotient "zero dividend" y))
(if (eq? y -1) (if (eq? y -1)
(if (eq? x (least-fixnum)) (if (eq? x (least-fixnum))
(die 'fxquotient "overflow" x y) (die/overflow 'fxquotient x y)
($fx- 0 x)) ($fx- 0 x))
($fxquotient x y)))) ($fxquotient x y))))
@ -255,13 +256,8 @@
(define fxarithmetic-shift-right (define fxarithmetic-shift-right
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (import (ikarus))
(die 'fxarithmetic-shift-right "not a fixnum" x)) (fxarithmetic-shift-right x y)))
(unless (fixnum? y)
(die 'fxarithmetic-shift-right "not a fixnum" y))
(unless ($fx>= y 0)
(die 'fxarithmetic-shift-right "negative shift not allowed" y))
($fxsra x y)))
(define fxsll (define fxsll
(lambda (x y) (lambda (x y)
@ -273,37 +269,48 @@
(die 'fxsll "negative shift not allowed" y)) (die 'fxsll "negative shift not allowed" y))
($fxsll x y))) ($fxsll x y)))
(define (error@fxarithmetic-shift-left x y)
(define (error@fxarithmetic-shift who x y)
(unless (fixnum? x) (unless (fixnum? x)
(die 'fxarithmetic-shift-left "not a fixnum" x)) (die who "not a fixnum" x))
(unless (fixnum? y) (unless (fixnum? y)
(die 'fxarithmetic-shift-left "not a fixnum" y)) (die who "not a fixnum" y))
(unless ($fx>= y 0) (unless ($fx>= y 0)
(die 'fxarithmetic-shift-left "negative shift not allowed" y)) (die who "negative shift not allowed" y))
(unless ($fx< y (fixnum-width)) (unless ($fx< y (fixnum-width))
(die 'fxarithmetic-shift-left (die who "shift is not less than fixnum-width" y))
"shift is not less than fixnum-width" y)) (die/overflow who x y))
(die 'fxarithmetic-shift-left "overflow" x y))
(define (error@fxarithmetic-shift-left x y)
(error@fxarithmetic-shift 'arithmetic-shift-left x y))
(define (error@fxarithmetic-shift-right x y)
(error@fxarithmetic-shift 'arithmetic-shift-right x y))
(define fxarithmetic-shift-left (define fxarithmetic-shift-left
(lambda (x y) (lambda (x y)
(import (ikarus)) (import (ikarus))
(fxarithmetic-shift-left x y))) (fxarithmetic-shift-left x y)))
(define fxarithmetic-shift (define fxarithmetic-shift
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (import (ikarus))
(die 'fxarithmetic-shift "not a fixnum" x)) (define (err str x) (die 'fxarithmetic-shift str x))
(unless (fixnum? y) (unless (fixnum? x) (err "not a fixnum" x))
(die 'fxarithmetic-shift "not a fixnum" y)) (unless (fixnum? y) (err "not a fixnum" y))
(if ($fx>= y 0) (if ($fx>= y 0)
($fxsll x y) (if ($fx< y (fixnum-width))
(if ($fx< x -100) ;;; arbitrary number < (fixnum-width) (let ([r ($fxsll x y)])
($fxsra x 32) (if ($fx= x ($fxsra r y))
($fxsra x ($fx- 0 y)))))) r
(die/overflow 'fxarithmetic-shift x y)))
(err "invalid shift amount" y))
(if ($fx> y (- (fixnum-width)))
($fxsra x ($fx- 0 y))
(err "invalid shift amount" y)))))
(define (fxpositive? x) (define (fxpositive? x)
(if (fixnum? x) (if (fixnum? x)
($fx> x 0) ($fx> x 0)
(die 'fxpositive? "not a fixnum" x))) (die 'fxpositive? "not a fixnum" x)))

2
scheme/last-revision
View File

@ -1 +1 @@
1845 1846

1
scheme/makefile.ss
View File

@ -617,6 +617,7 @@
[make-traced-macro i] [make-traced-macro i]
[error@fx+ ] [error@fx+ ]
[error@fxarithmetic-shift-left ] [error@fxarithmetic-shift-left ]
[error@fxarithmetic-shift-right ]
[error@fx* ] [error@fx* ]
[error@fx- ] [error@fx- ]
[error@add1 ] [error@add1 ]

27
scheme/pass-specify-rep-primops.ss
View File

@ -1592,6 +1592,33 @@
x2)))])]) x2)))])])
(define-primop fxarithmetic-shift-right safe
[(V x n)
(struct-case n
[(constant i)
(cond
[(and (fx? i)
(>= i 0)
(< i (- (* wordsize 8) fx-shift)))
(prm 'sll
(prm 'sra (T x) (K (+ i fx-shift)))
(K fx-shift))]
[else
(interrupt)])]
[else
(with-tmp ([x (T x)] [n (T n)])
(assert-fixnums x (list n))
(with-tmp ([n (prm 'sra n (K fx-shift))])
(interrupt-when
(prm '< n (K 0)))
(interrupt-when
(prm '>= n (K (- (* wordsize 8) fx-shift))))
(prm 'sll
(prm 'sra x n)
(K fx-shift))))])])
(define (log2 n) (define (log2 n)
(let f ([n n] [i 0]) (let f ([n n] [i 0])
(cond (cond

17
scheme/pass-specify-rep.ss
View File

@ -212,14 +212,15 @@
(module (cogen-primop cogen-debug-primop) (module (cogen-primop cogen-debug-primop)
(define (primop-interrupt-handler x) (define (primop-interrupt-handler x)
(case x (case x
[(fx+) 'error@fx+] [(fx+) 'error@fx+]
[(fx-) 'error@fx-] [(fx-) 'error@fx-]
[(fx*) 'error@fx*] [(fx*) 'error@fx*]
[(add1) 'error@add1] [(add1) 'error@add1]
[(sub1) 'error@sub1] [(sub1) 'error@sub1]
[(fxadd1) 'error@fxadd1] [(fxadd1) 'error@fxadd1]
[(fxsub1) 'error@fxsub1] [(fxsub1) 'error@fxsub1]
[(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left] [(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
[(fxarithmetic-shift-right) 'error@fxarithmetic-shift-right]
[else x])) [else x]))
(define (make-interrupt-call op args) (define (make-interrupt-call op args)
(make-funcall (make-funcall