1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs hashtables kernel sequences generic words
4 arrays classes slots slots.private classes.tuple
5 classes.tuple.private math vectors quotations accessors
9 TUPLE: mirror { object read-only } ;
13 : object-slots ( mirror -- slots ) object>> class all-slots ; inline
16 [ nip object>> ] [ object-slots slot-named ] 2bi
17 dup [ offset>> slot t ] [ 2drop f f ] if ;
19 : check-set-slot ( val slot -- val offset )
21 { [ dup not ] [ "No such slot" throw ] }
22 { [ dup read-only>> ] [ "Read only slot" throw ] }
23 { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
27 M: mirror set-at ( val key mirror -- )
28 [ object-slots slot-named check-set-slot ] [ object>> ] bi
31 M: mirror delete-at ( key mirror -- )
34 M: mirror clear-assoc ( mirror -- )
35 [ object>> ] [ object-slots ] bi [
36 [ initial>> ] [ offset>> ] bi swapd set-slot
39 M: mirror >alist ( mirror -- alist )
40 [ object-slots [ [ name>> ] map ] [ [ offset>> ] map ] bi ]
41 [ object>> [ swap slot ] curry ] bi
44 M: mirror assoc-size object>> layout-of size>> ;
46 INSTANCE: mirror assoc
48 GENERIC: make-mirror ( obj -- assoc )
49 M: hashtable make-mirror ;
50 M: integer make-mirror drop f ;
51 M: array make-mirror <enum> ;
52 M: vector make-mirror <enum> ;
53 M: quotation make-mirror <enum> ;
54 M: object make-mirror <mirror> ;