core/generic/generic.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.algebra
   4 classes.algebra.private classes.maybe classes.private
   5 combinators definitions kernel make math namespaces sequences
   6 sets words ;
   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" remove-word-prop ]
  21     [ dup "combination" word-prop perform-combination ]
  22     bi ;
  23
  24 PREDICATE: method < word
  25     "method-generic" word-prop >boolean ;
  26
  27 ERROR: method-lookup-failed class generic ;
  28
  29 : ?lookup-method ( class generic -- method/f )
  30     "methods" word-prop at ;
  31
  32 : lookup-method ( class generic -- method )
  33     2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ;
  34
  35 <PRIVATE
  36
  37 : interesting-class? ( class1 class2 -- ? )
  38     {
  39         ! Case 1: no intersection. Discard and keep going
  40         { [ 2dup classes-intersect? not ] [ 2drop t ] }
  41         ! Case 2: class1 contained in class2. Add to
  42         ! interesting set and keep going.
  43         { [ 2dup class<= ] [ nip , t ] }
  44         ! Case 3: class1 and class2 are incomparable. Give up
  45         [ 2drop f ]
  46     } cond ;
  47
  48 : interesting-classes ( class classes -- interesting/f )
  49     [ [ interesting-class? ] with all? ] { } make and ;
  50
  51 PRIVATE>
  52
  53 : method-classes ( generic -- classes )
  54     "methods" word-prop keys ;
  55
  56 : order ( generic -- seq )
  57     method-classes sort-classes ;
  58
  59 : nearest-class ( class generic -- class/f )
  60     method-classes interesting-classes smallest-class ;
  61
  62 : method-for-class ( class generic -- method/f )
  63     [ nip ] [ nearest-class ] 2bi
  64     [ swap ?lookup-method ] [ drop f ] if* ;
  65
  66 GENERIC: effective-method ( generic -- method )
  67
  68 \ effective-method t "no-compile" set-word-prop
  69
  70 : next-method-class ( class generic -- class/f )
  71     method-classes [ class< ] with filter smallest-class ;
  72
  73 : next-method ( class generic -- method/f )
  74     [ next-method-class ] keep ?lookup-method ;
  75
  76 GENERIC: next-method-quot* ( class generic combination -- quot )
  77
  78 : next-method-quot ( method -- quot )
  79     next-method-quot-cache get [
  80         [ "method-class" word-prop ]
  81         [
  82             "method-generic" word-prop
  83             dup "combination" word-prop
  84         ] bi next-method-quot*
  85     ] cache ;
  86
  87 ERROR: no-next-method method ;
  88
  89 : (call-next-method) ( method -- )
  90     dup next-method-quot [ call ] [ no-next-method ] ?if ;
  91
  92 ERROR: check-method-error class generic ;
  93
  94 : check-method ( classoid generic -- class generic )
  95     2dup [ classoid? ] [ generic? ] bi* and [
  96         check-method-error
  97     ] unless ; inline
  98
  99 : remake-generic ( generic -- )
 100     outdated-generics get add-to-unit ;
 101
 102 : remake-generics ( -- )
 103     outdated-generics get members [ generic? ] filter
 104     [ make-generic ] each ;
 105
 106 GENERIC: update-generic ( class generic -- )
 107
 108 : with-methods ( class generic quot -- )
 109     [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
 110
 111 : method-word-name ( class generic -- string )
 112     [ class-name ] [ name>> ] bi* "=>" glue ;
 113
 114 M: method parent-word
 115     "method-generic" word-prop ;
 116
 117 M: method crossref?
 118     "forgotten" word-prop not ;
 119
 120 : method-word-props ( class generic -- assoc )
 121     [
 122         "method-generic" ,,
 123         "method-class" ,,
 124     ] H{ } make ;
 125
 126 : <method> ( class generic -- method )
 127     check-method
 128     [ method-word-name f <word> ] [ method-word-props ] 2bi
 129     >>props ;
 130
 131 GENERIC: implementor-classes ( obj -- class )
 132
 133 M: maybe implementor-classes class>> 1array ;
 134
 135 M: class implementor-classes 1array ;
 136
 137 M: anonymous-union implementor-classes members>> ;
 138
 139 M: anonymous-intersection implementor-classes participants>> ;
 140
 141 : with-implementors ( class generic quot -- )
 142     [ swap implementor-classes [ implementors-map get at ] map ] dip call ; inline
 143
 144 : reveal-method ( method classes generic -- )
 145     [ [ [ adjoin ] with each ] with-implementors ]
 146     [ [ set-at ] with-methods ]
 147     2bi ;
 148
 149 : create-method ( class generic -- method )
 150     2dup ?lookup-method dup [ 2nip dup reset-generic ] [
 151         drop
 152         [ <method> dup ] 2keep
 153         reveal-method
 154         reset-caches
 155     ] if ;
 156
 157 PREDICATE: default-method < word "default" word-prop ;
 158
 159 : <default-method> ( generic combination -- method )
 160     [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
 161     [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
 162
 163 : define-default-method ( generic combination -- )
 164     dupd <default-method> "default-method" set-word-prop ;
 165
 166 ! Definition protocol
 167 M: method definer
 168     drop \ M: \ ; ;
 169
 170 M: method forget*
 171     dup "forgotten" word-prop [ drop ] [
 172         [
 173             dup default-method? [ drop ] [
 174                 [
 175                     [ "method-class" word-prop ]
 176                     [ "method-generic" word-prop ] bi
 177                     2dup ?lookup-method
 178                 ] keep eq?
 179                 [
 180                     [ [ delete-at ] with-methods ]
 181                     [ [ [ delete ] with each ] with-implementors ]
 182                     2bi reset-caches
 183                 ] [ 2drop ] if
 184             ] if
 185         ]
 186         [ call-next-method ] bi
 187     ] if ;
 188
 189 GENERIC#: check-combination-effect 1 ( combination effect -- )
 190
 191 M: object check-combination-effect 2drop ;
 192
 193 : define-generic ( word combination effect -- )
 194     [ [ check-combination-effect ] keep swap set-stack-effect ]
 195     [
 196         drop
 197         2dup [ "combination" word-prop ] dip = [ 2drop ] [
 198             {
 199                 [ drop reset-generic ]
 200                 [ "combination" set-word-prop ]
 201                 [ drop H{ } clone "methods" set-word-prop ]
 202                 [ define-default-method ]
 203             }
 204             2cleave
 205         ] if
 206     ]
 207     [ 2drop remake-generic ] 3tri ;
 208
 209 M: generic subwords
 210     [
 211         [ "default-method" word-prop , ]
 212         [ "methods" word-prop values % ]
 213         [ "engines" word-prop % ]
 214         tri
 215     ] { } make ;
 216
 217 M: class forget-methods
 218     [ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;