core/slots/slots.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel kernel.private math namespaces
   4 sequences strings words effects generic generic.standard
   5 classes slots.private combinators accessors words ;
   6 IN: slots
   7
   8 TUPLE: slot-spec name offset class initial read-only reader writer ;
   9
  10 : <slot-spec> ( -- slot-spec )
  11     slot-spec new
  12         object bootstrap-word >>class ;
  13
  14 : define-typecheck ( class generic quot -- )
  15     [
  16         dup define-simple-generic
  17         create-method
  18     ] dip define ;
  19
  20 : define-slot-word ( class offset word quot -- )
  21     rot >fixnum prefix define-typecheck ;
  22
  23 : create-accessor ( name effect -- word )
  24     >r "accessors" create dup r>
  25     "declared-effect" set-word-prop ;
  26
  27 : reader-quot ( decl -- quot )
  28     [
  29         \ slot ,
  30         dup object bootstrap-word eq?
  31         [ drop ] [ 1array , \ declare , ] if
  32     ] [ ] make ;
  33
  34 : reader-word ( name -- word )
  35     ">>" append (( object -- value )) create-accessor ;
  36
  37 : define-reader ( class slot-spec -- )
  38     [ offset>> ]
  39     [ name>> reader-word ]
  40     [ class>> reader-quot ]
  41     tri define-slot-word ;
  42
  43 : writer-word ( name -- word )
  44     "(>>" swap ")" 3append (( value object -- )) create-accessor ;
  45
  46 ERROR: bad-slot-value value object index ;
  47
  48 : writer-quot ( decl -- quot )
  49     [
  50         dup object bootstrap-word eq?
  51         [ drop \ set-slot , ] [
  52             \ pick ,
  53             "predicate" word-prop %
  54             [ [ set-slot ] [ bad-slot-value ] if ] %
  55         ] if
  56     ] [ ] make ;
  57
  58 : define-writer ( class slot-spec -- )
  59     [ offset>> ]
  60     [ name>> writer-word ]
  61     [ class>> writer-quot ]
  62     tri define-slot-word ;
  63
  64 : setter-word ( name -- word )
  65     ">>" prepend (( object value -- object )) create-accessor ;
  66
  67 : define-setter ( slot-spec -- )
  68     name>> dup setter-word dup deferred? [
  69         [ \ over , swap writer-word , ] [ ] make define-inline
  70     ] [ 2drop ] if ;
  71
  72 : changer-word ( name -- word )
  73     "change-" prepend (( object quot -- object )) create-accessor ;
  74
  75 : define-changer ( slot-spec -- )
  76     name>> dup changer-word dup deferred? [
  77         [
  78             [ over >r >r ] %
  79             over reader-word ,
  80             [ r> call r> swap ] %
  81             swap setter-word ,
  82         ] [ ] make define-inline
  83     ] [ 2drop ] if ;
  84
  85 : define-slot-methods ( class slot-spec -- )
  86     [ define-reader ]
  87     [
  88         dup read-only>> [ 2drop ] [
  89             [ define-setter drop ]
  90             [ define-changer drop ]
  91             [ define-writer ]
  92             2tri
  93         ] if
  94     ] 2bi ;
  95
  96 : define-accessors ( class specs -- )
  97     [ define-slot-methods ] with each ;
  98
  99 : define-protocol-slot ( name -- )
 100     {
 101         [ reader-word drop ]
 102         [ writer-word drop ]
 103         [ setter-word drop ]
 104         [ changer-word drop ]
 105     } cleave ;
 106
 107 GENERIC: make-slot ( desc -- slot-spec )
 108
 109 M: string make-slot
 110     <slot-spec>
 111         swap >>name ;
 112
 113 : peel-off-name ( slot-spec array -- slot-spec array )
 114     [ first >>name ] [ rest ] bi ; inline
 115
 116 : peel-off-class ( slot-spec array -- slot-spec array )
 117     dup empty? [
 118         ! We'd use class? here, but during bootstrap, we sometimes
 119         ! create slots whose class hasn't been defined yet.
 120         dup first name>> ":" tail? not [
 121             [ first >>class ] [ rest ] bi
 122         ] when
 123     ] unless ;
 124
 125 : peel-off-attributes ( slot-spec array -- slot-spec array )
 126     dup empty? [
 127         unclip {
 128             { initial: [ [ first >>initial ] [ rest ] bi ] }
 129             { read-only: [ [ first >>read-only ] [ rest ] bi ] }
 130         } case
 131     ] unless ;
 132
 133 M: array make-slot
 134     <slot-spec>
 135         swap
 136         peel-off-name
 137         peel-off-class
 138         [ dup empty? not ] [ peel-off-attributes ] [ ] while drop ;
 139
 140 : make-slots ( slots base -- specs )
 141     over length [ + ] with map
 142     [ [ make-slot ] dip >>offset ] 2map ;
 143
 144 : slot-named ( name specs -- spec/f )
 145     [ slot-spec-name = ] with find nip ;