fx* now detects overflow.
This commit is contained in:
parent
3811d0a4c2
commit
1683997a12
Binary file not shown.
|
@ -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
|
||||
|
|
|
@ -1 +1 @@
|
|||
1378
|
||||
1379
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue