basis/math/bitwise/bitwise.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math math.functions sequences
   4 sequences.private words namespaces macros hints
   5 combinators fry ;
   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 zero? ; 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' ) 1- 2^ mask ; inline
  19
  20 : shift-mod ( n s w -- n )
  21     >r shift r> 2^ wrap ; inline
  22
  23 : bitroll ( x s w -- y )
  24      [ wrap ] keep
  25      [ shift-mod ]
  26      [ [ - ] keep shift-mod ] 3bi bitor ; inline
  27
  28 : bitroll-32 ( n s -- n' ) 32 bitroll ;
  29
  30 HINTS: bitroll-32 bignum fixnum ;
  31
  32 : bitroll-64 ( n s -- n' ) 64 bitroll ;
  33
  34 HINTS: bitroll-64 bignum fixnum ;
  35
  36 ! 32-bit arithmetic
  37 : w+ ( int int -- int ) + 32 bits ; inline
  38 : w- ( int int -- int ) - 32 bits ; inline
  39 : w* ( int int -- int ) * 32 bits ; inline
  40
  41 ! flags
  42 MACRO: flags ( values -- )
  43     [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
  44
  45 ! bitfield
  46 <PRIVATE
  47
  48 GENERIC: (bitfield-quot) ( spec -- quot )
  49
  50 M: integer (bitfield-quot) ( spec -- quot )
  51     [ swapd shift bitor ] curry ;
  52
  53 M: pair (bitfield-quot) ( spec -- quot )
  54     first2 over word? [ >r swapd execute r> ] [ ] ?
  55     [ shift bitor ] append 2curry ;
  56
  57 PRIVATE>
  58
  59 MACRO: bitfield ( bitspec -- )
  60     [ 0 ] [ (bitfield-quot) compose ] reduce ;
  61
  62 ! bit-count
  63 <PRIVATE
  64
  65 DEFER: byte-bit-count
  66
  67 <<
  68
  69 \ byte-bit-count
  70 256 [
  71     0 swap [ [ 1+ ] when ] each-bit
  72 ] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
  73
  74 >>
  75
  76 GENERIC: (bit-count) ( x -- n )
  77
  78 M: fixnum (bit-count)
  79     {
  80         [           byte-bit-count ]
  81         [ -8  shift byte-bit-count ]
  82         [ -16 shift byte-bit-count ]
  83         [ -24 shift byte-bit-count ]
  84     } cleave + + + ;
  85
  86 M: bignum (bit-count)
  87     dup 0 = [ drop 0 ] [
  88         [ byte-bit-count ] [ -8 shift (bit-count) ] bi +
  89     ] if ;
  90
  91 PRIVATE>
  92
  93 : bit-count ( x -- n )
  94     dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline