Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / bit-arrays / bit-arrays.factor

diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor
index 4cb2032f4f27e8434dc3a8182a0c5efd9501ef79..7aea3c458ae297b67103ac316f14ddfb371571d0 100644 (file)
--- a/basis/bit-arrays/bit-arrays.factor
+++ b/basis/bit-arrays/bit-arrays.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types accessors math alien.accessors kernel
-kernel.private locals sequences sequences.private byte-arrays
-parser prettyprint.backend fry ;
+kernel.private sequences sequences.private byte-arrays
+parser prettyprint.custom fry ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -11,7 +11,7 @@ TUPLE: bit-array
 
 <PRIVATE
 
-: n>byte -3 shift ; inline
+: n>byte ( m -- n ) -3 shift ; inline
 
 : byte/bit ( n alien -- byte bit )
     over n>byte alien-unsigned-1 swap 7 bitand ; inline
@@ -19,13 +19,25 @@ TUPLE: bit-array
 : set-bit ( ? byte bit -- byte )
     2^ rot [ bitor ] [ bitnot bitand ] if ; inline
 
-: bits>cells 31 + -5 shift ; inline
+: bits>cells ( m -- n ) 31 + -5 shift ; inline
 
-: bits>bytes 7 + n>byte ; inline
+: bits>bytes ( m -- n ) 7 + n>byte ; inline
 
 : (set-bits) ( bit-array n -- )
     [ [ length bits>cells ] keep ] dip swap underlying>>
-    '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+
+: clean-up ( bit-array -- )
+    ! Zero bits after the end.
+    dup underlying>> empty? [ drop ] [
+        [
+            [ underlying>> length 8 * ] [ length ] bi -
+            8 swap - -1 swap shift bitnot
+        ]
+        [ underlying>> last bitand ]
+        [ underlying>> set-last ]
+        tri
+    ] if ; inline
 
 PRIVATE>
 
@@ -42,9 +54,13 @@ M: bit-array set-nth-unsafe
     [ byte/bit set-bit ] 2keep
     swap n>byte set-alien-unsigned-1 ;
 
-: clear-bits ( bit-array -- ) 0 (set-bits) ;
+GENERIC: clear-bits ( bit-array -- )
+
+M: bit-array clear-bits 0 (set-bits) ;
 
-: set-bits ( bit-array -- ) -1 (set-bits) ;
+GENERIC: set-bits ( bit-array -- )
+
+M: bit-array set-bits -1 (set-bits) ;
 
 M: bit-array clone
     [ length>> ] [ underlying>> clone ] bi bit-array boa ;
@@ -57,33 +73,33 @@ M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
 M: bit-array new-sequence drop <bit-array> ;
 
 M: bit-array equal?
-    over bit-array? [ sequence= ] [ 2drop f ] if ;
+    over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
 
 M: bit-array resize
     [ drop ] [
         [ bits>bytes ] [ underlying>> ] bi*
         resize-byte-array
     ] 2bi
-    bit-array boa ;
+    bit-array boa
+    dup clean-up ;
 
 M: bit-array byte-length length 7 + -3 shift ;
 
-: ?{ \ } [ >bit-array ] parse-literal ; parsing
-
-:: integer>bit-array ( n -- bit-array ) 
-    n zero? [ 0 <bit-array> ] [
-        [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
-            [ n' zero? not ] [
-                n' out underlying>> i set-alien-unsigned-1
-                n' -8 shift n'!
-                i 1+ i!
-            ] [ ] while
-            out
-        ]
+SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
+
+: integer>bit-array ( n -- bit-array )
+    dup 0 = [
+        <bit-array>
+    ] [
+        [ log2 1 + <bit-array> 0 ] keep
+        [ dup 0 = ] [
+            [ pick underlying>> pick set-alien-unsigned-1 ] keep
+            [ 1 + ] [ -8 shift ] bi*
+        ] until 2drop
     ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length [
+    0 swap underlying>> dup length <reversed> [
         alien-unsigned-1 swap 8 shift bitor
     ] with each ;