1 ! Copyright (C) 2006, 2010 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 classes.maybe classes.algebra.private ;
7 FROM: namespaces => set ;
10 ! Method combination protocol
11 GENERIC: perform-combination ( word combination -- )
13 GENERIC: make-default-method ( generic combination -- method )
15 PREDICATE: generic < word
16 "combination" word-prop >boolean ;
18 M: generic definition drop f ;
20 : make-generic ( word -- )
21 [ { "unannotated-def" } reset-props ]
22 [ dup "combination" word-prop perform-combination ]
25 PREDICATE: method < word
26 "method-generic" word-prop >boolean ;
28 ERROR: method-lookup-failed class generic ;
30 : ?lookup-method ( class generic -- method/f )
31 "methods" word-prop at ;
33 : lookup-method ( class generic -- method )
34 2dup ?lookup-method [ 2nip ] [ method-lookup-failed ] if* ;
38 : interesting-class? ( class1 class2 -- ? )
40 ! Case 1: no intersection. Discard and keep going
41 { [ 2dup classes-intersect? not ] [ 2drop t ] }
42 ! Case 2: class1 contained in class2. Add to
43 ! interesting set and keep going.
44 { [ 2dup class<= ] [ nip , t ] }
45 ! Case 3: class1 and class2 are incomparable. Give up
49 : interesting-classes ( class classes -- interesting/f )
50 [ [ interesting-class? ] with all? ] { } make and ;
54 : method-classes ( generic -- classes )
55 "methods" word-prop keys ;
57 : order ( generic -- seq )
58 method-classes sort-classes ;
60 : nearest-class ( class generic -- class/f )
61 method-classes interesting-classes smallest-class ;
63 : method-for-class ( class generic -- method/f )
64 [ nip ] [ nearest-class ] 2bi dup [ swap ?lookup-method ] [ 2drop f ] if ;
66 GENERIC: effective-method ( generic -- method )
68 \ effective-method t "no-compile" set-word-prop
70 : next-method-class ( class generic -- class/f )
71 method-classes [ class< ] with filter smallest-class ;
73 : next-method ( class generic -- method/f )
74 [ next-method-class ] keep ?lookup-method ;
76 GENERIC: next-method-quot* ( class generic combination -- quot )
78 : next-method-quot ( method -- quot )
79 next-method-quot-cache get [
80 [ "method-class" word-prop ]
82 "method-generic" word-prop
83 dup "combination" word-prop
84 ] bi next-method-quot*
87 ERROR: no-next-method method ;
89 : (call-next-method) ( method -- )
90 dup next-method-quot [ call ] [ no-next-method ] ?if ;
92 TUPLE: check-method class generic ;
94 : check-method ( classoid generic -- class generic )
95 2dup [ classoid? ] [ generic? ] bi* and [
96 \ check-method boa throw
99 : remake-generic ( generic -- )
100 dup outdated-generics get set-in-unit ;
102 : remake-generics ( -- )
103 outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
105 GENERIC: update-generic ( class generic -- )
107 : with-methods ( class generic quot -- )
108 [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
110 GENERIC# method-word-name 1 ( class generic -- string )
112 M: class method-word-name ( class generic -- string )
113 [ name>> ] bi@ "=>" glue ;
115 M: maybe method-word-name
116 [ class>> name>> ] [ name>> ] bi* "=>" glue ;
118 M: method parent-word
119 "method-generic" word-prop ;
122 "forgotten" word-prop not ;
124 : method-word-props ( class generic -- assoc )
130 : <method> ( class generic -- method )
132 [ method-word-name f <word> ] [ method-word-props ] 2bi
135 GENERIC: implementor-classes ( obj -- class )
137 M: maybe implementor-classes class>> 1array ;
139 M: class implementor-classes 1array ;
141 M: anonymous-union implementor-classes members>> ;
143 M: anonymous-intersection implementor-classes participants>> ;
145 : with-implementors ( class generic quot -- )
146 [ swap implementor-classes [ implementors-map get at ] map ] dip call ; inline
148 : reveal-method ( method classes generic -- )
149 [ [ [ conjoin ] with each ] with-implementors ]
150 [ [ set-at ] with-methods ]
153 : create-method ( class generic -- method )
154 2dup ?lookup-method dup [ 2nip dup reset-generic ] [
156 [ <method> dup ] 2keep
161 PREDICATE: default-method < word "default" word-prop ;
163 : <default-method> ( generic combination -- method )
164 [ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
165 [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
167 : define-default-method ( generic combination -- )
168 dupd <default-method> "default-method" set-word-prop ;
170 ! Definition protocol
175 dup "forgotten" word-prop [ drop ] [
177 dup default-method? [ drop ] [
179 [ "method-class" word-prop ]
180 [ "method-generic" word-prop ] bi
184 [ [ delete-at ] with-methods ]
185 [ [ [ delete-at ] with each ] with-implementors ] 2bi
190 [ call-next-method ] bi
193 : define-generic ( word combination effect -- )
194 [ nip swap set-stack-effect ]
197 2dup [ "combination" word-prop ] dip = [ 2drop ] [
199 [ drop reset-generic ]
200 [ "combination" set-word-prop ]
201 [ drop H{ } clone "methods" set-word-prop ]
202 [ define-default-method ]
207 [ 2drop remake-generic ] 3tri ;
211 [ "default-method" word-prop , ]
212 [ "methods" word-prop values % ]
213 [ "engines" word-prop % ]
217 M: class forget-methods
218 [ implementors ] [ [ swap ?lookup-method ] curry ] bi map forget-all ;