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

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

@ -1592,6 +1592,33 @@
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)
(let f ([n n] [i 0])
(cond

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

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