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