1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays byte-vectors classes
4 combinators definitions fry generic generic.single
5 generic.standard hashtables kernel kernel.private math
6 math.parser parser sbufs sequences splitting strings vectors
10 GENERIC: specializer-predicate ( spec -- quot )
12 M: class specializer-predicate '[ _ instance? ] ;
14 M: object specializer-predicate '[ _ eq? ] ;
16 GENERIC: specializer-declaration ( spec -- class )
18 M: class specializer-declaration ;
20 M: object specializer-declaration class-of ;
22 : specializer ( word -- specializer )
23 "specializer" word-prop ;
25 : make-specializer ( specs -- quot )
26 dup length <iota> <reversed>
27 [ (picker) 2array ] 2map
28 [ object eq? ] reject-keys
30 [ swap specializer-predicate append ] { } assoc>map
31 [ ] [ swap [ f ] \ if 3array [ ] append-as ] map-reduce
34 : specializer-cases ( quot specializer -- alist )
35 dup [ array? ] all? [ 1array ] unless [
36 [ nip make-specializer ]
37 [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
38 ] with { } map>assoc ;
40 : specialize-quot ( quot specializer -- quot' )
41 [ drop ] [ specializer-cases ] 2bi alist>quot ;
43 : method-declaration ( method -- quot )
44 [ "method-generic" word-prop dispatch# object <array> ]
45 [ "method-class" word-prop ]
46 bi prefix [ declare ] curry [ ] like ;
48 : specialize-method ( quot method -- quot' )
49 [ method-declaration prepend ]
50 [ "method-generic" word-prop ] bi
51 specializer [ specialize-quot ] when* ;
53 : standard-method? ( method -- ? )
55 "method-generic" word-prop standard-generic?
58 : specialized-def ( word -- quot )
60 dup generic? [ drop ] [
61 [ dup standard-method? [ specialize-method ] [ drop ] if ]
62 [ specializer [ specialize-quot ] when* ]
66 : specialized-length ( specializer -- n )
67 dup [ array? ] all? [ first ] when length ;
69 ERROR: cannot-specialize word specializer ;
71 : set-specializer ( word specializer -- )
72 over inline-recursive? [ cannot-specialize ] when
73 "specializer" set-word-prop ;
76 scan-object dup wrapper? [ wrapped>> ] when
77 [ changed-definition ]
78 [ subwords [ changed-definition ] each ]
79 [ parse-definition { } like set-specializer ] tri ;
81 ! Default specializers
82 { pop* pop push last } [
83 { vector } set-specializer
86 \ set-last { { object vector } } set-specializer
89 { { string sbuf } { array vector } { byte-array byte-vector } }
93 { { string string } { array array } }
98 { { string object } { array object } }
103 { { fixnum fixnum string } { fixnum fixnum array } }
107 { { string } { array } }
114 \ >string { sbuf } set-specializer
116 \ >array { { vector } } set-specializer
118 \ >vector { { array } { vector } } set-specializer
120 \ >sbuf { string } set-specializer
122 \ split { string string } set-specializer
124 \ member? { { array } { string } } set-specializer
126 \ member-eq? { { array } { string } } set-specializer
128 \ assoc-stack { vector } set-specializer
130 \ base> { string fixnum } set-specializer
133 { { fixnum object } { word object } }
137 { { object fixnum object } { object word object } }