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 : affected-methods ( class generic -- seq )
  60     "methods" word-prop swap
  61     [ nip classes-intersect? ] curry assoc-filter
  62     values ;
  63
  64 : update-generic ( class generic -- )
  65     [ affected-methods [ +called+ changed-definition ] each ]
  66     [ make-generic ]
  67     bi ;
  68
  69 : with-methods ( class generic quot -- )
  70     [ [ "methods" word-prop ] dip call ]
  71     [ drop update-generic ] 3bi ;
  72     inline
  73
  74 : method-word-name ( class word -- string )
  75     word-name "/" rot word-name 3append ;
  76
  77 PREDICATE: method-body < word
  78     "method-generic" word-prop >boolean ;
  79
  80 M: method-body stack-effect
  81     "method-generic" word-prop stack-effect ;
  82
  83 M: method-body crossref?
  84     drop t ;
  85
  86 : method-word-props ( class generic -- assoc )
  87     [
  88         "method-generic" set
  89         "method-class" set
  90     ] H{ } make-assoc ;
  91
  92 : <method> ( class generic -- method )
  93     check-method
  94     [ method-word-props ] 2keep
  95     method-word-name f <word>
  96     [ set-word-props ] keep ;
  97
  98 : reveal-method ( method class generic -- )
  99     [ set-at ] with-methods ;
 100
 101 : create-method ( class generic -- method )
 102     2dup method dup [
 103         2nip
 104     ] [
 105         drop [ <method> dup ] 2keep reveal-method
 106     ] if ;
 107
 108 : <default-method> ( generic combination -- method )
 109     object bootstrap-word pick <method>
 110     [ -rot make-default-method define ] keep ;
 111
 112 : define-default-method ( generic combination -- )
 113     dupd <default-method> "default-method" set-word-prop ;
 114
 115 ! Definition protocol
 116 M: method-spec where
 117     dup first2 method [ ] [ second ] ?if where ;
 118
 119 M: method-spec set-where
 120     first2 method set-where ;
 121
 122 M: method-spec definer
 123     first2 method definer ;
 124
 125 M: method-spec definition
 126     first2 method definition ;
 127
 128 M: method-spec forget*
 129     first2 method forget* ;
 130
 131 M: method-spec smart-usage
 132     second smart-usage ;
 133
 134 M: method-body definer
 135     drop \ M: \ ; ;
 136
 137 M: method-body forget*
 138     dup "forgotten" word-prop [ drop ] [
 139         [
 140             [ ]
 141             [ "method-class" word-prop ]
 142             [ "method-generic" word-prop ] tri
 143             3dup method eq? [
 144                 [ delete-at ] with-methods
 145                 call-next-method
 146             ] [ 3drop ] if
 147         ]
 148         [ t "forgotten" set-word-prop ] bi
 149     ] if ;
 150
 151 M: method-body smart-usage
 152     "method-generic" word-prop smart-usage ;
 153
 154 GENERIC: implementors ( class/classes -- seq )
 155
 156 M: class implementors
 157     all-words [ "methods" word-prop key? ] with filter ;
 158
 159 M: assoc implementors
 160     all-words [
 161          "methods" word-prop keys
 162         swap [ key? ] curry contains?
 163     ] with filter ;
 164
 165 : forget-methods ( class -- )
 166     [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 167
 168 M: class forget* ( class -- )
 169     [
 170         class-usages [
 171             drop
 172             [ forget-methods ]
 173             [ update-map- ]
 174             [ reset-class ]
 175             tri
 176         ] assoc-each
 177     ]
 178     [ call-next-method ] bi ;
 179
 180 M: assoc update-methods ( class assoc -- )
 181     implementors [ update-generic ] with each ;
 182
 183 : define-generic ( word combination -- )
 184     over "combination" word-prop over = [
 185         2drop
 186     ] [
 187         2dup "combination" set-word-prop
 188         over H{ } clone "methods" set-word-prop
 189         dupd define-default-method
 190         make-generic
 191     ] if ;
 192
 193 M: generic subwords
 194     [
 195         [ "default-method" word-prop , ]
 196         [ "methods" word-prop values % ]
 197         [ "engines" word-prop % ]
 198         tri
 199     ] { } make ;
 200
 201 M: generic forget*
 202     [ subwords forget-all ] [ call-next-method ] bi ;
 203
 204 : xref-generics ( -- )
 205     all-words [ subwords [ xref ] each ] each ;