* Added fx+/carry, fx*/carry, and fx-/carry (with tests)

src/ikarus.fixnums.ss

@@ -1,6 +1,7 @@
 
 (library (ikarus fixnums)
   (export fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx* fxquotient
+          fx+/carry fx*/carry fx-/carry
           fxremainder fxmodulo fxlogor fxlogand fxlogxor fxsll fxsra
           fx= fx< fx<= fx> fx>= 
           fx=? fx<? fx<=? fx>? fx>=? 
@@ -25,6 +26,7 @@
             fxpositive? fxnegative?
             fxeven? fxodd?
             fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
+            fx+/carry fx*/carry fx-/carry
             fxmin fxmax
             fixnum->string))
 
@@ -320,6 +322,24 @@
              (error 'fxmax "~s is not a fixnum" z)))]
       [(x) (if (fixnum? x) x (error 'fxmax "~s is not a fixnum" x))]))
 
+  (define (fx*/carry fx1 fx2 fx3)
+    (let ([s0 ($fx+ ($fx* fx1 fx2) fx3)])
+      (values 
+        s0
+        (sra (+ (* fx1 fx2) (- fx3 s0)) (fixnum-width)))))
+  
+  (define (fx+/carry fx1 fx2 fx3)
+    (let ([s0 ($fx+ ($fx+ fx1 fx2) fx3)])
+      (values 
+        s0
+        (sra (+ (+ fx1 fx2) (- fx3 s0)) (fixnum-width)))))
+  
+  (define (fx-/carry fx1 fx2 fx3)
+    (let ([s0 ($fx- ($fx- fx1 fx2) fx3)])
+      (values 
+        s0
+        (sra (- (- fx1 fx2) (+ s0 fx3)) (fixnum-width)))))
+
   (module (fixnum->string)
     (define f
       (lambda (n i j)
@@ -353,4 +373,5 @@
                ($string-set! str 0 #\-)
                str))]))))
 
+
   )

src/makefile.ss

@@ -462,6 +462,10 @@
     [fixnum-width    i]
     [least-fixnum    i]
     [greatest-fixnum i]
+            
+    [fx+/carry  i]
+    [fx*/carry  i]
+    [fx-/carry  i]
 
     [for-each                i r]
     [map                     i r]

src/run-tests.ss

@@ -6,6 +6,7 @@
         (tests strings)
         (tests numbers)
         (tests bignums)
+        (tests fxcarry)
         (tests bignum-to-flonum)
         (tests string-to-number))
 
@@ -30,4 +31,5 @@
 (test-string-to-number)
 (test-div-and-mod)
 (test-bignums)
+(test-fxcarry)
 (printf "Happy Happy Joy Joy\n")

src/tests/fxcarry.ss

@@ -0,0 +1,61 @@
+
+(library (tests fxcarry)
+  (export test-fxcarry)
+  (import (ikarus) (tests framework))
+
+
+(define (fx*/carry-reference fx1 fx2 fx3)
+  (let* ([s (+ (* fx1 fx2) fx3)]
+         [s0 (mod0 s (expt 2 (fixnum-width)))]
+         [s1 (div0 s (expt 2 (fixnum-width)))])
+    (values s0 s1)))
+
+(define (fx+/carry-reference fx1 fx2 fx3)
+  (let* ([s (+ (+ fx1 fx2) fx3)]
+         [s0 (mod0 s (expt 2 (fixnum-width)))]
+         [s1 (div0 s (expt 2 (fixnum-width)))])
+    (values s0 s1)))
+
+(define (fx-/carry-reference fx1 fx2 fx3)
+  (let* ([s (- (- fx1 fx2) fx3)]
+         [s0 (mod0 s (expt 2 (fixnum-width)))]
+         [s1 (div0 s (expt 2 (fixnum-width)))])
+    (values s0 s1)))
+
+(define (test name fxop/carry fxop/carry-reference fx1 fx2 fx3)
+  (let-values ([(s0 s1) (fxop/carry fx1 fx2 fx3)]
+               [(s2 s3) (fxop/carry-reference fx1 fx2 fx3)])
+    (unless (fx= s0 s2) 
+      (error name "failed (value1) on ~s ~s ~s, got ~s, should be ~s" 
+        fx1 fx2 fx3 s0 s2))
+    (unless (fx= s1 s3) 
+      (error name "failed (value2) on ~s ~s ~s, got ~s, should be ~s" 
+        fx1 fx2 fx3 s1 s3))))
+
+(define ls 
+  (list 0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)))
+
+(define (test-fxcarry)
+  (printf "[~s: test-fxcarry] " (expt (length ls) 3))
+  (for-each 
+    (lambda (fx1)
+      (for-each 
+        (lambda (fx2)
+          (for-each 
+            (lambda (fx3)
+              (test 'fx*/carry fx*/carry fx*/carry-reference fx1 fx2 fx3)
+              (test 'fx+/carry fx+/carry fx+/carry-reference fx1 fx2 fx3)
+              (test 'fx-/carry fx-/carry fx-/carry-reference fx1 fx2 fx3))
+            ls))
+        ls))
+    ls)
+  (printf "Happy Happy Joy Joy\n"))
+
+)
+
+#!eof
+
+(define (t x)
+  (= (fxsra (fx+ x 1) 1) 
+     (quotient x 2)))
+

src/todo-r6rs.ss

@@ -261,11 +261,11 @@
     [least-fixnum                               C fx] 
     [greatest-fixnum                            C fx] 
     [fx*                                        C fx]
-    [fx*/carry                                  D fx]
+    [fx*/carry                                  C fx]
     [fx+                                        C fx]
-    [fx+/carry                                  D fx]
+    [fx+/carry                                  C fx]
     [fx-                                        C fx]
-    [fx-/carry                                  D fx]
+    [fx-/carry                                  C fx]
     [fx<=?                                      C fx]
     [fx<?                                       C fx]
     [fx=?                                       C fx]