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 assocs combinators combinators.smart fry kernel
   4 macros math math.bits sequences sequences.private words
   5 byte-arrays alien alien.c-types alien.data specialized-arrays
   6 kernel.private layouts ;
   7 SPECIALIZED-ARRAY: uchar
   8 IN: math.bitwise
   9
  10 ! utilities
  11 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
  12 : set-bit ( x n -- y ) 2^ bitor ; inline
  13 : bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
  14 : unmask ( x n -- ? ) bitnot bitand ; inline
  15 : unmask? ( x n -- ? ) unmask 0 > ; inline
  16 : mask ( x n -- ? ) bitand ; inline
  17 : mask? ( x n -- ? ) mask 0 > ; inline
  18 : wrap ( m n -- m' ) 1 - bitand ; inline
  19 : on-bits ( m -- n ) 2^ 1 - ; inline
  20 : bits ( m n -- m' ) on-bits mask ; inline
  21 : mask-bit ( m n -- m' ) 2^ mask ; inline
  22 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
  23 : >signed ( x n -- y )
  24     [ bits ] keep 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
  25 : >odd ( m -- n ) 0 set-bit ; foldable
  26 : >even ( m -- n ) 0 clear-bit ; foldable
  27 : next-even ( m -- n ) >even 2 + ; foldable
  28 : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
  29 : shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
  30
  31 : bitroll ( x s w -- y )
  32     [ wrap ] keep
  33     [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
  34
  35 : bitroll-32 ( m s -- n ) 32 bitroll ; inline
  36
  37 : bitroll-64 ( m s -- n ) 64 bitroll ; inline
  38
  39 ! 32-bit arithmetic
  40 : w+ ( x y -- z ) + 32 bits ; inline
  41 : w- ( x y -- z ) - 32 bits ; inline
  42 : w* ( x y -- z ) * 32 bits ; inline
  43
  44 ! 64-bit arithmetic
  45 : W+ ( x y -- z ) + 64 bits ; inline
  46 : W- ( x y -- z ) - 64 bits ; inline
  47 : W* ( x y -- z ) * 64 bits ; inline
  48
  49 : symbols>flags ( symbols assoc -- flag-bits )
  50     [ at ] curry map
  51     0 [ bitor ] reduce ;
  52
  53 ! bitfield
  54 <PRIVATE
  55
  56 GENERIC: (bitfield-quot) ( spec -- quot )
  57
  58 M: integer (bitfield-quot) ( spec -- quot )
  59     [ swapd shift bitor ] curry ;
  60
  61 M: pair (bitfield-quot) ( spec -- quot )
  62     first2 over word? [ [ swapd execute ] dip ] [ ] ?
  63     [ shift bitor ] append 2curry ;
  64
  65 PRIVATE>
  66
  67 MACRO: bitfield ( bitspec -- )
  68     [ 0 ] [ (bitfield-quot) compose ] reduce ;
  69
  70 ! bit-count
  71 <PRIVATE
  72
  73 DEFER: byte-bit-count
  74
  75 <<
  76
  77 \ byte-bit-count
  78 256 iota [
  79     8 <bits> 0 [ [ 1 + ] when ] reduce
  80 ] B{ } map-as '[ 0xff bitand _ nth-unsafe ]
  81 ( byte -- table ) define-declared
  82
  83 \ byte-bit-count make-inline
  84
  85 >>
  86
  87 GENERIC: (bit-count) ( x -- n )
  88
  89 : fixnum-bit-count ( x -- n )
  90     { fixnum } declare
  91     {
  92         [ byte-bit-count ]
  93         [ -8 shift byte-bit-count + ]
  94         [ -16 shift byte-bit-count + ]
  95         [ -24 shift byte-bit-count + ]
  96         [
  97             cell 8 = [
  98                 {
  99                     [ -32 shift byte-bit-count + ]
 100                     [ -40 shift byte-bit-count + ]
 101                     [ -48 shift byte-bit-count + ]
 102                     [ -56 shift byte-bit-count + ]
 103                 } cleave >fixnum
 104             ] [ drop ] if
 105         ]
 106     } cleave ;
 107
 108 M: fixnum (bit-count)
 109     fixnum-bit-count { fixnum } declare ; inline
 110
 111 M: bignum (bit-count)
 112     dup 0 = [ drop 0 ] [
 113         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
 114     ] if ;
 115
 116 : byte-array-bit-count ( byte-array -- n )
 117     0 [ byte-bit-count + ] reduce ; inline
 118
 119 PRIVATE>
 120
 121 ERROR: invalid-bit-count-target object ;
 122
 123 GENERIC: bit-count ( obj -- n )
 124
 125 M: integer bit-count
 126     dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline
 127
 128 M: byte-array bit-count
 129     byte-array-bit-count ;
 130
 131 M: object bit-count
 132     binary-object uchar <c-direct-array> byte-array-bit-count ;
 133
 134 : even-parity? ( obj -- ? ) bit-count even? ;
 135
 136 : odd-parity? ( obj -- ? ) bit-count odd? ;