fx* now detects overflow.

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

scheme/last-revision

@@ -1 +1 @@
-1378
+1379

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]

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)

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