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 ;
   6 IN: slots
   7
   8 TUPLE: slot-spec type name offset reader writer ;
   9
  10 C: <slot-spec> slot-spec
  11
  12 : define-typecheck ( class generic quot -- )
  13     [
  14         dup define-simple-generic
  15         create-method
  16     ] dip define ;
  17
  18 : define-slot-word ( class slot word quot -- )
  19     rot >fixnum prefix define-typecheck ;
  20
  21 : reader-quot ( decl -- quot )
  22     [
  23         \ slot ,
  24         dup object bootstrap-word eq?
  25         [ drop ] [ 1array , \ declare , ] if
  26     ] [ ] make ;
  27
  28 : create-accessor ( name effect -- word )
  29     >r "accessors" create dup r>
  30     "declared-effect" set-word-prop ;
  31
  32 : reader-word ( name -- word )
  33     ">>" append (( object -- value )) create-accessor ;
  34
  35 : define-reader ( class slot name decl -- )
  36     [ reader-word ] dip reader-quot define-slot-word ;
  37
  38 : writer-word ( name -- word )
  39     "(>>" swap ")" 3append (( value object -- )) create-accessor ;
  40
  41 ERROR: bad-slot-value value object index ;
  42
  43 : writer-quot ( decl -- quot )
  44     [
  45         dup object bootstrap-word eq?
  46         [ drop \ set-slot , ] [
  47             \ pick ,
  48             "predicate" word-prop %
  49             [ [ set-slot ] [ bad-slot-value ] if ] %
  50         ] if
  51     ] [ ] make ;
  52
  53 : define-writer ( class slot name decl -- )
  54     [ writer-word ] dip writer-quot define-slot-word ;
  55
  56 : setter-word ( name -- word )
  57     ">>" prepend (( object value -- object )) create-accessor ;
  58
  59 : define-setter ( name -- )
  60     dup setter-word dup deferred? [
  61         [ \ over , swap writer-word , ] [ ] make define-inline
  62     ] [ 2drop ] if ;
  63
  64 : changer-word ( name -- word )
  65     "change-" prepend (( object quot -- object )) create-accessor ;
  66
  67 : define-changer ( name -- )
  68     dup changer-word dup deferred? [
  69         [
  70             [ over >r >r ] %
  71             over reader-word ,
  72             [ r> call r> swap ] %
  73             swap setter-word ,
  74         ] [ ] make define-inline
  75     ] [ 2drop ] if ;
  76
  77 : define-slot-methods ( class slot-spec -- )
  78     {
  79         [ [ drop ] [ name>> ] bi* define-changer ]
  80         [ [ drop ] [ name>> ] bi* define-setter ]
  81         [ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ]
  82         [ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ]
  83     } 2cleave ;
  84
  85 : define-accessors ( class specs -- )
  86     [ define-slot-methods ] with each ;
  87
  88 : slot-named ( name specs -- spec/f )
  89     [ slot-spec-name = ] with find nip ;