-! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data
-alien.prettyprint arrays assocs classes classes.struct
-combinators combinators.short-circuit continuations fry kernel
-libc make math math.parser mirrors prettyprint.backend
-prettyprint.custom prettyprint.sections see.private sequences
-slots strings summary words ;
+! Copyright (C) 2009, 2011 Joe Groff, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.prettyprint arrays assocs classes
+classes.struct combinators combinators.short-circuit
+continuations kernel libc make math math.parser mirrors
+prettyprint.backend prettyprint.custom prettyprint.sections
+see.private sequences slots summary ;
IN: classes.struct.prettyprint
<PRIVATE
: struct-definer-word ( class -- word )
struct-slots
{
+ { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
{ [ dup length 1 <= ] [ drop \ STRUCT: ] }
{ [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] }
- { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
[ drop \ STRUCT: ]
} cond ;
: struct>assoc ( struct -- assoc )
- [ class struct-slots ] [ struct-slot-values ] bi zip ;
+ [ class-of struct-slots ] [ struct-slot-values ] bi zip ;
: pprint-struct-slot ( slot -- )
<flow \ { pprint-word
: pprint-struct ( struct -- )
[
[ \ S{ ] dip
- [ class ]
+ [ class-of ]
[ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
\ } (pprint-tuple)
] ?pprint-tuple ;
: pprint-struct-pointer ( struct -- )
- \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
+ \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
PRIVATE>
drop \ S{ \ } ;
M: struct >pprint-sequence
- [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+ [ class-of ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint*
[ pprint-struct ]
M: struct summary
[
- dup class name>> %
+ dup class-of name>> %
" struct of " %
byte-length #
" bytes " %
C: <struct-mirror> struct-mirror
: get-struct-slot ( struct slot -- value present? )
- over class struct-slots slot-named
+ over class-of struct-slots slot-named
[ name>> reader-word execute( struct -- value ) t ]
[ drop f f ] if* ;
: set-struct-slot ( value struct slot -- )
- over class struct-slots slot-named
+ over class-of struct-slots slot-named
[ name>> writer-word execute( value struct -- ) ]
[ 2drop ] if* ;
: reset-struct-slot ( struct slot -- )
- over class struct-slots slot-named
+ over class-of struct-slots slot-named
[ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
[ drop ] if* ;
: reset-struct-slots ( struct -- )
- dup class struct-prototype
+ dup class-of struct-prototype
dup byte-length memcpy ;
M: struct-mirror at*
M: struct-mirror clear-assoc
object>> reset-struct-slots ;
-M: struct-mirror >alist ( mirror -- alist )
+M: struct-mirror >alist
object>> [
[ drop "underlying" ] [ >c-ptr ] bi 2array 1array
] [