basis/math/bitwise/bitwise.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math sequences accessors math.bits
   4 sequences.private words namespaces macros hints
   5 combinators fry io.binary combinators.smart ;
   6 IN: math.bitwise
   7
   8 ! utilities
   9 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
  10 : set-bit ( x n -- y ) 2^ bitor ; inline
  11 : bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
  12 : unmask ( x n -- ? ) bitnot bitand ; inline
  13 : unmask? ( x n -- ? ) unmask 0 > ; inline
  14 : mask ( x n -- ? ) bitand ; inline
  15 : mask? ( x n -- ? ) mask 0 > ; inline
  16 : wrap ( m n -- m' ) 1 - bitand ; inline
  17 : bits ( m n -- m' ) 2^ wrap ; inline
  18 : mask-bit ( m n -- m' ) 2^ mask ; inline
  19 : on-bits ( n -- m ) 2^ 1 - ; inline
  20 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
  21
  22 : shift-mod ( n s w -- n )
  23     [ shift ] dip 2^ wrap ; inline
  24
  25 : bitroll ( x s w -- y )
  26     [ wrap ] keep
  27     [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
  28
  29 : bitroll-32 ( n s -- n' ) 32 bitroll ; inline
  30
  31 : bitroll-64 ( n s -- n' ) 64 bitroll ; inline
  32
  33 ! 32-bit arithmetic
  34 : w+ ( int int -- int ) + 32 bits ; inline
  35 : w- ( int int -- int ) - 32 bits ; inline
  36 : w* ( int int -- int ) * 32 bits ; inline
  37
  38 ! flags
  39 MACRO: flags ( values -- )
  40     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
  41
  42 ! bitfield
  43 <PRIVATE
  44
  45 GENERIC: (bitfield-quot) ( spec -- quot )
  46
  47 M: integer (bitfield-quot) ( spec -- quot )
  48     [ swapd shift bitor ] curry ;
  49
  50 M: pair (bitfield-quot) ( spec -- quot )
  51     first2 over word? [ [ swapd execute ] dip ] [ ] ?
  52     [ shift bitor ] append 2curry ;
  53
  54 PRIVATE>
  55
  56 MACRO: bitfield ( bitspec -- )
  57     [ 0 ] [ (bitfield-quot) compose ] reduce ;
  58
  59 ! bit-count
  60 <PRIVATE
  61
  62 DEFER: byte-bit-count
  63
  64 <<
  65
  66 \ byte-bit-count
  67 256 iota [
  68     8 <bits> 0 [ [ 1 + ] when ] reduce
  69 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
  70 (( byte -- table )) define-declared
  71
  72 \ byte-bit-count make-inline
  73
  74 >>
  75
  76 GENERIC: (bit-count) ( x -- n )
  77
  78 M: fixnum (bit-count)
  79     [
  80         {
  81             [           byte-bit-count ]
  82             [ -8  shift byte-bit-count ]
  83             [ -16 shift byte-bit-count ]
  84             [ -24 shift byte-bit-count ]
  85         } cleave
  86     ] sum-outputs ;
  87
  88 M: bignum (bit-count)
  89     dup 0 = [ drop 0 ] [
  90         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
  91     ] if ;
  92
  93 PRIVATE>
  94
  95 : bit-count ( x -- n )
  96     dup 0 < [ bitnot ] when (bit-count) ; inline
  97
  98 ! Signed byte array to integer conversion
  99 : signed-le> ( bytes -- x )
 100     [ le> ] [ length 8 * 1 - on-bits ] bi
 101     2dup > [ bitnot bitor ] [ drop ] if ;
 102
 103 : signed-be> ( bytes -- x )
 104     <reversed> signed-le> ;
 105
 106 : >signed ( x n -- y )
 107     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 108