1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.algebra
4 combinators debugger definitions effects effects.parser io
5 kernel make math math.order namespaces parser prettyprint
6 prettyprint.backend prettyprint.custom quotations see sequences
7 sequences.generalizations sets sorting vectors words ;
8 FROM: namespaces => set ;
12 ! PART I: Converting hook specializers
13 : canonicalize-specializer-0 ( specializer -- specializer' )
22 : canonicalize-specializer-1 ( specializer -- specializer' )
25 [ length <iota> <reversed> [ 1 + neg ] map ] keep zip
26 [ length args [ max ] change ] keep
30 [ keys [ hooks get adjoin ] each ] keep
33 : canonicalize-specializer-2 ( specializer -- specializer' )
37 { [ dup integer? ] [ ] }
38 { [ dup word? ] [ hooks get index ] }
43 : canonicalize-specializer-3 ( specializer -- specializer' )
44 [ total get object <array> <enumerated> ] dip assoc-union! seq>> ;
46 : canonicalize-specializers ( methods -- methods' hooks )
48 [ [ canonicalize-specializer-0 ] dip ] assoc-map
53 [ [ canonicalize-specializer-1 ] dip ] assoc-map
57 [ [ canonicalize-specializer-2 ] dip ] assoc-map
59 args get hooks get length + total set
61 [ [ canonicalize-specializer-3 ] dip ] assoc-map
66 : drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
68 : prepare-method ( method n -- quot )
69 [ 1quotation ] [ drop-n-quot ] bi* prepend ;
71 : prepare-methods ( methods -- methods' prologue )
72 canonicalize-specializers
73 [ length [ prepare-method ] curry assoc-map ] keep
74 [ [ get ] curry ] map concat [ ] like ;
76 ! Part II: Topologically sorting specializers
77 : maximal-element ( seq quot -- n elt )
79 swapd [ call +lt+ = ] 2curry none?
80 ] 2curry find [ "Topological sort failed" throw ] unless* ;
83 : topological-sort ( seq quot -- newseq )
84 [ >vector [ dup empty? not ] ] dip
85 [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
88 : classes< ( seq1 seq2 -- lt/eq/gt )
91 { [ 2dup eq? ] [ +eq+ ] }
92 { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
93 { [ 2dup class<= ] [ +lt+ ] }
94 { [ 2dup swap class<= ] [ +gt+ ] }
97 ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
99 : sort-methods ( alist -- alist' )
100 [ [ first ] bi@ classes< ] topological-sort ;
102 ! PART III: Creating dispatch quotation
103 : picker ( n -- quot )
108 [ 1 - picker [ dip swap ] curry ]
111 : (multi-predicate) ( class picker -- quot )
112 swap predicate-def append ;
114 : multi-predicate ( classes -- quot )
115 dup length <iota> <reversed>
116 [ picker 2array ] 2map
117 [ drop object eq? ] assoc-reject
119 [ (multi-predicate) ] { } assoc>map
120 unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
123 : argument-count ( methods -- n )
124 keys 0 [ length max ] reduce ;
126 ERROR: no-method arguments generic ;
128 : make-default-method ( methods generic -- quot )
129 [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
131 : multi-dispatch-quot ( methods generic -- quot )
132 [ make-default-method ]
133 [ drop [ [ multi-predicate ] dip ] assoc-map reverse! ]
137 PREDICATE: generic < word
138 "multi-methods" word-prop >boolean ;
140 : methods ( word -- alist )
141 "multi-methods" word-prop >alist ;
143 : make-generic ( generic -- quot )
145 [ methods prepare-methods % sort-methods ] keep
146 multi-dispatch-quot %
149 : update-generic ( word -- )
150 dup make-generic define ;
153 PREDICATE: method-body < word
154 "multi-method-generic" word-prop >boolean ;
156 M: method-body stack-effect
157 "multi-method-generic" word-prop stack-effect ;
159 M: method-body crossref?
160 "forgotten" word-prop not ;
162 : method-word-name ( specializer generic -- string )
163 [ name>> % "-" % unparse % ] "" make ;
165 : method-word-props ( specializer generic -- assoc )
167 "multi-method-generic" ,,
168 "multi-method-specializer" ,,
171 : <method> ( specializer generic -- word )
172 [ method-word-props ] 2keep
173 method-word-name f <word>
176 : with-methods ( word quot -- )
178 [ "multi-methods" word-prop ] dip call
179 ] dip update-generic ; inline
181 : reveal-method ( method classes generic -- )
182 [ set-at ] with-methods ;
184 : method ( classes word -- method )
185 "multi-methods" word-prop at ;
187 : create-method ( classes generic -- method )
191 drop [ <method> dup ] 2keep reveal-method
194 : niceify-method ( seq -- seq )
195 [ dup \ f eq? [ drop f ] when ] map ;
198 "Type check error" print
200 "Generic word " write dup generic>> pprint
201 " does not have a method applicable to inputs:" print
202 dup arguments>> short.
204 "Inputs have signature:" print
205 dup arguments>> [ class-of ] map niceify-method .
207 "Available methods: " print
208 generic>> methods canonicalize-specializers drop sort-methods
209 keys [ niceify-method ] map stack. ;
211 : forget-method ( specializer generic -- )
212 [ delete-at ] with-methods ;
214 : method>spec ( method -- spec )
215 [ "multi-method-specializer" word-prop ]
216 [ "multi-method-generic" word-prop ] bi prefix ;
218 : define-generic ( word effect -- )
219 [ set-stack-effect ] keepd
220 dup "multi-methods" word-prop [ drop ] [
221 [ H{ } clone "multi-methods" set-word-prop ]
227 SYNTAX: GENERIC: scan-new-word scan-effect define-generic ;
229 : parse-method ( -- quot classes generic )
230 parse-definition [ 2 tail ] [ second ] [ first ] tri ;
232 : create-method-in ( specializer generic -- method )
233 create-method dup save-location f set-last-word ;
235 : scan-new-method ( -- method )
236 scan-word scan-object swap create-method-in ;
238 : (METHOD:) ( -- method def ) scan-new-method parse-definition ;
240 SYNTAX: METHOD: (METHOD:) define ;
244 scan-word 1array scan-word create-method-in
248 ! Definition protocol. We qualify core generics here
249 syntax:M: generic definer drop \ GENERIC: f ;
251 syntax:M: generic definition drop f ;
253 PREDICATE: method-spec < array
254 unclip generic? [ [ class? ] all? ] dip and ;
256 syntax:M: method-spec where
257 dup unclip method [ ] [ first ] ?if-old where ;
259 syntax:M: method-spec set-where
260 unclip method set-where ;
262 syntax:M: method-spec definer
263 unclip method definer ;
265 syntax:M: method-spec definition
266 unclip method definition ;
268 syntax:M: method-spec synopsis*
269 unclip method synopsis* ;
271 syntax:M: method-spec forget*
272 unclip method forget* ;
274 syntax:M: method-body definer
277 syntax:M: method-body synopsis*
279 [ "multi-method-generic" word-prop pprint-word ]
280 [ "multi-method-specializer" word-prop pprint* ] bi ;