core/classes/classes.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays definitions assocs kernel kernel.private
   4 slots.private namespaces make sequences strings words vectors
   5 math quotations combinators sorting effects graphs vocabs sets ;
   6 IN: classes
   7
   8 SYMBOL: class<=-cache
   9 SYMBOL: class-not-cache
  10 SYMBOL: classes-intersect-cache
  11 SYMBOL: class-and-cache
  12 SYMBOL: class-or-cache
  13
  14 : init-caches ( -- )
  15     H{ } clone class<=-cache set
  16     H{ } clone class-not-cache set
  17     H{ } clone classes-intersect-cache set
  18     H{ } clone class-and-cache set
  19     H{ } clone class-or-cache set ;
  20
  21 : reset-caches ( -- )
  22     class<=-cache get clear-assoc
  23     class-not-cache get clear-assoc
  24     classes-intersect-cache get clear-assoc
  25     class-and-cache get clear-assoc
  26     class-or-cache get clear-assoc ;
  27
  28 SYMBOL: update-map
  29
  30 SYMBOL: implementors-map
  31
  32 PREDICATE: class < word
  33     "class" word-prop ;
  34
  35 : classes ( -- seq ) implementors-map get keys ;
  36
  37 : predicate-word ( word -- predicate )
  38     [ name>> "?" append ] [ vocabulary>> ] bi create ;
  39
  40 PREDICATE: predicate < word "predicating" word-prop >boolean ;
  41
  42 : define-predicate ( class quot -- )
  43     >r "predicate" word-prop first
  44     r> (( object -- ? )) define-declared ;
  45
  46 : superclass ( class -- super )
  47     #! Output f for non-classes to work with algebra code
  48     dup class? [ "superclass" word-prop ] [ drop f ] if ;
  49
  50 : superclasses ( class -- supers )
  51     [ superclass ] follow reverse ;
  52
  53 : members ( class -- seq )
  54     #! Output f for non-classes to work with algebra code
  55     dup class? [ "members" word-prop ] [ drop f ] if ;
  56
  57 : participants ( class -- seq )
  58     #! Output f for non-classes to work with algebra code
  59     dup class? [ "participants" word-prop ] [ drop f ] if ;
  60
  61 GENERIC: rank-class ( class -- n )
  62
  63 GENERIC: reset-class ( class -- )
  64
  65 M: class reset-class
  66     {
  67         "class"
  68         "metaclass"
  69         "superclass"
  70         "members"
  71         "participants"
  72         "predicate"
  73     } reset-props ;
  74
  75 M: word reset-class drop ;
  76
  77 GENERIC: implementors ( class/classes -- seq )
  78
  79 ! update-map
  80 : class-uses ( class -- seq )
  81     [
  82         [ members % ]
  83         [ participants % ]
  84         [ superclass [ , ] when* ]
  85         tri
  86     ] { } make ;
  87
  88 : class-usage ( class -- seq ) update-map get at ;
  89
  90 : class-usages ( class -- seq ) [ class-usage ] closure keys ;
  91
  92 <PRIVATE
  93
  94 : update-map+ ( class -- )
  95     dup class-uses update-map get add-vertex ;
  96
  97 : update-map- ( class -- )
  98     dup class-uses update-map get remove-vertex ;
  99
 100 M: class implementors implementors-map get at keys ;
 101
 102 M: sequence implementors [ implementors ] gather ;
 103
 104 : implementors-map+ ( class -- )
 105     H{ } clone swap implementors-map get set-at ;
 106
 107 : implementors-map- ( class -- )
 108     implementors-map get delete-at ;
 109
 110 : make-class-props ( superclass members participants metaclass -- assoc )
 111     [
 112         {
 113             [ dup [ bootstrap-word ] when "superclass" set ]
 114             [ [ bootstrap-word ] map "members" set ]
 115             [ [ bootstrap-word ] map "participants" set ]
 116             [ "metaclass" set ]
 117         } spread
 118     ] H{ } make-assoc ;
 119
 120 : (define-class) ( word props -- )
 121     >r
 122     dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
 123     dup reset-class
 124     dup deferred? [ dup define-symbol ] when
 125     dup redefined
 126     dup props>>
 127     r> assoc-union >>props
 128     dup predicate-word
 129     [ 1quotation "predicate" set-word-prop ]
 130     [ swap "predicating" set-word-prop ]
 131     [ drop t "class" set-word-prop ]
 132     2tri ;
 133
 134 PRIVATE>
 135
 136 GENERIC: update-class ( class -- )
 137
 138 M: class update-class drop ;
 139
 140 GENERIC: update-methods ( class seq -- )
 141
 142 : update-classes ( class -- )
 143     dup class-usages
 144     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 145
 146 : define-class ( word superclass members participants metaclass -- )
 147     #! If it was already a class, update methods after.
 148     reset-caches
 149     make-class-props
 150     [ drop update-map- ]
 151     [ (define-class) ]
 152     [ drop update-map+ ]
 153     2tri ;
 154
 155 : forget-predicate ( class -- )
 156     dup "predicate" word-prop
 157     dup length 1 = [
 158         first
 159         tuck "predicating" word-prop =
 160         [ forget ] [ drop ] if
 161     ] [ 2drop ] if ;
 162
 163 : forget-methods ( class -- )
 164     [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 165
 166 GENERIC: class-forgotten ( use class -- )
 167
 168 : forget-class ( class -- )
 169     {
 170         [ dup class-usage keys [ class-forgotten ] with each ]
 171         [ forget-predicate ]
 172         [ forget-methods ]
 173         [ implementors-map- ]
 174         [ update-map- ]
 175         [ reset-class ]
 176     } cleave ;
 177
 178 M: class class-forgotten
 179     nip forget-class ;
 180
 181 M: class forget* ( class -- )
 182     [ call-next-method ] [ forget-class ] bi ;
 183
 184 GENERIC: class ( object -- class )
 185
 186 GENERIC: instance? ( object class -- ? ) flushable