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