basis/classes/struct/prettyprint/prettyprint.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types arrays assocs classes
   3 classes.struct combinators combinators.short-circuit continuations
   4 definitions fry kernel libc make math math.parser mirrors
   5 prettyprint.backend prettyprint.custom prettyprint.sections
   6 see see.private sequences slots strings summary words ;
   7 IN: classes.struct.prettyprint
   8
   9 <PRIVATE
  10
  11 : struct>assoc ( struct -- assoc )
  12     [ class struct-slots ] [ struct-slot-values ] bi zip ;
  13
  14 : pprint-struct-slot ( slot -- )
  15     <flow \ { pprint-word
  16     f <inset {
  17         [ name>> text ]
  18         [ c-type>> dup string? [ text ] [ pprint* ] if ]
  19         [ read-only>> [ \ read-only pprint-word ] when ]
  20         [ initial>> [ \ initial: pprint-word pprint* ] when* ]
  21     } cleave block>
  22     \ } pprint-word block> ;
  23
  24 : pprint-struct ( struct -- )
  25     [
  26         [ \ S{ ] dip
  27         [ class ]
  28         [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
  29         \ } (pprint-tuple)
  30     ] ?pprint-tuple ;
  31
  32 : pprint-struct-pointer ( struct -- )
  33     \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
  34
  35 PRIVATE>
  36
  37 M: struct-class definer
  38     struct-slots dup length 2 >=
  39     [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
  40     [ drop \ STRUCT: ] if
  41     \ ; ;
  42
  43 M: struct-class see-class*
  44     <colon dup definer drop pprint-word dup pprint-word
  45     <block struct-slots [ pprint-struct-slot ] each
  46     block> pprint-; block> ;
  47
  48 M: struct pprint-delims
  49     drop \ S{ \ } ;
  50
  51 M: struct >pprint-sequence
  52     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
  53
  54 M: struct pprint*
  55     [ pprint-struct ]
  56     [ pprint-struct-pointer ] pprint-c-object ;
  57
  58 M: struct summary
  59     [
  60         dup class name>> %
  61         " struct of " %
  62         byte-length #
  63         " bytes " %
  64     ] "" make ;
  65
  66 TUPLE: struct-mirror { object read-only } ;
  67 C: <struct-mirror> struct-mirror
  68
  69 : get-struct-slot ( struct slot -- value present? )
  70     over class struct-slots slot-named
  71     [ name>> reader-word execute( struct -- value ) t ]
  72     [ drop f f ] if* ;
  73 : set-struct-slot ( value struct slot -- )
  74     over class struct-slots slot-named
  75     [ name>> writer-word execute( value struct -- ) ]
  76     [ 2drop ] if* ;
  77 : reset-struct-slot ( struct slot -- )
  78     over class struct-slots slot-named
  79     [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
  80     [ drop ] if* ;
  81 : reset-struct-slots ( struct -- )
  82     dup class struct-prototype
  83     dup byte-length memcpy ;
  84
  85 M: struct-mirror at*
  86     object>> {
  87         { [ over "underlying" = ] [ nip >c-ptr t ] }
  88         { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
  89         [ 2drop f f ]
  90     } cond ;
  91
  92 M: struct-mirror set-at
  93     object>> {
  94         { [ over "underlying" = ] [ 3drop ] }
  95         { [ over array? ] [ swap first set-struct-slot ] }
  96         [ 3drop ]
  97     } cond ;
  98
  99 M: struct-mirror delete-at
 100     object>> {
 101         { [ over "underlying" = ] [ 2drop ] }
 102         { [ over array? ] [ swap first reset-struct-slot ] }
 103         [ 2drop ]
 104     } cond ;
 105
 106 M: struct-mirror clear-assoc
 107     object>> reset-struct-slots ;
 108
 109 M: struct-mirror >alist ( mirror -- alist )
 110     object>> [
 111         [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
 112     ] [
 113         '[
 114             _ struct>assoc
 115             [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
 116         ] [ drop { } ] recover
 117     ] bi append ;
 118
 119 M: struct make-mirror <struct-mirror> ;
 120
 121 INSTANCE: struct-mirror assoc