factor: trim using lists

[factor.git] / basis / classes / struct / prettyprint / prettyprint.factor

diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor
index 0334b19ddd45bacd9957340098f8c006257df26f..500c5dbd191529a329313c0dbc6aa3f16f8f555b 100644 (file)
--- a/basis/classes/struct/prettyprint/prettyprint.factor
+++ b/basis/classes/struct/prettyprint/prettyprint.factor
@@ -1,38 +1,51 @@
-! (c)Joe Groff bsd license
-USING: accessors alien assocs classes classes.struct
-combinators kernel math prettyprint.backend prettyprint.custom
-prettyprint.sections see.private sequences strings 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 length 2 >=
-    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
-    [ drop \ STRUCT: ] if ;
+    struct-slots
+    {
+        { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
+        { [ dup length 1 <= ] [ drop \ STRUCT: ] }
+        { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-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
-    {
+    f <inset {
         [ name>> text ]
-        [ c-type>> dup string? [ text ] [ pprint* ] if ]
+        [ type>> pprint-c-type ]
         [ read-only>> [ \ read-only pprint-word ] when ]
         [ initial>> [ \ initial: pprint-word pprint* ] when* ]
-    } cleave
+        [
+            dup struct-bit-slot-spec?
+            [ \ bits: pprint-word bits>> pprint* ]
+            [ drop ] if
+        ]
+    } cleave block>
     \ } pprint-word block> ;
 
 : pprint-struct ( struct -- )
-    [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+    [
+        [ \ S{ ] dip
+        [ class-of ]
+        [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
+        \ } (pprint-tuple)
+    ] ?pprint-tuple ;
 
 : pprint-struct-pointer ( struct -- )
-    <block
-    \ S@ pprint-word
-    [ class pprint-word ]
-    [ >c-ptr pprint* ] bi
-    block> ;
+    \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
 
 PRIVATE>
 
@@ -45,8 +58,73 @@ M: struct pprint-delims
     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 ]
     [ pprint-struct-pointer ] pprint-c-object ;
+
+M: struct summary
+    [
+        dup class-of name>> %
+        " struct of " %
+        byte-length #
+        " bytes " %
+    ] "" make ;
+
+TUPLE: struct-mirror { object read-only } ;
+C: <struct-mirror> struct-mirror
+
+: get-struct-slot ( struct slot -- value present? )
+    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-of struct-slots slot-named
+    [ name>> writer-word execute( value struct -- ) ]
+    [ 2drop ] if* ;
+: reset-struct-slot ( struct slot -- )
+    over class-of struct-slots slot-named
+    [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
+    [ drop ] if* ;
+: reset-struct-slots ( struct -- )
+    dup class-of struct-prototype
+    dup byte-length memcpy ;
+
+M: struct-mirror at*
+    object>> {
+        { [ over "underlying" = ] [ nip >c-ptr t ] }
+        { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] }
+        [ 2drop f f ]
+    } cond ;
+
+M: struct-mirror set-at
+    object>> {
+        { [ over "underlying" = ] [ 3drop ] }
+        { [ over array? ] [ swap first set-struct-slot ] }
+        [ 3drop ]
+    } cond ;
+
+M: struct-mirror delete-at
+    object>> {
+        { [ over "underlying" = ] [ 2drop ] }
+        { [ over array? ] [ swap first reset-struct-slot ] }
+        [ 2drop ]
+    } cond ;
+
+M: struct-mirror clear-assoc
+    object>> reset-struct-slots ;
+
+M: struct-mirror >alist
+    object>> [
+        [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
+    ] [
+        '[
+            _ struct>assoc
+            [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map
+        ] [ drop { } ] recover
+    ] bi append ;
+
+M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc