core/generic/generic.factor

   1 ! Copyright (C) 2006, 2009 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 flushable?
 108     "method-generic" word-prop flushable? ;
 109
 110 M: method stack-effect
 111     "method-generic" word-prop stack-effect ;
 112
 113 M: method crossref?
 114     "forgotten" word-prop not ;
 115
 116 : method-word-props ( class generic -- assoc )
 117     [
 118         "method-generic" set
 119         "method-class" set
 120     ] H{ } make-assoc ;
 121
 122 : <method> ( class generic -- method )
 123     check-method
 124     [ method-word-name f <word> ] [ method-word-props ] 2bi
 125     >>props ;
 126
 127 : with-implementors ( class generic quot -- )
 128     [ swap implementors-map get at ] dip call ; inline
 129
 130 : reveal-method ( method class generic -- )
 131     [ [ conjoin ] with-implementors ]
 132     [ [ set-at ] with-methods ]
 133     2bi ;
 134
 135 : create-method ( class generic -- method )
 136     2dup method dup [ 2nip dup reset-generic ] [
 137         drop
 138         [ <method> dup ] 2keep
 139         reveal-method
 140         reset-caches
 141     ] if ;
 142
 143 PREDICATE: default-method < word "default" word-prop ;
 144
 145 : <default-method> ( generic combination -- method )
 146     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 147     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 148
 149 : define-default-method ( generic combination -- )
 150     dupd <default-method> "default-method" set-word-prop ;
 151
 152 ! Definition protocol
 153 M: method definer
 154     drop \ M: \ ; ;
 155
 156 M: method forget*
 157     dup "forgotten" word-prop [ drop ] [
 158         [
 159             dup default-method? [ drop ] [
 160                 [
 161                     [ "method-class" word-prop ]
 162                     [ "method-generic" word-prop ] bi
 163                     2dup method
 164                 ] keep eq?
 165                 [
 166                     [ [ delete-at ] with-methods ]
 167                     [ [ delete-at ] with-implementors ] 2bi
 168                     reset-caches
 169                 ] [ 2drop ] if
 170             ] if
 171         ]
 172         [ call-next-method ] bi
 173     ] if ;
 174
 175 : define-generic ( word combination effect -- )
 176     [ nip swap set-stack-effect ]
 177     [
 178         drop
 179         2dup [ "combination" word-prop ] dip = [ 2drop ] [
 180             {
 181                 [ drop reset-generic ]
 182                 [ "combination" set-word-prop ]
 183                 [ drop H{ } clone "methods" set-word-prop ]
 184                 [ define-default-method ]
 185             }
 186             2cleave
 187         ] if
 188     ]
 189     [ 2drop remake-generic ] 3tri ;
 190
 191 M: generic subwords
 192     [
 193         [ "default-method" word-prop , ]
 194         [ "methods" word-prop values % ]
 195         [ "engines" word-prop % ]
 196         tri
 197     ] { } make ;
 198
 199 M: generic forget*
 200     [ subwords forget-all ] [ call-next-method ] bi ;
 201
 202 M: class forget-methods
 203     [ implementors ] [ [ swap method ] curry ] bi map forget-all ;