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