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