1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays classes
4 classes.tuple classes.tuple.private combinators fry hashtables
5 kernel math quotations sequences slots slots.private strings
9 TUPLE: mirror { object read-only } ;
13 : object-slots ( mirror -- slots ) object>> class-of all-slots ; inline
16 [ nip object>> ] [ object-slots slot-named ] 2bi
17 [ offset>> slot t ] [ drop f f ] if* ;
19 ERROR: no-such-slot slot ;
20 ERROR: read-only-slot slot ;
22 : check-set-slot ( val slot -- val offset )
24 { [ dup not ] [ throw-no-such-slot ] }
25 { [ dup read-only>> ] [ throw-read-only-slot ] }
26 { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
30 M: mirror set-at ( val key mirror -- )
31 [ object-slots slot-named check-set-slot ] [ object>> ] bi
34 M: mirror delete-at ( key mirror -- )
37 M: mirror clear-assoc ( mirror -- )
38 [ object-slots ] [ object>> ] bi '[
39 [ initial>> ] [ offset>> _ swap set-slot ] bi
42 M: mirror >alist ( mirror -- alist )
43 [ object-slots ] [ object>> ] bi '[
44 [ name>> ] [ offset>> _ swap slot ] bi
47 M: mirror keys ( mirror -- keys )
48 object-slots [ name>> ] map ;
50 M: mirror values ( mirror -- values )
51 [ object-slots ] [ object>> ] bi
52 '[ offset>> _ swap slot ] map ;
55 object>> class-of class-size ;
57 INSTANCE: mirror assoc
59 MIXIN: inspected-sequence
60 INSTANCE: array inspected-sequence
61 INSTANCE: vector inspected-sequence
62 INSTANCE: callable inspected-sequence
63 INSTANCE: byte-array inspected-sequence
65 GENERIC: make-mirror ( obj -- assoc )
66 M: hashtable make-mirror ;
67 M: integer make-mirror drop f ;
68 M: inspected-sequence make-mirror <enum> ;
69 M: object make-mirror <mirror> ;