fx* now detects overflow.

This commit is contained in:
Abdulaziz Ghuloum 2008-02-12 14:46:18 -05:00
parent 3811d0a4c2
commit 1683997a12
6 changed files with 41 additions and 9 deletions

Binary file not shown.

View File

@ -26,13 +26,13 @@
fixnum->string
fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
fxmin fxmax
error@fx+)
error@fx+ error@fx*)
(import
(ikarus system $fx)
(ikarus system $chars)
(ikarus system $pairs)
(ikarus system $strings)
(prefix (only (ikarus) fx+) sys:)
(prefix (only (ikarus) fx+ fx*) sys:)
(except (ikarus) fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx*
fxquotient fxremainder fxmodulo fxlogor fxlogand
fxlogxor fxsll fxsra fx= fx< fx<= fx> fx>=
@ -76,14 +76,23 @@
(die 'fxnot "not a fixnum" x))
($fxlognot x)))
(define error@fx+
(lambda (x y)
(if (fixnum? x)
(if (fixnum? x)
(if (fixnum? y)
(die 'fx+ "overflow when adding numbers" x y)
(die 'fx+ "not a fixnum" y))
(die 'fx+ "not a fixnum" x))))
(define error@fx*
(lambda (x y)
(if (fixnum? x)
(if (fixnum? y)
(die 'fx* "overflow when multiplying numbers" x y)
(die 'fx* "not a fixnum" y))
(die 'fx* "not a fixnum" x))))
(define fx+
(lambda (x y)
(sys:fx+ x y)))
@ -98,11 +107,7 @@
(define fx*
(lambda (x y)
(unless (fixnum? x)
(die 'fx* "not a fixnum" x))
(unless (fixnum? y)
(die 'fx* "not a fixnum" y))
($fx* x y)))
(sys:fx* x y)))
(define false-loop

View File

@ -1 +1 @@
1378
1379

View File

@ -565,6 +565,7 @@
[make-promise ]
[make-traced-procedure i]
[error@fx+ ]
[error@fx* ]
[fasl-write i]
[lambda i r ba se ne]
[and i r ba se ne]

View File

@ -1248,6 +1248,31 @@
(define-primop fx+ safe
[(V x y) (cogen-value-+ x y)])
(define-primop fx* safe
[(V a b)
(struct-case a
[(constant ak)
(cond
[(fx? ak)
(with-tmp ([b (T b)])
(assert-fixnum b)
(prm 'int*/overflow b a))]
[else (interrupt)])]
[else
(struct-case b
[(constant bk)
(cond
[(fx? bk)
(with-tmp ([a (T a)])
(assert-fixnum a)
(prm 'int*/overflow a b))]
[else (interrupt)])]
[else
(with-tmp ([a (T a)] [b (T b)])
(assert-fixnum a)
(assert-fixnum b)
(prm 'int*/overflow
(prm 'sra a (K fx-shift)) b))])])])
(define-primop zero? safe
[(P x)

View File

@ -56,6 +56,7 @@
(define (primop-interrupt-handler x)
(case x
[(fx+) 'error@fx+]
[(fx*) 'error@fx*]
[else x]))
(define (make-interrupt-call op args)
(make-funcall