1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel math sequences vectors classes classes.algebra
4 combinators arrays words assocs parser namespaces definitions
5 prettyprint prettyprint.backend quotations generalizations
6 debugger io compiler.units kernel.private effects accessors
7 hashtables sorting shuffle math.order sets ;
10 ! PART I: Converting hook specializers
11 : canonicalize-specializer-0 ( specializer -- specializer' )
20 : canonicalize-specializer-1 ( specializer -- specializer' )
23 [ length <reversed> [ 1+ neg ] map ] keep zip
24 [ length args [ max ] change ] keep
28 [ keys [ hooks get adjoin ] each ] keep
31 : canonicalize-specializer-2 ( specializer -- specializer' )
35 { [ dup integer? ] [ ] }
36 { [ dup word? ] [ hooks get index ] }
40 : canonicalize-specializer-3 ( specializer -- specializer' )
41 >r total get object <array> dup <enum> r> update ;
43 : canonicalize-specializers ( methods -- methods' hooks )
45 [ >r canonicalize-specializer-0 r> ] assoc-map
50 [ >r canonicalize-specializer-1 r> ] assoc-map
52 hooks [ natural-sort ] change
54 [ >r canonicalize-specializer-2 r> ] assoc-map
56 args get hooks get length + total set
58 [ >r canonicalize-specializer-3 r> ] assoc-map
63 : drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
65 : prepare-method ( method n -- quot )
66 [ 1quotation ] [ drop-n-quot ] bi* prepend ;
68 : prepare-methods ( methods -- methods' prologue )
69 canonicalize-specializers
70 [ length [ prepare-method ] curry assoc-map ] keep
71 [ [ get ] curry ] map concat [ ] like ;
73 ! Part II: Topologically sorting specializers
74 : maximal-element ( seq quot -- n elt )
76 swapd [ call +lt+ = ] 2curry filter empty?
77 ] 2curry find [ "Topological sort failed" throw ] unless* ;
80 : topological-sort ( seq quot -- newseq )
81 >r >vector [ dup empty? not ] r>
82 [ dupd maximal-element >r over delete-nth r> ] curry
83 [ ] produce nip ; inline
85 : classes< ( seq1 seq2 -- lt/eq/gt )
88 { [ 2dup eq? ] [ +eq+ ] }
89 { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
90 { [ 2dup class<= ] [ +lt+ ] }
91 { [ 2dup swap class<= ] [ +gt+ ] }
94 ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
96 : sort-methods ( alist -- alist' )
97 [ [ first ] bi@ classes< ] topological-sort ;
99 ! PART III: Creating dispatch quotation
100 : picker ( n -- quot )
105 [ 1- picker [ >r ] swap [ r> swap ] 3append ]
108 : (multi-predicate) ( class picker -- quot )
109 swap "predicate" word-prop append ;
111 : multi-predicate ( classes -- quot )
112 dup length <reversed>
113 [ picker 2array ] 2map
114 [ drop object eq? not ] assoc-filter
116 [ (multi-predicate) ] { } assoc>map
117 unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
120 : argument-count ( methods -- n )
121 keys 0 [ length max ] reduce ;
123 ERROR: no-method arguments generic ;
125 : make-default-method ( methods generic -- quot )
126 >r argument-count r> [ >r narray r> no-method ] 2curry ;
128 : multi-dispatch-quot ( methods generic -- quot )
129 [ make-default-method ]
130 [ drop [ >r multi-predicate r> ] assoc-map reverse ]
134 PREDICATE: generic < word
135 "multi-methods" word-prop >boolean ;
137 : methods ( word -- alist )
138 "multi-methods" word-prop >alist ;
140 : make-generic ( generic -- quot )
142 [ methods prepare-methods % sort-methods ] keep
143 multi-dispatch-quot %
146 : update-generic ( word -- )
147 dup make-generic define ;
150 PREDICATE: method-body < word
151 "multi-method-generic" word-prop >boolean ;
153 M: method-body stack-effect
154 "multi-method-generic" word-prop stack-effect ;
156 M: method-body crossref?
157 "forgotten" word-prop not ;
159 : method-word-name ( specializer generic -- string )
160 [ name>> % "-" % unparse % ] "" make ;
162 : method-word-props ( specializer generic -- assoc )
164 "multi-method-generic" set
165 "multi-method-specializer" set
168 : <method> ( specializer generic -- word )
169 [ method-word-props ] 2keep
170 method-word-name f <word>
173 : with-methods ( word quot -- )
174 over >r >r "multi-methods" word-prop
175 r> call r> update-generic ; inline
177 : reveal-method ( method classes generic -- )
178 [ set-at ] with-methods ;
180 : method ( classes word -- method )
181 "multi-methods" word-prop at ;
183 : create-method ( classes generic -- method )
187 drop [ <method> dup ] 2keep reveal-method
190 : niceify-method ( seq -- seq )
191 [ dup \ f eq? [ drop f ] when ] map ;
194 "Type check error" print
196 "Generic word " write dup generic>> pprint
197 " does not have a method applicable to inputs:" print
198 dup arguments>> short.
200 "Inputs have signature:" print
201 dup arguments>> [ class ] map niceify-method .
203 "Available methods: " print
204 generic>> methods canonicalize-specializers drop sort-methods
205 keys [ niceify-method ] map stack. ;
207 : forget-method ( specializer generic -- )
208 [ delete-at ] with-methods ;
210 : method>spec ( method -- spec )
211 [ "multi-method-specializer" word-prop ]
212 [ "multi-method-generic" word-prop ] bi prefix ;
214 : define-generic ( word -- )
215 dup "multi-methods" word-prop [
218 [ H{ } clone "multi-methods" set-word-prop ]
225 CREATE define-generic ; parsing
227 : parse-method ( -- quot classes generic )
228 parse-definition [ 2 tail ] [ second ] [ first ] tri ;
230 : create-method-in ( specializer generic -- method )
231 create-method dup save-location f set-word ;
233 : CREATE-METHOD ( -- method )
234 scan-word scan-object swap create-method-in ;
236 : (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
238 : METHOD: (METHOD:) define ; parsing
242 scan-word 1array scan-word create-method-in
246 ! Definition protocol. We qualify core generics here
250 syntax:M: generic definer drop \ GENERIC: f ;
252 syntax:M: generic definition drop f ;
254 PREDICATE: method-spec < array
255 unclip generic? >r [ class? ] all? r> and ;
257 syntax:M: method-spec where
258 dup unclip method [ ] [ first ] ?if where ;
260 syntax:M: method-spec set-where
261 unclip method set-where ;
263 syntax:M: method-spec definer
264 unclip method definer ;
266 syntax:M: method-spec definition
267 unclip method definition ;
269 syntax:M: method-spec synopsis*
270 unclip method synopsis* ;
272 syntax:M: method-spec forget*
273 unclip method forget* ;
275 syntax:M: method-body definer
278 syntax:M: method-body synopsis*
280 [ "multi-method-generic" word-prop pprint-word ]
281 [ "multi-method-specializer" word-prop pprint* ] bi ;