1 ! Copyright (C) 2009, 2011 Joe Groff, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data
4 alien.prettyprint arrays assocs classes classes.struct
5 combinators combinators.short-circuit continuations fry kernel
6 libc make math math.parser mirrors prettyprint.backend
7 prettyprint.custom prettyprint.sections see.private sequences
8 slots strings summary words ;
9 IN: classes.struct.prettyprint
13 : struct-definer-word ( class -- word )
16 { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
17 { [ dup length 1 <= ] [ drop \ STRUCT: ] }
18 { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] }
22 : struct>assoc ( struct -- assoc )
23 [ class-of struct-slots ] [ struct-slot-values ] bi zip ;
25 : pprint-struct-slot ( slot -- )
29 [ type>> pprint-c-type ]
30 [ read-only>> [ \ read-only pprint-word ] when ]
31 [ initial>> [ \ initial: pprint-word pprint* ] when* ]
33 dup struct-bit-slot-spec?
34 [ \ bits: pprint-word bits>> pprint* ]
38 \ } pprint-word block> ;
40 : pprint-struct ( struct -- )
44 [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
48 : pprint-struct-pointer ( struct -- )
49 \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
53 M: struct-class see-class*
54 <colon dup struct-definer-word pprint-word dup pprint-word
55 <block struct-slots [ pprint-struct-slot ] each
56 block> pprint-; block> ;
58 M: struct pprint-delims
61 M: struct >pprint-sequence
62 [ class-of ] [ struct-slot-values ] bi class-slot-sequence ;
66 [ pprint-struct-pointer ] pprint-c-object ;
76 TUPLE: struct-mirror { object read-only } ;
77 C: <struct-mirror> struct-mirror
79 : get-struct-slot ( struct slot -- value present? )
80 over class-of struct-slots slot-named
81 [ name>> reader-word execute( struct -- value ) t ]
83 : set-struct-slot ( value struct slot -- )
84 over class-of struct-slots slot-named
85 [ name>> writer-word execute( value struct -- ) ]
87 : reset-struct-slot ( struct slot -- )
88 over class-of struct-slots slot-named
89 [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
91 : reset-struct-slots ( struct -- )
92 dup class-of struct-prototype
93 dup byte-length memcpy ;
97 { [ over "underlying" = ] [ nip >c-ptr t ] }
98 { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
102 M: struct-mirror set-at
104 { [ over "underlying" = ] [ 3drop ] }
105 { [ over array? ] [ swap first set-struct-slot ] }
109 M: struct-mirror delete-at
111 { [ over "underlying" = ] [ 2drop ] }
112 { [ over array? ] [ swap first reset-struct-slot ] }
116 M: struct-mirror clear-assoc
117 object>> reset-struct-slots ;
119 M: struct-mirror >alist
121 [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
125 [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
126 ] [ drop { } ] recover
129 M: struct make-mirror <struct-mirror> ;
131 INSTANCE: struct-mirror assoc