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 compiler.units ;
   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 [
  25     remake-generics get keys
  26     [ generic? ] filter [ make-generic ] each
  27 ] remake-generics-hook set-global
  28
  29 : method ( class generic -- method/f )
  30     "methods" word-prop at ;
  31
  32 PREDICATE: method-spec < pair
  33     first2 generic? swap class? and ;
  34
  35 : order ( generic -- seq )
  36     "methods" word-prop keys sort-classes ;
  37
  38 : specific-method ( class generic -- method/f )
  39     [ nip ] [ order min-class ] 2bi
  40     dup [ swap method ] [ 2drop f ] if ;
  41
  42 GENERIC: effective-method ( generic -- method )
  43
  44 : next-method-class ( class generic -- class/f )
  45     order [ class<= ] with filter reverse dup length 1 =
  46     [ drop f ] [ second ] if ;
  47
  48 : next-method ( class generic -- method/f )
  49     [ next-method-class ] keep method ;
  50
  51 GENERIC: next-method-quot* ( class generic combination -- quot )
  52
  53 : next-method-quot ( method -- quot )
  54     next-method-quot-cache get [
  55         [ "method-class" word-prop ]
  56         [
  57             "method-generic" word-prop
  58             dup "combination" word-prop
  59         ] bi next-method-quot*
  60     ] cache ;
  61
  62 ERROR: no-next-method method ;
  63
  64 : (call-next-method) ( method -- )
  65     dup next-method-quot [ call ] [ no-next-method ] ?if ;
  66
  67 TUPLE: check-method class generic ;
  68
  69 : check-method ( class generic -- class generic )
  70     2dup [ class? ] [ generic? ] bi* and [
  71         \ check-method boa throw
  72     ] unless ; inline
  73
  74 : with-methods ( class generic quot -- )
  75     [ drop changed-generic ]
  76     [ [ "methods" word-prop ] dip call ]
  77     [ drop remake-generic drop ]
  78     3tri ; inline
  79
  80 : method-word-name ( class word -- string )
  81     [ name>> ] bi@ "=>" glue ;
  82
  83 PREDICATE: method-body < word
  84     "method-generic" word-prop >boolean ;
  85
  86 M: method-body stack-effect
  87     "method-generic" word-prop stack-effect ;
  88
  89 M: method-body crossref?
  90     "forgotten" word-prop not ;
  91
  92 : method-word-props ( class generic -- assoc )
  93     [
  94         "method-generic" set
  95         "method-class" set
  96     ] H{ } make-assoc ;
  97
  98 : <method> ( class generic -- method )
  99     check-method
 100     [ method-word-props ] 2keep
 101     method-word-name f <word>
 102     swap >>props ;
 103
 104 : with-implementors ( class generic quot -- )
 105     [ swap implementors-map get at ] dip call ; inline
 106
 107 : reveal-method ( method class generic -- )
 108     [ [ conjoin ] with-implementors ]
 109     [ [ set-at ] with-methods ]
 110     2bi ;
 111
 112 : create-method ( class generic -- method )
 113     2dup method dup [ 2nip ] [
 114         drop
 115         [ <method> dup ] 2keep
 116         reveal-method
 117         reset-caches
 118     ] if ;
 119
 120 PREDICATE: default-method < word "default" word-prop ;
 121
 122 M: default-method irrelevant? drop t ;
 123
 124 : <default-method> ( generic combination -- method )
 125     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 126     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 127
 128 : define-default-method ( generic combination -- )
 129     dupd <default-method> "default-method" set-word-prop ;
 130
 131 ! Definition protocol
 132 M: method-spec where
 133     dup first2 method [ ] [ second ] ?if where ;
 134
 135 M: method-spec set-where
 136     first2 method set-where ;
 137
 138 M: method-spec definer
 139     first2 method definer ;
 140
 141 M: method-spec definition
 142     first2 method definition ;
 143
 144 M: method-spec forget*
 145     first2 method [ forgotten-definition ] [ forget* ] bi ;
 146
 147 M: method-spec smart-usage
 148     second smart-usage ;
 149
 150 M: method-body definer
 151     drop \ M: \ ; ;
 152
 153 M: method-body forget*
 154     dup "forgotten" word-prop [ drop ] [
 155         [
 156             dup default-method? [ drop ] [
 157                 [
 158                     [ "method-class" word-prop ]
 159                     [ "method-generic" word-prop ] bi
 160                     2dup method
 161                 ] keep eq?
 162                 [
 163                     [ [ delete-at ] with-methods ]
 164                     [ [ delete-at ] with-implementors ] 2bi
 165                     reset-caches
 166                 ] [ 2drop ] if
 167             ] if
 168         ]
 169         [ call-next-method ] bi
 170     ] if ;
 171
 172 M: method-body smart-usage
 173     "method-generic" word-prop smart-usage ;
 174
 175 M: sequence update-methods ( class seq -- )
 176     implementors [
 177         [ changed-generic ] [ remake-generic drop ] 2bi
 178     ] with each ;
 179
 180 : define-generic ( word combination -- )
 181     over "combination" word-prop over = [ drop ] [
 182         2dup "combination" set-word-prop
 183         over "methods" word-prop values forget-all
 184         over H{ } clone "methods" set-word-prop
 185         dupd define-default-method
 186     ] if remake-generic ;
 187
 188 M: generic subwords
 189     [
 190         [ "default-method" word-prop , ]
 191         [ "methods" word-prop values % ]
 192         [ "engines" word-prop % ]
 193         tri
 194     ] { } make ;
 195
 196 M: generic forget*
 197     [ subwords forget-all ] [ call-next-method ] bi ;
 198
 199 : xref-generics ( -- )
 200     all-words [ subwords [ xref ] each ] each ;