1 ! Copyright (C) 2006, 2008 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
9 ! Method combination protocol
10 GENERIC: perform-combination ( word combination -- )
12 GENERIC: make-default-method ( generic combination -- method )
14 PREDICATE: generic < word
15 "combination" word-prop >boolean ;
17 M: generic definition drop f ;
19 : make-generic ( word -- )
20 [ { "unannotated-def" } reset-props ]
21 [ dup "combination" word-prop perform-combination ]
24 : method ( class generic -- method/f )
25 "methods" word-prop at ;
27 PREDICATE: method-spec < pair
28 first2 generic? swap class? and ;
30 : order ( generic -- seq )
31 "methods" word-prop keys sort-classes ;
33 : specific-method ( class generic -- method/f )
34 tuck order min-class dup [ swap method ] [ 2drop f ] if ;
36 GENERIC: effective-method ( generic -- method )
38 : next-method-class ( class generic -- class/f )
39 order [ class<= ] with filter reverse dup length 1 =
40 [ drop f ] [ second ] if ;
42 : next-method ( class generic -- method/f )
43 [ next-method-class ] keep method ;
45 GENERIC: next-method-quot* ( class generic combination -- quot )
47 : next-method-quot ( class generic -- quot )
48 next-method-quot-cache get [
49 dup "combination" word-prop next-method-quot*
52 : (call-next-method) ( class generic -- )
53 next-method-quot call ;
55 TUPLE: check-method class generic ;
57 : check-method ( class generic -- class generic )
58 2dup [ class? ] [ generic? ] bi* and [
59 \ check-method boa throw
62 : with-methods ( class generic quot -- )
63 [ drop changed-generic ]
64 [ [ "methods" word-prop ] dip call ]
65 [ drop make-generic drop ]
68 : method-word-name ( class word -- string )
69 [ name>> ] bi@ "=>" swap 3append ;
71 PREDICATE: method-body < word
72 "method-generic" word-prop >boolean ;
74 M: method-body inline?
75 "method-generic" word-prop inline? ;
77 M: method-body stack-effect
78 "method-generic" word-prop stack-effect ;
80 M: method-body crossref?
81 "forgotten" word-prop not ;
83 : method-word-props ( class generic -- assoc )
89 : <method> ( class generic -- method )
91 [ method-word-props ] 2keep
92 method-word-name f <word>
95 : with-implementors ( class generic quot -- )
96 [ swap implementors-map get at ] dip call ; inline
98 : reveal-method ( method class generic -- )
99 [ [ conjoin ] with-implementors ]
100 [ [ set-at ] with-methods ]
103 : create-method ( class generic -- method )
104 2dup method dup [ 2nip ] [
106 [ <method> dup ] 2keep
111 PREDICATE: default-method < word "default" word-prop ;
113 M: default-method irrelevant? drop t ;
115 : <default-method> ( generic combination -- method )
116 [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
117 [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
119 : define-default-method ( generic combination -- )
120 dupd <default-method> "default-method" set-word-prop ;
122 ! Definition protocol
124 dup first2 method [ ] [ second ] ?if where ;
126 M: method-spec set-where
127 first2 method set-where ;
129 M: method-spec definer
130 first2 method definer ;
132 M: method-spec definition
133 first2 method definition ;
135 M: method-spec forget*
136 first2 method [ forgotten-definition ] [ forget* ] bi ;
138 M: method-spec smart-usage
141 M: method-body definer
144 M: method-body forget*
145 dup "forgotten" word-prop [ drop ] [
147 dup default-method? [ drop ] [
149 [ "method-class" word-prop ]
150 [ "method-generic" word-prop ] bi
154 [ [ delete-at ] with-methods ]
155 [ [ delete-at ] with-implementors ] 2bi
160 [ call-next-method ] bi
163 M: method-body smart-usage
164 "method-generic" word-prop smart-usage ;
166 M: sequence update-methods ( class seq -- )
168 [ changed-generic ] [ make-generic drop ] 2bi
171 : define-generic ( word combination -- )
172 over "combination" word-prop over = [ drop ] [
173 2dup "combination" set-word-prop
174 over "methods" word-prop values forget-all
175 over H{ } clone "methods" set-word-prop
176 dupd define-default-method
181 [ "default-method" word-prop , ]
182 [ "methods" word-prop values % ]
183 [ "engines" word-prop % ]
188 [ subwords forget-all ] [ call-next-method ] bi ;
190 : xref-generics ( -- )
191 all-words [ subwords [ xref ] each ] each ;