put a more useful mirror over structs

basis/classes/struct/prettyprint/prettyprint.factor

@@ -1,9 +1,9 @@
 ! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types arrays assocs classes
-classes.struct combinators continuations fry kernel make math
+classes.struct combinators combinators.short-circuit continuations
-math.parser mirrors prettyprint.backend prettyprint.custom
+fry kernel libc make math math.parser mirrors prettyprint.backend
-prettyprint.sections see.private sequences strings
+prettyprint.custom prettyprint.sections see.private sequences
-summary words ;
+slots strings summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
@@ -62,12 +62,57 @@ M: struct summary
         " bytes " %
     ] "" make ;
 
-M: struct make-mirror
+TUPLE: struct-mirror { object read-only } ;
-    [
+C: <struct-mirror> struct-mirror
-        [ drop "underlying" ] [ (underlying)>> ] bi 2array 1array
+
+: get-struct-slot ( struct slot -- value present? )
+    over class 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
+    [ name>> writer-word execute( value struct -- ) ]
+    [ 2drop ] if* ;
+: reset-struct-slot ( struct slot -- )
+    over class struct-slots slot-named
+    [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
+    [ drop ] if* ;
+: reset-struct-slots ( struct -- )
+    dup class 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 ( mirror -- alist )
+    object>> [
+        [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
     ] [
         '[
             _ struct>assoc
             [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
         ] [ drop { } ] recover
     ] bi append ;
+
+M: struct make-mirror <struct-mirror> ;

basis/classes/struct/struct-tests.factor

@@ -1,12 +1,13 @@
 ! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types alien.libraries
-alien.structs.fields alien.syntax ascii byte-arrays classes.struct
+alien.structs.fields alien.syntax ascii assocs byte-arrays
-combinators destructors io.encodings.utf8 io.pathnames io.streams.string
+classes.struct classes.tuple.private combinators
-kernel libc literals math multiline namespaces prettyprint
+compiler.tree.debugger compiler.units destructors
-prettyprint.config see sequences specialized-arrays.ushort
+io.encodings.utf8 io.pathnames io.streams.string kernel libc
-system tools.test compiler.tree.debugger struct-arrays
+literals math mirrors multiline namespaces prettyprint
-classes.tuple.private specialized-arrays.direct.int
+prettyprint.config see sequences specialized-arrays.char
-compiler.units specialized-arrays.char ;
+specialized-arrays.direct.int specialized-arrays.ushort
+struct-arrays system tools.test ;
 IN: classes.struct.tests
 
 <<
@@ -56,6 +57,89 @@ STRUCT: struct-test-bar
 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
 
+[ {
+    { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
+    { { "x" "char" } 98            }
+    { { "y" "int"  } HEX: 7F00007F }
+    { { "z" "bool" } f             }
+} ] [
+    B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
+    make-mirror >alist
+] unit-test
+
+[ { { "underlying" f } } ] [
+    f struct-test-foo memory>struct
+    make-mirror >alist
+] unit-test
+
+[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
+[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
+[ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
+[ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
+[ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
+[ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
+
+[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "y" "int" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "x" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror { "nonexist" "char" } swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror "underlying" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z f } }
+    [ make-mirror "nonsense" swap delete-at ] keep
+] unit-test
+
+[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
+    S{ struct-test-foo { x 1 } { y 2 } { z t } }
+    [ make-mirror clear-assoc ] keep
+] unit-test
+
 UNION-STRUCT: struct-test-float-and-bits
     { f float }
     { bits uint } ;

basis/classes/struct/struct.factor

@@ -97,7 +97,7 @@ PRIVATE>
 
 M: struct-class boa>object
     swap pad-struct-slots
-    [ (struct) ] [ struct-slots ] bi 
+    [ <struct> ] [ struct-slots ] bi 
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 
 ! Struct slot accessors