core/generic/generic.factor

   1 ! Copyright (C) 2006, 2010 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 FROM: namespaces => set ;
   8 IN: generic
   9
  10 ! Method combination protocol
  11 GENERIC: perform-combination ( word combination -- )
  12
  13 GENERIC: make-default-method ( generic combination -- method )
  14
  15 PREDICATE: generic < word
  16     "combination" word-prop >boolean ;
  17
  18 M: generic definition drop f ;
  19
  20 : make-generic ( word -- )
  21     [ { "unannotated-def" } reset-props ]
  22     [ dup "combination" word-prop perform-combination ]
  23     bi ;
  24
  25 PREDICATE: method < word
  26     "method-generic" word-prop >boolean ;
  27
  28 : method ( class generic -- method/f )
  29     "methods" word-prop at ;
  30
  31 <PRIVATE
  32
  33 : interesting-class? ( class1 class2 -- ? )
  34     {
  35         ! Case 1: no intersection. Discard and keep going
  36         { [ 2dup classes-intersect? not ] [ 2drop t ] }
  37         ! Case 2: class1 contained in class2. Add to
  38         ! interesting set and keep going.
  39         { [ 2dup class<= ] [ nip , t ] }
  40         ! Case 3: class1 and class2 are incomparable. Give up
  41         [ 2drop f ]
  42     } cond ;
  43
  44 : interesting-classes ( class classes -- interesting/f )
  45     [ [ interesting-class? ] with all? ] { } make and ;
  46
  47 PRIVATE>
  48
  49 : method-classes ( generic -- classes )
  50     "methods" word-prop keys ;
  51
  52 : order ( generic -- seq )
  53     method-classes sort-classes ;
  54
  55 : nearest-class ( class generic -- class/f )
  56     method-classes interesting-classes smallest-class ;
  57
  58 : method-for-class ( class generic -- method/f )
  59     [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
  60
  61 GENERIC: effective-method ( generic -- method )
  62
  63 \ effective-method t "no-compile" set-word-prop
  64
  65 : next-method-class ( class generic -- class/f )
  66     method-classes [ class< ] with filter smallest-class ;
  67
  68 : next-method ( class generic -- method/f )
  69     [ next-method-class ] keep method ;
  70
  71 GENERIC: next-method-quot* ( class generic combination -- quot )
  72
  73 : next-method-quot ( method -- quot )
  74     next-method-quot-cache get [
  75         [ "method-class" word-prop ]
  76         [
  77             "method-generic" word-prop
  78             dup "combination" word-prop
  79         ] bi next-method-quot*
  80     ] cache ;
  81
  82 ERROR: no-next-method method ;
  83
  84 : (call-next-method) ( method -- )
  85     dup next-method-quot [ call ] [ no-next-method ] ?if ;
  86
  87 TUPLE: check-method class generic ;
  88
  89 : check-method ( class generic -- class generic )
  90     2dup [ class? ] [ generic? ] bi* and [
  91         \ check-method boa throw
  92     ] unless ; inline
  93
  94 : remake-generic ( generic -- )
  95     dup outdated-generics get set-in-unit ;
  96
  97 : remake-generics ( -- )
  98     outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
  99
 100 GENERIC: update-generic ( class generic -- )
 101
 102 : with-methods ( class generic quot -- )
 103     [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
 104
 105 : method-word-name ( class generic -- string )
 106     [ name>> ] bi@ "=>" glue ;
 107
 108 M: method parent-word
 109     "method-generic" word-prop ;
 110
 111 M: method crossref?
 112     "forgotten" word-prop not ;
 113
 114 : method-word-props ( class generic -- assoc )
 115     [
 116         "method-generic" set
 117         "method-class" set
 118     ] H{ } make-assoc ;
 119
 120 : <method> ( class generic -- method )
 121     check-method
 122     [ method-word-name f <word> ] [ method-word-props ] 2bi
 123     >>props ;
 124
 125 : with-implementors ( class generic quot -- )
 126     [ swap implementors-map get at ] dip call ; inline
 127
 128 : reveal-method ( method class generic -- )
 129     [ [ conjoin ] with-implementors ]
 130     [ [ set-at ] with-methods ]
 131     2bi ;
 132
 133 : create-method ( class generic -- method )
 134     2dup method dup [ 2nip dup reset-generic ] [
 135         drop
 136         [ <method> dup ] 2keep
 137         reveal-method
 138         reset-caches
 139     ] if ;
 140
 141 PREDICATE: default-method < word "default" word-prop ;
 142
 143 : <default-method> ( generic combination -- method )
 144     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 145     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 146
 147 : define-default-method ( generic combination -- )
 148     dupd <default-method> "default-method" set-word-prop ;
 149
 150 ! Definition protocol
 151 M: method definer
 152     drop \ M: \ ; ;
 153
 154 M: method forget*
 155     dup "forgotten" word-prop [ drop ] [
 156         [
 157             dup default-method? [ drop ] [
 158                 [
 159                     [ "method-class" word-prop ]
 160                     [ "method-generic" word-prop ] bi
 161                     2dup method
 162                 ] keep eq?
 163                 [
 164                     [ [ delete-at ] with-methods ]
 165                     [ [ delete-at ] with-implementors ] 2bi
 166                     reset-caches
 167                 ] [ 2drop ] if
 168             ] if
 169         ]
 170         [ call-next-method ] bi
 171     ] if ;
 172
 173 : define-generic ( word combination effect -- )
 174     [ nip swap set-stack-effect ]
 175     [
 176         drop
 177         2dup [ "combination" word-prop ] dip = [ 2drop ] [
 178             {
 179                 [ drop reset-generic ]
 180                 [ "combination" set-word-prop ]
 181                 [ drop H{ } clone "methods" set-word-prop ]
 182                 [ define-default-method ]
 183             }
 184             2cleave
 185         ] if
 186     ]
 187     [ 2drop remake-generic ] 3tri ;
 188
 189 M: generic subwords
 190     [
 191         [ "default-method" word-prop , ]
 192         [ "methods" word-prop values % ]
 193         [ "engines" word-prop % ]
 194         tri
 195     ] { } make ;
 196
 197 M: class forget-methods
 198     [ implementors ] [ [ swap method ] curry ] bi map forget-all ;