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