From e0408b9b10cde28bf1c201fbc0957a4012bc8ab4 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 7 Oct 2009 01:43:32 -0500
Subject: [PATCH] Adding bit fields to STRUCT:

---
 basis/classes/struct/struct-tests.factor |  5 ++
 basis/classes/struct/struct.factor       | 99 ++++++++++++++++++++++--
 2 files changed, 97 insertions(+), 7 deletions(-)

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index a026417171..b59fc4577c 100755
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -352,3 +352,8 @@ STRUCT: struct-that's-a-word { x int } ;
 ] unit-test
 
 [ f ] [ "a-struct" c-types get key? ] unit-test
+
+STRUCT: bit-field-test
+    { a uint bits: 12 }
+    { b int bits: 2 }
+    { c char } ;
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index beddf07dd5..f8bdac530e 100755
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -1,4 +1,4 @@
-! (c)Joe Groff bsd license
+! (c)Joe Groff, Daniel Ehrenberg bsd license
 USING: accessors alien alien.c-types alien.data alien.parser arrays
 byte-arrays classes classes.parser classes.tuple classes.tuple.parser
 classes.tuple.private combinators combinators.short-circuit
@@ -6,11 +6,29 @@ combinators.smart cpu.architecture definitions functors.backend
 fry generalizations generic.parser kernel kernel.private lexer
 libc locals macros make math math.order parser quotations
 sequences slots slots.private specialized-arrays vectors words
-summary namespaces assocs vocabs.parser ;
+summary namespaces assocs vocabs.parser math.functions bit-arrays ;
+QUALIFIED: math
 IN: classes.struct
 
 SPECIALIZED-ARRAY: uchar
 
+<PRIVATE
+
+TUPLE: bits size signed? ;
+C: <bits> bits
+
+M: bits heap-size size>> 8 / ;
+
+M: bits c-type-align drop 1/8 ;
+
+: align ( m w -- n )
+    ! Really, you could write 'align' correctly
+    ! for any real w; this is just a hack
+    ! that only works here
+    dup integer? [ [ ceiling ] dip math:align ] [ drop ] if ;
+
+PRIVATE>
+
 ERROR: struct-must-have-slots ;
 
 M: struct-must-have-slots summary
@@ -84,14 +102,56 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 : pad-struct-slots ( values class -- values' class )
     [ struct-slots [ initial>> ] map over length tail append ] keep ;
 
-: (reader-quot) ( slot -- quot )
+: read-normal ( slot -- quot )
     [ type>> c-type-getter-boxer ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
-: (writer-quot) ( slot -- quot )
+: bits@ ( slot -- beginning end )
+    [ offset>> 8 * ] [ type>> size>> ] bi dupd + ;
+
+QUALIFIED: math.bits
+
+: bytes>bits ( byte-array -- bit-array )
+    [ 8 math.bits:<bits> ] { } map-as ?{ } join ;
+
+: (read-bits) ( beginning end byte-array -- n )
+    ! This is absurdly inefficient
+    bytes>bits subseq bit-array>integer ;
+
+: sign-extend ( n bits -- n' )
+    ! formula from:
+    ! http://guru.multimedia.cx/fast-sign-extension/
+    1 - -1 swap shift [ + ] keep bitxor ; inline
+
+: read-bits ( slot -- quot )
+    [ bits@ ] [ type>> signed?>> ] [ type>> size>> ] tri '[
+        [ _ _ ] dip (underlying)>> (read-bits)
+        _ [ _ sign-extend ] when
+    ] ;
+
+: (reader-quot) ( slot -- quot )
+    dup type>> bits? [ read-bits ] [ read-normal ] if ;
+
+: write-normal ( slot -- quot )
     [ type>> c-setter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
+: overwrite ( donor victim -- )
+    0 swap copy ;
+
+: (write-bits) ( value offset end byte-array -- )
+    ! This is absurdly inefficient
+    [
+        [ [ swap - math.bits:<bits> ] 2keep ] [ bytes>bits ] bi*
+        replace-slice ?{ } like underlying>>
+    ] keep overwrite ;
+
+: write-bits ( slot -- quot )
+    bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
+
+: (writer-quot) ( slot -- quot )
+    dup type>> bits? [ write-bits ] [ write-normal ] if ;
+
 : (boxer-quot) ( class -- quot )
     '[ _ memory>struct ] ;
 
@@ -196,10 +256,10 @@ M: struct-c-type c-struct? drop t ;
     ] reduce ;
 
 : union-struct-offsets ( slots -- size )
-    [ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
+    1 [ 0 >>offset type>> heap-size max ] reduce ;
 
 : struct-align ( slots -- align )
-    [ type>> c-type-align ] [ max ] map-reduce ;
+    1 [ type>> c-type-align max ] reduce ;
 PRIVATE>
 
 M: struct byte-length class "struct-size" word-prop ; foldable
@@ -273,11 +333,36 @@ ERROR: invalid-struct-slot token ;
     c-type c-type-boxed-class
     dup \ byte-array = [ drop \ c-ptr ] when ;
 
+SYMBOL: bits:
+
+<PRIVATE
+
+ERROR: bad-type-for-bits type ;
+
+: set-bits ( slot-spec n -- slot-spec )
+    over type>> {
+        { int [ t ] }
+        { uint [ f ] }
+        [ bad-type-for-bits ]
+    } case <bits> >>type ;
+
+: peel-off-struct-attributes ( slot-spec array -- slot-spec array )
+    dup empty? [
+        unclip {
+            { initial: [ [ first >>initial ] [ rest ] bi ] }
+            { read-only [ [ t >>read-only ] dip ] }
+            { bits: [ [ first set-bits ] [ rest ] bi ] }
+            [ bad-slot-attribute ]
+        } case
+    ] unless ;
+
+PRIVATE>
+
 : <struct-slot-spec> ( name c-type attributes -- slot-spec )
     [ struct-slot-spec new ] 3dip
     [ >>name ]
     [ [ >>type ] [ struct-slot-class >>class ] bi ]
-    [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
+    [ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
 
 <PRIVATE
 : parse-struct-slot ( -- slot )