core/classes/classes.factor

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