1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
3 assocs classes classes.struct combinators combinators.short-circuit
4 continuations fry kernel libc make math math.parser mirrors
5 prettyprint.backend prettyprint.custom prettyprint.sections
6 see.private sequences slots strings summary words ;
7 IN: classes.struct.prettyprint
11 : struct-definer-word ( class -- word )
12 struct-slots dup length 2 >=
13 [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
14 [ drop \ STRUCT: ] if ;
16 : struct>assoc ( struct -- assoc )
17 [ class struct-slots ] [ struct-slot-values ] bi zip ;
19 : pprint-struct-slot ( slot -- )
23 [ type>> pprint-c-type ]
24 [ read-only>> [ \ read-only pprint-word ] when ]
25 [ initial>> [ \ initial: pprint-word pprint* ] when* ]
27 dup struct-bit-slot-spec?
28 [ \ bits: pprint-word bits>> pprint* ]
32 \ } pprint-word block> ;
34 : pprint-struct ( struct -- )
38 [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
42 : pprint-struct-pointer ( struct -- )
43 \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
47 M: struct-class see-class*
48 <colon dup struct-definer-word pprint-word dup pprint-word
49 <block struct-slots [ pprint-struct-slot ] each
50 block> pprint-; block> ;
52 M: struct pprint-delims
55 M: struct >pprint-sequence
56 [ class ] [ struct-slot-values ] bi class-slot-sequence ;
60 [ pprint-struct-pointer ] pprint-c-object ;
70 TUPLE: struct-mirror { object read-only } ;
71 C: <struct-mirror> struct-mirror
73 : get-struct-slot ( struct slot -- value present? )
74 over class struct-slots slot-named
75 [ name>> reader-word execute( struct -- value ) t ]
77 : set-struct-slot ( value struct slot -- )
78 over class struct-slots slot-named
79 [ name>> writer-word execute( value struct -- ) ]
81 : reset-struct-slot ( struct slot -- )
82 over class struct-slots slot-named
83 [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
85 : reset-struct-slots ( struct -- )
86 dup class struct-prototype
87 dup byte-length memcpy ;
91 { [ over "underlying" = ] [ nip >c-ptr t ] }
92 { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
96 M: struct-mirror set-at
98 { [ over "underlying" = ] [ 3drop ] }
99 { [ over array? ] [ swap first set-struct-slot ] }
103 M: struct-mirror delete-at
105 { [ over "underlying" = ] [ 2drop ] }
106 { [ over array? ] [ swap first reset-struct-slot ] }
110 M: struct-mirror clear-assoc
111 object>> reset-struct-slots ;
113 M: struct-mirror >alist ( mirror -- alist )
115 [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
119 [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
120 ] [ drop { } ] recover
123 M: struct make-mirror <struct-mirror> ;
125 INSTANCE: struct-mirror assoc