From 82eda09ea0c6e1b231fbca9babaca9269754f62b Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 13 Nov 2007 23:24:21 -0500
Subject: [PATCH] * Added fxlength

---
 scheme/ikarus.numerics.ss | 20 ++++++++++++++++++--
 scheme/makefile.ss        |  2 +-
 scheme/run-tests.ss       |  1 +
 scheme/tests/fixnums.ss   | 32 +++++++++++++++++++++++++++++++-
 scheme/todo-r6rs.ss       |  2 +-
 5 files changed, 52 insertions(+), 5 deletions(-)

diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss
index 6883c86..97ebf70 100644
--- a/scheme/ikarus.numerics.ss
+++ b/scheme/ikarus.numerics.ss
@@ -2838,13 +2838,16 @@
 
 (library (ikarus bitwise misc)
   (export bitwise-first-bit-set
-          fxbit-count bitwise-bit-count)
+          fxbit-count bitwise-bit-count
+          fxlength)
   (import 
     (ikarus system $fx)
     (ikarus system $bignums)
+    (ikarus system $flonums)
     (except (ikarus) 
       bitwise-first-bit-set
-      fxbit-count bitwise-bit-count))
+      fxbit-count bitwise-bit-count
+      fxlength))
 
   (define (bitwise-first-bit-set x)
     (define (byte-first-bit-set x i) 
@@ -2917,6 +2920,19 @@
         [(bignum? n) (bnbitcount n)]
         [else (error 'bitwise-bit-count "not an exact integer" n)])))
   
+
+  (define (fxlength x) 
+    (if (fixnum? x) 
+        (let ([fl ($fixnum->flonum
+                    (if ($fx< x 0) ($fxlognot x) x))])
+          (let ([sbe ($fxlogor 
+                       ($fxsll ($flonum-u8-ref fl 0) 4)
+                       ($fxsra ($flonum-u8-ref fl 1) 4))])
+            (cond
+              [($fx= sbe 0) 0]
+              [else ($fx- sbe 1022)])))
+        (error 'fxlength "not a fixnum" x)))
+
   )
 
 
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 6a7f7bf..2e52472 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -798,7 +798,7 @@
     [fxfirst-bit-set                             r fx]
     [fxif                                        i r fx]
     [fxior                                       i r fx]
-    [fxlength                                    r fx]
+    [fxlength                                    i r fx]
     [fxmax                                       i r fx]
     [fxmin                                       i r fx]
     [fxmod                                       i r fx]
diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss
index 05a02f6..505d270 100755
--- a/scheme/run-tests.ss
+++ b/scheme/run-tests.ss
@@ -63,5 +63,6 @@
 (test-fldiv0-and-mod0)
 (test-fxdiv-and-mod)
 (test-fxdiv0-and-mod0)
+(test-fxlength)
 (test-bitwise-bit-count)
 (printf "Happy Happy Joy Joy\n")
diff --git a/scheme/tests/fixnums.ss b/scheme/tests/fixnums.ss
index af84466..e0db2da 100644
--- a/scheme/tests/fixnums.ss
+++ b/scheme/tests/fixnums.ss
@@ -1,6 +1,7 @@
 
 (library (tests fixnums)
-  (export test-fxdiv-and-mod test-fxdiv0-and-mod0)
+  (export test-fxdiv-and-mod test-fxdiv0-and-mod0
+          test-fxlength)
   (import (ikarus))
 
   (define (test-fxdiv-and-mod)
@@ -82,5 +83,34 @@
     (test (least-fixnum) (greatest-fixnum))
     (test (greatest-fixnum) (greatest-fixnum)))
   
+
+  (define (test-fxlength)
+    (define (test x)
+      (define (bitlen x)
+        (if (zero? x) 
+            0
+            (+ 1 (bitlen (bitwise-arithmetic-shift-right x 1)))))
+      (define (len x) 
+        (if (< x 0) 
+            (bitlen (bitwise-not x))
+            (bitlen x)))
+      (let ([c0 (len x)]
+            [c1 (fxlength x)])
+        (unless (= c0 c1) 
+          (error 'test-fxlength "failed/expected/got" x c0 c1))))
+    (define (fxtest x)
+      (when (fixnum? x) 
+        (when (zero? (bitwise-and x #xFFFFFFF)) 
+          (printf "fxlength ~s\n" x))
+        (test x) 
+        (fxtest (+ x #x100))))
+    (test 0)
+    (test 1)
+    (test 2)
+    (test 3)
+    (test -1)
+    (test -2)
+    (test -3)
+    (fxtest (least-fixnum)))
   )
 
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index d0b4f53..49750d2 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -301,7 +301,7 @@
     [fxfirst-bit-set                            S fx]
     [fxif                                       C fx]
     [fxior                                      C fx]
-    [fxlength                                   S fx]
+    [fxlength                                   C fx]
     [fxmax                                      C fx]
     [fxmin                                      C fx]
     [fxmod                                      C fx]