From ab6c871d7651bf280593f5eb5110c6b9a7989059 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 15 Nov 2007 07:03:04 -0500
Subject: [PATCH] * Added fxcopy-bit-field.

---
 scheme/ikarus.numerics.ss | 33 +++++++++++++++++++++++++++++++--
 scheme/makefile.ss        |  2 +-
 scheme/todo-r6rs.ss       |  2 +-
 3 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss
index 5ca9055..135ea47 100644
--- a/scheme/ikarus.numerics.ss
+++ b/scheme/ikarus.numerics.ss
@@ -2890,7 +2890,8 @@
           fxbit-count bitwise-bit-count
           fxlength
           fxbit-set?
-          fxcopy-bit)
+          fxcopy-bit
+          fxcopy-bit-field)
   (import 
     (ikarus system $fx)
     (ikarus system $bignums)
@@ -2900,7 +2901,8 @@
       fxbit-count bitwise-bit-count
       fxlength
       fxbit-set?
-      fxcopy-bit))
+      fxcopy-bit
+      fxcopy-bit-field))
 
   (module (bitwise-first-bit-set fxfirst-bit-set)
     (define (byte-first-bit-set x i) 
@@ -3026,6 +3028,33 @@
                 (error who "index out of range" i))
             (error who "index is not a fixnum" i))
         (error who "not a fixnum" x)))
+
+  (define (fxcopy-bit-field x i j b)
+    (define who 'fxcopy-bit-field)
+    (if (fixnum? x) 
+        (if (fixnum? i)
+            (if ($fx<= 0 i)
+                (if (fixnum? j) 
+                    (if ($fx< j (fixnum-width))
+                        (if ($fx<= i j)
+                            (if (fixnum? b) 
+                                (let ([m 
+                                       ($fxlogxor
+                                         ($fxsub1 ($fxsll 1 i))
+                                         ($fxsub1 ($fxsll 1 j)))])
+                                  ($fxlogor
+                                    ($fxlogand m b)
+                                    ($fxlogand ($fxlognot m) x)))
+                                (error who "not a fixnum" b))
+                            (if ($fx<= 0 j)
+                                (error who "index out of range" j)
+                                (error who "indices not in order" i j)))
+                        (error who "index out of range" j))
+                    (error who "not a fixnum" j))
+                (error who "index out of range" i))
+            (error who "not a fixnum" i))
+        (error who "not a fixnum" x)))
+
   )
 
 
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index bd1d721..43777d4 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -790,7 +790,7 @@
     [fxbit-field                                 r fx]
     [fxbit-set?                                  i r fx]
     [fxcopy-bit                                  i r fx]
-    [fxcopy-bit-field                            r fx]
+    [fxcopy-bit-field                            i r fx]
     [fxdiv                                       i r fx]
     [fxdiv-and-mod                               i r fx]
     [fxdiv0                                      i r fx]
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index 157804d..a0ea6f0 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -292,7 +292,7 @@
     [fxbit-field                                S fx]
     [fxbit-set?                                 C fx]
     [fxcopy-bit                                 C fx]
-    [fxcopy-bit-field                           S fx]
+    [fxcopy-bit-field                           C fx]
     [fxdiv                                      C fx]
     [fxdiv-and-mod                              C fx]
     [fxdiv0                                     C fx]