diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index 29dc642..396601f 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.fixnums.ss b/scheme/ikarus.fixnums.ss index 1f9e95d..ff39c35 100644 --- a/scheme/ikarus.fixnums.ss +++ b/scheme/ikarus.fixnums.ss @@ -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 diff --git a/scheme/last-revision b/scheme/last-revision index 30ed602..e4f0a85 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1378 +1379 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 9649354..4c24544 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 41dbd80..794412d 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -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) diff --git a/scheme/pass-specify-rep.ss b/scheme/pass-specify-rep.ss index 1578192..ead91b1 100644 --- a/scheme/pass-specify-rep.ss +++ b/scheme/pass-specify-rep.ss @@ -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