core/generic/generic.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors words kernel sequences namespaces make assocs
   4 hashtables definitions kernel.private classes classes.private
   5 classes.algebra quotations arrays vocabs effects combinators
   6 sets ;
   7 IN: generic
   8
   9 ! Method combination protocol
  10 GENERIC: perform-combination ( word combination -- )
  11
  12 GENERIC: make-default-method ( generic combination -- method )
  13
  14 PREDICATE: generic < word
  15     "combination" word-prop >boolean ;
  16
  17 M: generic definition drop f ;
  18
  19 : make-generic ( word -- )
  20     [ { "unannotated-def" } reset-props ]
  21     [ dup "combination" word-prop perform-combination ]
  22     bi ;
  23
  24 : method ( class generic -- method/f )
  25     "methods" word-prop at ;
  26
  27 PREDICATE: method-spec < pair
  28     first2 generic? swap class? and ;
  29
  30 : order ( generic -- seq )
  31     "methods" word-prop keys sort-classes ;
  32
  33 : specific-method ( class generic -- method/f )
  34     tuck order min-class dup [ swap method ] [ 2drop f ] if ;
  35
  36 GENERIC: effective-method ( generic -- method )
  37
  38 : next-method-class ( class generic -- class/f )
  39     order [ class<= ] with filter reverse dup length 1 =
  40     [ drop f ] [ second ] if ;
  41
  42 : next-method ( class generic -- method/f )
  43     [ next-method-class ] keep method ;
  44
  45 GENERIC: next-method-quot* ( class generic combination -- quot )
  46
  47 : next-method-quot ( class generic -- quot )
  48     next-method-quot-cache get [
  49         dup "combination" word-prop next-method-quot*
  50     ] 2cache ;
  51
  52 : (call-next-method) ( class generic -- )
  53     next-method-quot call ;
  54
  55 TUPLE: check-method class generic ;
  56
  57 : check-method ( class generic -- class generic )
  58     2dup [ class? ] [ generic? ] bi* and [
  59         \ check-method boa throw
  60     ] unless ; inline
  61
  62 : with-methods ( class generic quot -- )
  63     [ drop changed-generic ]
  64     [ [ "methods" word-prop ] dip call ]
  65     [ drop make-generic drop ]
  66     3tri ; inline
  67
  68 : method-word-name ( class word -- string )
  69     [ name>> ] bi@ "=>" swap 3append ;
  70
  71 PREDICATE: method-body < word
  72     "method-generic" word-prop >boolean ;
  73
  74 M: method-body inline?
  75     "method-generic" word-prop inline? ;
  76
  77 M: method-body stack-effect
  78     "method-generic" word-prop stack-effect ;
  79
  80 M: method-body crossref?
  81     "forgotten" word-prop not ;
  82
  83 : method-word-props ( class generic -- assoc )
  84     [
  85         "method-generic" set
  86         "method-class" set
  87     ] H{ } make-assoc ;
  88
  89 : <method> ( class generic -- method )
  90     check-method
  91     [ method-word-props ] 2keep
  92     method-word-name f <word>
  93     swap >>props ;
  94
  95 : with-implementors ( class generic quot -- )
  96     [ swap implementors-map get at ] dip call ; inline
  97
  98 : reveal-method ( method class generic -- )
  99     [ [ conjoin ] with-implementors ]
 100     [ [ set-at ] with-methods ]
 101     2bi ;
 102
 103 : create-method ( class generic -- method )
 104     2dup method dup [ 2nip ] [
 105         drop
 106         [ <method> dup ] 2keep
 107         reveal-method
 108         reset-caches
 109     ] if ;
 110
 111 PREDICATE: default-method < word "default" word-prop ;
 112
 113 M: default-method irrelevant? drop t ;
 114
 115 : <default-method> ( generic combination -- method )
 116     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 117     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 118
 119 : define-default-method ( generic combination -- )
 120     dupd <default-method> "default-method" set-word-prop ;
 121
 122 ! Definition protocol
 123 M: method-spec where
 124     dup first2 method [ ] [ second ] ?if where ;
 125
 126 M: method-spec set-where
 127     first2 method set-where ;
 128
 129 M: method-spec definer
 130     first2 method definer ;
 131
 132 M: method-spec definition
 133     first2 method definition ;
 134
 135 M: method-spec forget*
 136     first2 method [ forgotten-definition ] [ forget* ] bi ;
 137
 138 M: method-spec smart-usage
 139     second smart-usage ;
 140
 141 M: method-body definer
 142     drop \ M: \ ; ;
 143
 144 M: method-body forget*
 145     dup "forgotten" word-prop [ drop ] [
 146         [
 147             dup default-method? [ drop ] [
 148                 [
 149                     [ "method-class" word-prop ]
 150                     [ "method-generic" word-prop ] bi
 151                     2dup method
 152                 ] keep eq?
 153                 [
 154                     [ [ delete-at ] with-methods ]
 155                     [ [ delete-at ] with-implementors ] 2bi
 156                     reset-caches
 157                 ] [ 2drop ] if
 158             ] if
 159         ]
 160         [ call-next-method ] bi
 161     ] if ;
 162
 163 M: method-body smart-usage
 164     "method-generic" word-prop smart-usage ;
 165
 166 M: sequence update-methods ( class seq -- )
 167     implementors [
 168         [ changed-generic ] [ make-generic drop ] 2bi
 169     ] with each ;
 170
 171 : define-generic ( word combination -- )
 172     over "combination" word-prop over = [ drop ] [
 173         2dup "combination" set-word-prop
 174         over "methods" word-prop values forget-all
 175         over H{ } clone "methods" set-word-prop
 176         dupd define-default-method
 177     ] if make-generic ;
 178
 179 M: generic subwords
 180     [
 181         [ "default-method" word-prop , ]
 182         [ "methods" word-prop values % ]
 183         [ "engines" word-prop % ]
 184         tri
 185     ] { } make ;
 186
 187 M: generic forget*
 188     [ subwords forget-all ] [ call-next-method ] bi ;
 189
 190 : xref-generics ( -- )
 191     all-words [ subwords [ xref ] each ] each ;