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