111 lines
2.5 KiB
Forth
111 lines
2.5 KiB
Forth
\ Bit Arrays
|
|
|
|
: to-bits ( c -- f f f f f f f f )
|
|
8 0 ?do
|
|
2 /mod
|
|
swap negate swap
|
|
loop
|
|
drop ;
|
|
|
|
: from-bits ( f f f f f f f f -- )
|
|
8 0 ?do
|
|
if [char] 1 emit else [char] 0 emit then
|
|
loop ;
|
|
|
|
: byte-bin. ( c -- )
|
|
to-bits from-bits space ;
|
|
|
|
: byte. ( c -- )
|
|
dup byte-bin.
|
|
dup 2 ['] u.r 16 base-execute space
|
|
3 u.r space ;
|
|
|
|
: bytes-for-bits ( u1 -- u2 )
|
|
8 /mod swap
|
|
0> if 1+ then ;
|
|
|
|
: bits ( u -- bits )
|
|
dup bytes-for-bits cell + \ u-bits u-bytes
|
|
dup allocate throw \ u-bits u-bytes addr
|
|
2dup swap erase nip \ u-bits addr
|
|
swap over ! ; \ addr
|
|
|
|
: free-bits ( bits -- )
|
|
free throw ;
|
|
|
|
: bits. ( bits -- )
|
|
dup @ bytes-for-bits \ addr bytes
|
|
swap cell+ swap \ addr+cell bytes
|
|
bounds ?do
|
|
i cr 20 ['] u.r 16 base-execute space
|
|
i c@ byte.
|
|
loop
|
|
cr ;
|
|
|
|
: bit-position ( u -- u-bit u-byte )
|
|
8 /mod ;
|
|
|
|
: assert-bit ( bits u -- bits u )
|
|
assert( 2dup swap @ < ) ;
|
|
|
|
: find-bit ( bits u1 -- addr u2 )
|
|
assert-bit
|
|
bit-position \ addr bit byte
|
|
rot \ bit byte addr
|
|
cell+ + swap ; \ addr' bit
|
|
|
|
: set-true ( addr u -- )
|
|
1 swap lshift over \ addr mask addr
|
|
c@ or swap c! ;
|
|
|
|
: set-false ( addr u -- )
|
|
1 swap lshift invert over \ addr mask addr
|
|
c@ and swap c! ;
|
|
|
|
: set ( addr u f -- )
|
|
if set-true else set-false then ;
|
|
|
|
: set-bit ( bits u f -- )
|
|
{ f }
|
|
find-bit f set ;
|
|
|
|
: set-bits-at-addr ( addr u-start u-stop f -- )
|
|
{ f }
|
|
1+ swap u+do
|
|
dup i f set
|
|
loop
|
|
drop ;
|
|
|
|
: byte-from-flag ( f -- c )
|
|
if 255 else 0 then ;
|
|
|
|
: set-bits { bits u-start u-stop f -- }
|
|
|
|
u-start u-stop > if exit then
|
|
|
|
bits u-start find-bit { addr-start bit-start }
|
|
bits u-stop find-bit { addr-stop bit-stop }
|
|
|
|
addr-start addr-stop = if
|
|
addr-start bit-start bit-stop f set-bits-at-addr
|
|
else
|
|
addr-start bit-start 7 f set-bits-at-addr
|
|
addr-start 1+ addr-stop addr-start - 1- f byte-from-flag fill
|
|
addr-stop 0 bit-stop f set-bits-at-addr
|
|
then ;
|
|
|
|
: check-bit ( addr u -- f )
|
|
find-bit \ addr bit
|
|
1 swap lshift swap \ mask addr
|
|
c@ and 0> ;
|
|
|
|
: resize-bits ( bits u -- bits )
|
|
over @ { old-size }
|
|
tuck bytes-for-bits cell + resize throw \ u-bits bits
|
|
2dup ! swap \ bits u-bits
|
|
dup old-size > if
|
|
over swap \ bits bits u-bits
|
|
1- old-size swap false set-bits
|
|
else
|
|
drop
|
|
then ;
|