core/classes/classes.factor

   1 ! Copyright (C) 2004, 2010 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 words.symbol
   5 vectors math quotations combinators sorting effects graphs
   6 vocabs sets ;
   7 FROM: namespaces => set ;
   8 IN: classes
   9
  10 ERROR: bad-inheritance class superclass ;
  11
  12 PREDICATE: class < word "class" word-prop ;
  13
  14 <PRIVATE
  15
  16 SYMBOL: class<=-cache
  17 SYMBOL: class-not-cache
  18 SYMBOL: classes-intersect-cache
  19 SYMBOL: class-and-cache
  20 SYMBOL: class-or-cache
  21 SYMBOL: next-method-quot-cache
  22
  23 : init-caches ( -- )
  24     H{ } clone class<=-cache set
  25     H{ } clone class-not-cache set
  26     H{ } clone classes-intersect-cache set
  27     H{ } clone class-and-cache set
  28     H{ } clone class-or-cache set
  29     H{ } clone next-method-quot-cache set ;
  30
  31 : reset-caches ( -- )
  32     class<=-cache get clear-assoc
  33     class-not-cache get clear-assoc
  34     classes-intersect-cache get clear-assoc
  35     class-and-cache get clear-assoc
  36     class-or-cache get clear-assoc
  37     next-method-quot-cache get clear-assoc ;
  38
  39 SYMBOL: update-map
  40
  41 SYMBOL: implementors-map
  42
  43 GENERIC: rank-class ( class -- n )
  44
  45 GENERIC: reset-class ( class -- )
  46
  47 M: class reset-class
  48     {
  49         "class"
  50         "metaclass"
  51         "superclass"
  52         "members"
  53         "participants"
  54         "predicate"
  55     } reset-props ;
  56
  57 M: word reset-class drop ;
  58
  59 PRIVATE>
  60
  61 : classes ( -- seq ) implementors-map get keys ;
  62
  63 PREDICATE: predicate < word "predicating" word-prop >boolean ;
  64
  65 : create-predicate-word ( word -- predicate )
  66     [ name>> "?" append ] [ vocabulary>> ] bi create
  67     dup predicate? [ dup reset-generic ] unless ;
  68
  69 : predicate-word ( word -- predicate )
  70     "predicate" word-prop first ;
  71
  72 M: predicate flushable? drop t ;
  73
  74 M: predicate forget*
  75     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
  76
  77 M: predicate reset-word
  78     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
  79
  80 : define-predicate ( class quot -- )
  81     [ predicate-word ] dip (( object -- ? )) define-declared ;
  82
  83 : superclass ( class -- super )
  84     #! Output f for non-classes to work with algebra code
  85     dup class? [ "superclass" word-prop ] [ drop f ] if ;
  86
  87 : superclasses ( class -- supers )
  88     [ superclass ] follow reverse ;
  89
  90 : superclass-of? ( class superclass -- ? )
  91     superclasses member-eq? ;
  92
  93 : subclass-of? ( class superclass -- ? )
  94     swap superclass-of? ;
  95
  96 : members ( class -- seq )
  97     #! Output f for non-classes to work with algebra code
  98     dup class? [ "members" word-prop ] [ drop f ] if ;
  99
 100 : participants ( class -- seq )
 101     #! Output f for non-classes to work with algebra code
 102     dup class? [ "participants" word-prop ] [ drop f ] if ;
 103
 104 GENERIC: implementors ( class/classes -- seq )
 105
 106 ! update-map
 107 : class-uses ( class -- seq )
 108     [
 109         [ members % ]
 110         [ participants % ]
 111         [ superclass [ , ] when* ]
 112         tri
 113     ] { } make ;
 114
 115 : class-usage ( class -- seq ) update-map get at ;
 116
 117 : class-usages ( class -- seq ) [ class-usage ] closure keys ;
 118
 119 M: class implementors implementors-map get at keys ;
 120
 121 M: sequence implementors [ implementors ] gather ;
 122
 123 <PRIVATE
 124
 125 : update-map+ ( class -- )
 126     dup class-uses update-map get add-vertex ;
 127
 128 : update-map- ( class -- )
 129     dup class-uses update-map get remove-vertex ;
 130
 131 : implementors-map+ ( class -- )
 132     [ H{ } clone ] dip implementors-map get set-at ;
 133
 134 : implementors-map- ( class -- )
 135     implementors-map get delete-at ;
 136
 137 : make-class-props ( superclass members participants metaclass -- assoc )
 138     [
 139         {
 140             [ dup [ bootstrap-word ] when "superclass" set ]
 141             [ [ bootstrap-word ] map "members" set ]
 142             [ [ bootstrap-word ] map "participants" set ]
 143             [ "metaclass" set ]
 144         } spread
 145     ] H{ } make-assoc ;
 146
 147 GENERIC: metaclass-changed ( use class -- )
 148
 149 : ?metaclass-changed ( class usages/f -- )
 150     dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
 151
 152 : check-metaclass ( class metaclass -- usages/f )
 153     over class? [
 154         over "metaclass" word-prop eq?
 155         [ drop f ] [ class-usage keys ] if
 156     ] [ 2drop f ] if ;
 157
 158 : ?define-symbol ( word -- )
 159     dup deferred? [ define-symbol ] [ drop ] if ;
 160
 161 : (define-class) ( word props -- )
 162     reset-caches
 163     2dup "metaclass" swap at check-metaclass
 164     {
 165         [ 2drop update-map- ]
 166         [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
 167         [ 2drop ?define-symbol ]
 168         [ drop [ assoc-union ] curry change-props drop ]
 169         [
 170             2drop
 171             dup create-predicate-word
 172             [ 1quotation "predicate" set-word-prop ]
 173             [ swap "predicating" set-word-prop ]
 174             2bi
 175         ]
 176         [ 2drop t "class" set-word-prop ]
 177         [ 2drop update-map+ ]
 178         [ nip ?metaclass-changed ]
 179     } 3cleave ;
 180
 181 GENERIC: update-class ( class -- )
 182
 183 M: class update-class drop ;
 184
 185 GENERIC: update-methods ( class seq -- )
 186
 187 : update-classes ( class -- )
 188     dup class-usages
 189     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 190
 191 : check-inheritance ( subclass superclass -- )
 192     2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
 193
 194 : define-class ( word superclass members participants metaclass -- )
 195     [ 2dup check-inheritance ] 3dip
 196     make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
 197
 198 : forget-predicate ( class -- )
 199     dup "predicate" word-prop
 200     dup length 1 = [
 201         first
 202         [ nip ] [ "predicating" word-prop = ] 2bi
 203         [ forget ] [ drop ] if
 204     ] [ 2drop ] if ;
 205
 206 GENERIC: forget-methods ( class -- )
 207
 208 PRIVATE>
 209
 210 : forget-class ( class -- )
 211     dup f check-metaclass {
 212         [ drop forget-predicate ]
 213         [ drop forget-methods ]
 214         [ drop implementors-map- ]
 215         [ drop update-map- ]
 216         [ drop reset-class ]
 217         [ 2drop reset-caches ]
 218         [ ?metaclass-changed ]
 219     } 2cleave ;
 220
 221 M: class metaclass-changed
 222     swap class? [ drop ] [ forget-class ] if ;
 223
 224 M: class forget* ( class -- )
 225     [ call-next-method ] [ forget-class ] bi ;
 226
 227 GENERIC: class ( object -- class )
 228
 229 GENERIC: instance? ( object class -- ? ) flushable