convert alien.struct fields to classes.struct fields; add tests

diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor
index 1f8d0cc482f4b6f86a7660dfd3b4530501a42250..912d33c7bc3c6bc632ab3b899359b18fc0465569 100644 (file)
--- a/extra/classes/struct/struct-tests.factor
+++ b/extra/classes/struct/struct-tests.factor
@@ -1,25 +1,25 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien.c-types classes.c-types classes.struct
-combinators io.streams.string kernel libc math multiline namespaces
-prettyprint prettyprint.config see tools.test ;
+USING: accessors alien.c-types alien.structs.fields classes.c-types
+classes.struct combinators io.streams.string kernel libc literals math
+multiline namespaces prettyprint prettyprint.config see tools.test ;
 IN: classes.struct.tests
 
-STRUCT: foo
+STRUCT: struct-test-foo
     { x char }
     { y int initial: 123 }
     { z boolean } ;
 
-STRUCT: bar
+STRUCT: struct-test-bar
     { w ushort initial: HEX: ffff }
-    { foo foo } ;
+    { foo struct-test-foo } ;
 
-[ 12 ] [ foo heap-size ] unit-test
-[ 16 ] [ bar heap-size ] unit-test
-[ 123 ] [ foo <struct> y>> ] unit-test
-[ 123 ] [ bar <struct> foo>> y>> ] unit-test
+[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 16 ] [ struct-test-bar heap-size ] unit-test
+[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
+[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
 
 [ 1 2 3 t ] [
-    1   2 3 t foo <struct-boa>   bar <struct-boa>
+    1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
     {
         [ w>> ] 
         [ foo>> x>> ]
@@ -28,35 +28,85 @@ STRUCT: bar
     } cleave
 ] unit-test
 
-[ 7654 ] [ S{ foo f 98 7654 f } y>> ] unit-test
-[ 7654 ] [ S{ foo { y 7654 } } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
+[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
 
-UNION-STRUCT: float-and-bits
+UNION-STRUCT: struct-test-float-and-bits
     { f single-float }
     { bits uint } ;
 
-[ 1.0 ] [ float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
-[ 4 ] [ float-and-bits heap-size ] unit-test
+[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
+[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 
-[ ] [ foo malloc-struct free ] unit-test
+[ ] [ struct-test-foo malloc-struct free ] unit-test
 
-[ "S{ foo { y 7654 } }" ]
-[ f boa-tuples? [ foo <struct> 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test
+[ "S{ struct-test-foo { y 7654 } }" ]
+[
+    f boa-tuples?
+    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+    with-variable
+] unit-test
 
-[ "S{ foo f 0 7654 f }" ]
-[ t boa-tuples? [ foo <struct> 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test
+[ "S{ struct-test-foo f 0 7654 f }" ]
+[
+    t boa-tuples?
+    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+    with-variable
+] unit-test
 
 [ <" USING: classes.c-types classes.struct kernel ;
 IN: classes.struct.tests
-STRUCT: foo
+STRUCT: struct-test-foo
     { x char initial: 0 } { y int initial: 123 }
     { z boolean initial: f } ;
 "> ]
-[ [ foo see ] with-string-writer ] unit-test
+[ [ struct-test-foo see ] with-string-writer ] unit-test
 
 [ <" USING: classes.c-types classes.struct ;
 IN: classes.struct.tests
-UNION-STRUCT: float-and-bits
+UNION-STRUCT: struct-test-float-and-bits
     { f single-float initial: 0.0 } { bits uint initial: 0 } ;
 "> ]
-[ [ float-and-bits see ] with-string-writer ] unit-test
+[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
+
+[ {
+    T{ field-spec
+        { name "x" }
+        { offset 0 }
+        { type $[ char c-type ] }
+        { reader x>> }
+        { writer (>>x) }
+    }
+    T{ field-spec
+        { name "y" }
+        { offset 4 }
+        { type $[ int c-type ] }
+        { reader y>> }
+        { writer (>>y) }
+    }
+    T{ field-spec
+        { name "z" }
+        { offset 8 }
+        { type $[ boolean c-type ] }
+        { reader z>> }
+        { writer (>>z) }
+    }
+} ] [ "struct-test-foo" c-type fields>> ] unit-test
+
+[ {
+    T{ field-spec
+        { name "f" }
+        { offset 0 }
+        { type $[ single-float c-type ] }
+        { reader f>> }
+        { writer (>>f) }
+    }
+    T{ field-spec
+        { name "bits" }
+        { offset 0 }
+        { type $[ uint c-type ] }
+        { reader bits>> }
+        { writer (>>bits) }
+    }
+} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+

diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 2794df13931bcb81423f274550c4303ca45c0fa7..3d4ffe138bc9949390ecb2ca44f6914d9b4ddabf 100644 (file)
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -1,10 +1,11 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs arrays
+USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
 byte-arrays classes classes.c-types classes.parser classes.tuple
 classes.tuple.parser classes.tuple.private combinators
 combinators.smart fry generalizations generic.parser kernel
 kernel.private libc macros make math math.order parser
 quotations sequences slots slots.private struct-arrays words ;
+FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
 ! struct class
@@ -92,12 +93,23 @@ M: struct-class writer-quot
 ! Struct as c-type
 
 : slot>field ( slot -- field )
-    [ class>> c-type ] [ name>> ] bi 2array ;
+    field-spec new swap {
+        [ name>> >>name ]
+        [ offset>> >>offset ]
+        [ class>> c-type >>type ]
+        [ name>> reader-word >>reader ]
+        [ name>> writer-word >>writer ]
+    } cleave ;
 
 : define-struct-for-class ( class -- )
     [
-        [ name>> ] [ vocabulary>> ] [ struct-slots [ slot>field ] map ] tri
-        define-struct
+        {
+            [ name>> ]
+            [ "struct-size" word-prop ]
+            [ "struct-align" word-prop ]
+            [ struct-slots [ slot>field ] map ]
+        } cleave
+        (define-struct)
     ] [
         [ name>> c-type ]
         [ (unboxer-quot) >>unboxer-quot ]
@@ -171,8 +183,8 @@ M: struct-class direct-array-of
     [ class>> c-type drop ] each ;
 
 : (define-struct-class) ( class slots offsets-quot -- )
-    [ drop struct f define-tuple-class ] swap
-    '[
+    [ drop struct f define-tuple-class ]
+    swap '[
         make-slots dup
         [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
         (struct-word-props)