diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 1f8d0cc482..912d33c7bc 100644 --- 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 y>> ] unit-test -[ 123 ] [ bar foo>> y>> ] unit-test +[ 12 ] [ struct-test-foo heap-size ] unit-test +[ 16 ] [ struct-test-bar heap-size ] unit-test +[ 123 ] [ struct-test-foo y>> ] unit-test +[ 123 ] [ struct-test-bar foo>> y>> ] unit-test [ 1 2 3 t ] [ - 1 2 3 t foo bar + 1 2 3 t struct-test-foo struct-test-bar { [ 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 1.0 float>bits >>bits f>> ] unit-test -[ 4 ] [ float-and-bits heap-size ] unit-test +[ 1.0 ] [ struct-test-float-and-bits 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 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test +[ "S{ struct-test-foo { y 7654 } }" ] +[ + f boa-tuples? + [ struct-test-foo 7654 >>y [ pprint ] with-string-writer ] + with-variable +] unit-test -[ "S{ foo f 0 7654 f }" ] -[ t boa-tuples? [ foo 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test +[ "S{ struct-test-foo f 0 7654 f }" ] +[ + t boa-tuples? + [ struct-test-foo 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 2794df1393..3d4ffe138b 100644 --- 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)