1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: parser words definitions kernel sequences assocs arrays
4 kernel.private fry combinators accessors vectors strings sbufs
5 byte-arrays byte-vectors io.binary io.streams.string splitting
6 math generic generic.standard generic.standard.engines classes
10 GENERIC: specializer-predicate ( spec -- quot )
12 M: class specializer-predicate "predicate" word-prop ;
14 M: object specializer-predicate '[ _ eq? ] ;
16 GENERIC: specializer-declaration ( spec -- class )
18 M: class specializer-declaration ;
20 M: object specializer-declaration class ;
22 : make-specializer ( specs -- quot )
24 [ (picker) 2array ] 2map
25 [ drop object eq? not ] assoc-filter
27 [ swap specializer-predicate append ] { } assoc>map
28 unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
31 : specializer-cases ( quot word -- default alist )
32 dup [ array? ] all? [ 1array ] unless [
33 [ make-specializer ] keep
34 [ specializer-declaration ] map '[ _ declare ] pick append
37 : method-declaration ( method -- quot )
38 [ "method-generic" word-prop dispatch# object <array> ]
39 [ "method-class" word-prop ]
42 : specialize-method ( quot method -- quot' )
43 method-declaration '[ _ declare ] prepend ;
45 : specialize-quot ( quot specializer -- quot' )
46 specializer-cases alist>quot ;
48 : standard-method? ( method -- ? )
50 "method-generic" word-prop standard-generic?
53 : specialized-def ( word -- quot )
55 [ dup standard-method? [ specialize-method ] [ drop ] if ]
56 [ "specializer" word-prop [ specialize-quot ] when* ]
59 : specialized-length ( specializer -- n )
60 dup [ array? ] all? [ first ] when length ;
64 dup method-spec? [ first2 method ] when
66 [ parse-definition "specializer" set-word-prop ] bi ;
68 ! Default specializers
69 { first first2 first3 first4 }
70 [ { array } "specializer" set-word-prop ] each
73 { vector } "specializer" set-word-prop
76 \ push { { vector } { sbuf } } "specializer" set-word-prop
79 { { string sbuf } { array vector } { byte-array byte-vector } }
80 "specializer" set-word-prop
83 { { string string } { array array } }
84 "specializer" set-word-prop
87 { { fixnum fixnum string } { fixnum fixnum array } }
88 "specializer" set-word-prop
91 { { string } { array } }
92 "specializer" set-word-prop
96 "specializer" set-word-prop
98 \ >string { sbuf } "specializer" set-word-prop
100 \ >array { { vector } } "specializer" set-word-prop
102 \ >vector { { array } { vector } } "specializer" set-word-prop
104 \ >sbuf { string } "specializer" set-word-prop
106 \ split, { string string } "specializer" set-word-prop
108 \ memq? { array } "specializer" set-word-prop
110 \ member? { array } "specializer" set-word-prop
112 \ assoc-stack { vector } "specializer" set-word-prop
114 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
116 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
118 \ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
120 \ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop