core/mirrors/mirrors.factor

   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 math vectors
   5 quotations accessors ;
   6 IN: mirrors
   7
   8 : all-slots ( class -- slots )
   9     superclasses [ "slots" word-prop ] map concat ;
  10
  11 : object-slots ( obj -- seq )
  12     class all-slots ;
  13
  14 TUPLE: mirror object slots ;
  15
  16 : <mirror> ( object -- mirror )
  17     dup object-slots mirror boa ;
  18
  19 ERROR: no-such-slot object name ;
  20
  21 ERROR: immutable-slot object name ;
  22
  23 M: mirror at*
  24     [ nip object>> ] [ slots>> slot-named ] 2bi
  25     dup [ offset>> slot t ] [ 2drop f f ] if ;
  26
  27 M: mirror set-at ( val key mirror -- )
  28     [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
  29         dup writer>> [
  30             nip offset>> set-slot
  31         ] [
  32             drop immutable-slot
  33         ] if
  34     ] [
  35         drop no-such-slot
  36     ] if ;
  37
  38 M: mirror delete-at ( key mirror -- )
  39     f -rot set-at ;
  40
  41 M: mirror >alist ( mirror -- alist )
  42     [ slots>> [ name>> ] map ]
  43     [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
  44     zip ;
  45
  46 M: mirror assoc-size mirror-slots length ;
  47
  48 INSTANCE: mirror assoc
  49
  50 GENERIC: make-mirror ( obj -- assoc )
  51 M: hashtable make-mirror ;
  52 M: integer make-mirror drop f ;
  53 M: array make-mirror <enum> ;
  54 M: vector make-mirror <enum> ;
  55 M: quotation make-mirror <enum> ;
  56 M: object make-mirror <mirror> ;