steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

likewise, an S@ word for structs

db4
Joe Groff 2009-08-30 20:46:31 -05:00
parent dee9f56500
commit 82025bde30
3 changed files with 43 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors assocs classes classes.struct combinators USING: accessors alien assocs classes classes.struct
kernel math prettyprint.backend prettyprint.custom combinators kernel math prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences strings words ; prettyprint.sections see.private sequences strings words ;
IN: classes.struct.prettyprint IN: classes.struct.prettyprint
@ -24,6 +24,14 @@ IN: classes.struct.prettyprint
} cleave } cleave
\ } pprint-word block> ; \ } pprint-word block> ;
: pprint-struct ( struct -- )
[ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
: pprint-struct-pointer ( struct -- )
\ S@ pprint-word
[ class pprint-word ]
[ >c-ptr pprint* ] bi ;
PRIVATE> PRIVATE>
M: struct-class see-class* M: struct-class see-class*
@ -38,4 +46,5 @@ M: struct >pprint-sequence
[ class ] [ struct-slot-values ] bi class-slot-sequence ; [ class ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint* M: struct pprint*
[ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ; [ pprint-struct ]
[ pprint-struct-pointer ] pprint-c-object ;

36
basis/classes/struct/struct-tests.factor
View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.libraries USING: accessors alien alien.c-types alien.libraries
alien.structs.fields alien.syntax ascii classes.struct combinators alien.structs.fields alien.syntax ascii byte-arrays classes.struct
destructors io.encodings.utf8 io.pathnames io.streams.string combinators destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort prettyprint.config see sequences specialized-arrays.ushort
system tools.test compiler.tree.debugger struct-arrays system tools.test compiler.tree.debugger struct-arrays
@ -78,16 +78,36 @@ STRUCT: struct-test-string-ptr
[ "S{ struct-test-foo { y 7654 } }" ] [ "S{ struct-test-foo { y 7654 } }" ]
[ [
f boa-tuples? [
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ] boa-tuples? off
with-variable c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
[
[
c-object-pointers? on
12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test ] unit-test
[ "S{ struct-test-foo f 0 7654 f }" ] [ "S{ struct-test-foo f 0 7654 f }" ]
[ [
t boa-tuples? [
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ] boa-tuples? on
with-variable c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo f" ]
[
[
c-object-pointers? off
f struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test ] unit-test
[ <" USING: classes.struct ; [ <" USING: classes.struct ;

3
basis/classes/struct/struct.factor
View File

@ -277,6 +277,9 @@ SYNTAX: UNION-STRUCT:
SYNTAX: S{ SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ; scan-word dup struct-slots parse-tuple-literal-slots parsed ;
SYNTAX: S@
scan-word scan-object swap memory>struct parsed ;
! functor support ! functor support
<PRIVATE <PRIVATE