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
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 PREDICATE: method < word
25 "method-generic" word-prop >boolean ;
27 : method ( class generic -- method/f )
28 "methods" word-prop at ;
32 : interesting-class? ( class1 class2 -- ? )
34 ! Case 1: no intersection. Discard and keep going
35 { [ 2dup classes-intersect? not ] [ 2drop t ] }
36 ! Case 2: class1 contained in class2. Add to
37 ! interesting set and keep going.
38 { [ 2dup class<= ] [ nip , t ] }
39 ! Case 3: class1 and class2 are incomparable. Give up
43 : interesting-classes ( class classes -- interesting/f )
44 [ [ interesting-class? ] with all? ] { } make and ;
48 : method-classes ( generic -- classes )
49 "methods" word-prop keys ;
51 : order ( generic -- seq )
52 method-classes sort-classes ;
54 : nearest-class ( class generic -- class/f )
55 method-classes interesting-classes smallest-class ;
57 : method-for-class ( class generic -- method/f )
58 [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ;
60 GENERIC: effective-method ( generic -- method )
62 \ effective-method t "no-compile" set-word-prop
64 : next-method-class ( class generic -- class/f )
65 method-classes [ class< ] with filter smallest-class ;
67 : next-method ( class generic -- method/f )
68 [ next-method-class ] keep method ;
70 GENERIC: next-method-quot* ( class generic combination -- quot )
72 : next-method-quot ( method -- quot )
73 next-method-quot-cache get [
74 [ "method-class" word-prop ]
76 "method-generic" word-prop
77 dup "combination" word-prop
78 ] bi next-method-quot*
81 ERROR: no-next-method method ;
83 : (call-next-method) ( method -- )
84 dup next-method-quot [ call ] [ no-next-method ] ?if ;
86 TUPLE: check-method class generic ;
88 : check-method ( class generic -- class generic )
89 2dup [ class? ] [ generic? ] bi* and [
90 \ check-method boa throw
93 : remake-generic ( generic -- )
94 dup outdated-generics get set-in-unit ;
96 : remake-generics ( -- )
97 outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
99 GENERIC: update-generic ( class generic -- )
101 : with-methods ( class generic quot -- )
102 [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
104 : method-word-name ( class generic -- string )
105 [ name>> ] bi@ "=>" glue ;
108 "method-generic" word-prop flushable? ;
110 M: method stack-effect
111 "method-generic" word-prop stack-effect ;
114 "forgotten" word-prop not ;
116 : method-word-props ( class generic -- assoc )
122 : <method> ( class generic -- method )
124 [ method-word-name f <word> ] [ method-word-props ] 2bi
127 : with-implementors ( class generic quot -- )
128 [ swap implementors-map get at ] dip call ; inline
130 : reveal-method ( method class generic -- )
131 [ [ conjoin ] with-implementors ]
132 [ [ set-at ] with-methods ]
135 : create-method ( class generic -- method )
136 2dup method dup [ 2nip dup reset-generic ] [
138 [ <method> dup ] 2keep
143 PREDICATE: default-method < word "default" word-prop ;
145 : <default-method> ( generic combination -- method )
146 [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
147 [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
149 : define-default-method ( generic combination -- )
150 dupd <default-method> "default-method" set-word-prop ;
152 ! Definition protocol
157 dup "forgotten" word-prop [ drop ] [
159 dup default-method? [ drop ] [
161 [ "method-class" word-prop ]
162 [ "method-generic" word-prop ] bi
166 [ [ delete-at ] with-methods ]
167 [ [ delete-at ] with-implementors ] 2bi
172 [ call-next-method ] bi
175 : define-generic ( word combination effect -- )
176 [ nip swap set-stack-effect ]
179 2dup [ "combination" word-prop ] dip = [ 2drop ] [
181 [ drop reset-generic ]
182 [ "combination" set-word-prop ]
183 [ drop H{ } clone "methods" set-word-prop ]
184 [ define-default-method ]
189 [ 2drop remake-generic ] 3tri ;
193 [ "default-method" word-prop , ]
194 [ "methods" word-prop values % ]
195 [ "engines" word-prop % ]
200 [ subwords forget-all ] [ call-next-method ] bi ;
202 M: class forget-methods
203 [ implementors ] [ [ swap method ] curry ] bi map forget-all ;