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