basis/classes/struct/prettyprint/prettyprint.factor

   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
   8
   9 <PRIVATE
  10
  11 : struct-definer-word ( class -- word )
  12     struct-slots dup length 2 >=
  13     [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
  14     [ drop \ STRUCT: ] if ;
  15
  16 : struct>assoc ( struct -- assoc )
  17     [ class struct-slots ] [ struct-slot-values ] bi zip ;
  18
  19 : pprint-struct-slot ( slot -- )
  20     <flow \ { pprint-word
  21     f <inset {
  22         [ name>> text ]
  23         [ type>> pprint-c-type ]
  24         [ read-only>> [ \ read-only pprint-word ] when ]
  25         [ initial>> [ \ initial: pprint-word pprint* ] when* ]
  26         [
  27             dup struct-bit-slot-spec?
  28             [ \ bits: pprint-word bits>> pprint* ]
  29             [ drop ] if
  30         ]
  31     } cleave block>
  32     \ } pprint-word block> ;
  33
  34 : pprint-struct ( struct -- )
  35     [
  36         [ \ S{ ] dip
  37         [ class ]
  38         [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
  39         \ } (pprint-tuple)
  40     ] ?pprint-tuple ;
  41
  42 : pprint-struct-pointer ( struct -- )
  43     \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
  44
  45 PRIVATE>
  46
  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> ;
  51
  52 M: struct pprint-delims
  53     drop \ S{ \ } ;
  54
  55 M: struct >pprint-sequence
  56     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
  57
  58 M: struct pprint*
  59     [ pprint-struct ]
  60     [ pprint-struct-pointer ] pprint-c-object ;
  61
  62 M: struct summary
  63     [
  64         dup class name>> %
  65         " struct of " %
  66         byte-length #
  67         " bytes " %
  68     ] "" make ;
  69
  70 TUPLE: struct-mirror { object read-only } ;
  71 C: <struct-mirror> struct-mirror
  72
  73 : get-struct-slot ( struct slot -- value present? )
  74     over class struct-slots slot-named
  75     [ name>> reader-word execute( struct -- value ) t ]
  76     [ drop f f ] if* ;
  77 : set-struct-slot ( value struct slot -- )
  78     over class struct-slots slot-named
  79     [ name>> writer-word execute( value struct -- ) ]
  80     [ 2drop ] if* ;
  81 : reset-struct-slot ( struct slot -- )
  82     over class struct-slots slot-named
  83     [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
  84     [ drop ] if* ;
  85 : reset-struct-slots ( struct -- )
  86     dup class struct-prototype
  87     dup byte-length memcpy ;
  88
  89 M: struct-mirror at*
  90     object>> {
  91         { [ over "underlying" = ] [ nip >c-ptr t ] }
  92         { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
  93         [ 2drop f f ]
  94     } cond ;
  95
  96 M: struct-mirror set-at
  97     object>> {
  98         { [ over "underlying" = ] [ 3drop ] }
  99         { [ over array? ] [ swap first set-struct-slot ] }
 100         [ 3drop ]
 101     } cond ;
 102
 103 M: struct-mirror delete-at
 104     object>> {
 105         { [ over "underlying" = ] [ 2drop ] }
 106         { [ over array? ] [ swap first reset-struct-slot ] }
 107         [ 2drop ]
 108     } cond ;
 109
 110 M: struct-mirror clear-assoc
 111     object>> reset-struct-slots ;
 112
 113 M: struct-mirror >alist ( mirror -- alist )
 114     object>> [
 115         [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
 116     ] [
 117         '[
 118             _ struct>assoc
 119             [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
 120         ] [ drop { } ] recover
 121     ] bi append ;
 122
 123 M: struct make-mirror <struct-mirror> ;
 124
 125 INSTANCE: struct-mirror assoc