core/generic/generic.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words kernel sequences namespaces assocs hashtables
   4 definitions kernel.private classes classes.private
   5 classes.algebra quotations arrays vocabs effects combinators ;
   6 IN: generic
   7
   8 ! Method combination protocol
   9 GENERIC: perform-combination ( word combination -- )
  10
  11 GENERIC: make-default-method ( generic combination -- method )
  12
  13 PREDICATE: generic < word
  14     "combination" word-prop >boolean ;
  15
  16 M: generic definition drop f ;
  17
  18 : make-generic ( word -- )
  19     [ { "unannotated-def" } reset-props ]
  20     [ dup "combination" word-prop perform-combination ]
  21     bi ;
  22
  23 : method ( class generic -- method/f )
  24     "methods" word-prop at ;
  25
  26 PREDICATE: method-spec < pair
  27     first2 generic? swap class? and ;
  28
  29 : order ( generic -- seq )
  30     "methods" word-prop keys sort-classes ;
  31
  32 : specific-method ( class word -- class )
  33     order min-class ;
  34
  35 GENERIC: effective-method ( ... generic -- method )
  36
  37 : next-method-class ( class generic -- class/f )
  38     order [ class<= ] with filter reverse dup length 1 =
  39     [ drop f ] [ second ] if ;
  40
  41 : next-method ( class generic -- class/f )
  42     [ next-method-class ] keep method ;
  43
  44 GENERIC: next-method-quot* ( class generic -- quot )
  45
  46 : next-method-quot ( class generic -- quot )
  47     dup "combination" word-prop next-method-quot* ;
  48
  49 : (call-next-method) ( class generic -- )
  50     next-method-quot call ;
  51
  52 TUPLE: check-method class generic ;
  53
  54 : check-method ( class generic -- class generic )
  55     over class? over generic? and [
  56         \ check-method boa throw
  57     ] unless ; inline
  58
  59 : with-methods ( generic quot -- )
  60     swap [ "methods" word-prop swap call ] keep make-generic ;
  61     inline
  62
  63 : method-word-name ( class word -- string )
  64     word-name "/" rot word-name 3append ;
  65
  66 PREDICATE: method-body < word
  67     "method-generic" word-prop >boolean ;
  68
  69 M: method-body stack-effect
  70     "method-generic" word-prop stack-effect ;
  71
  72 M: method-body crossref?
  73     drop t ;
  74
  75 : method-word-props ( class generic -- assoc )
  76     [
  77         "method-generic" set
  78         "method-class" set
  79     ] H{ } make-assoc ;
  80
  81 : <method> ( class generic -- method )
  82     check-method
  83     [ method-word-props ] 2keep
  84     method-word-name f <word>
  85     [ set-word-props ] keep ;
  86
  87 : reveal-method ( method class generic -- )
  88     [ set-at ] with-methods ;
  89
  90 : create-method ( class generic -- method )
  91     2dup method dup [
  92         2nip
  93     ] [
  94         drop [ <method> dup ] 2keep reveal-method
  95     ] if ;
  96
  97 : <default-method> ( generic combination -- method )
  98     object bootstrap-word pick <method>
  99     [ -rot make-default-method define ] keep ;
 100
 101 : define-default-method ( generic combination -- )
 102     dupd <default-method> "default-method" set-word-prop ;
 103
 104 ! Definition protocol
 105 M: method-spec where
 106     dup first2 method [ ] [ second ] ?if where ;
 107
 108 M: method-spec set-where
 109     first2 method set-where ;
 110
 111 M: method-spec definer
 112     first2 method definer ;
 113
 114 M: method-spec definition
 115     first2 method definition ;
 116
 117 M: method-spec forget*
 118     first2 method forget* ;
 119
 120 M: method-spec smart-usage
 121     second smart-usage ;
 122
 123 M: method-body definer
 124     drop \ M: \ ; ;
 125
 126 M: method-body forget*
 127     dup "forgotten" word-prop [ drop ] [
 128         [
 129             [ ]
 130             [ "method-class" word-prop ]
 131             [ "method-generic" word-prop ] tri
 132             3dup method eq? [
 133                 [ delete-at ] with-methods
 134                 call-next-method
 135             ] [ 3drop ] if
 136         ]
 137         [ t "forgotten" set-word-prop ] bi
 138     ] if ;
 139
 140 M: method-body smart-usage
 141     "method-generic" word-prop smart-usage ;
 142
 143 : implementors* ( classes -- words )
 144     all-words [
 145         "methods" word-prop keys
 146         swap [ key? ] curry contains?
 147     ] with filter ;
 148
 149 : implementors ( class -- seq )
 150     dup associate implementors* ;
 151
 152 : forget-methods ( class -- )
 153     [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 154
 155 M: class forget* ( class -- )
 156     [
 157         class-usages [
 158             drop
 159             [ forget-methods ]
 160             [ update-map- ]
 161             [ reset-class ]
 162             tri
 163         ] assoc-each
 164     ]
 165     [ call-next-method ] bi ;
 166
 167 M: assoc update-methods ( assoc -- )
 168     implementors* [ make-generic ] each ;
 169
 170 : define-generic ( word combination -- )
 171     over "combination" word-prop over = [
 172         2drop
 173     ] [
 174         2dup "combination" set-word-prop
 175         over H{ } clone "methods" set-word-prop
 176         dupd define-default-method
 177         make-generic
 178     ] if ;
 179
 180 M: generic subwords
 181     [
 182         [ "default-method" word-prop , ]
 183         [ "methods" word-prop values % ]
 184         [ "engines" word-prop % ]
 185         tri
 186     ] { } make ;
 187
 188 M: generic forget*
 189     [ subwords forget-all ] [ call-next-method ] bi ;
 190
 191 : xref-generics ( -- )
 192     all-words [ subwords [ xref ] each ] each ;