basis/classes/struct/prettyprint/prettyprint.factor

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