1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays byte-vectors classes
4 combinators definitions effects fry generic generic.single
5 generic.standard hashtables io.binary io.encodings
6 io.streams.string kernel kernel.private math math.parser
7 namespaces parser sbufs sequences sequences.private splitting
8 splitting.private strings vectors words ;
11 GENERIC: specializer-predicate ( spec -- quot )
13 M: class specializer-predicate predicate-def ;
15 M: object specializer-predicate '[ _ eq? ] ;
17 GENERIC: specializer-declaration ( spec -- class )
19 M: class specializer-declaration ;
21 M: object specializer-declaration class-of ;
23 : specializer ( word -- specializer )
24 "specializer" word-prop ;
26 : make-specializer ( specs -- quot )
27 dup length iota <reversed>
28 [ (picker) 2array ] 2map
29 [ drop object eq? ] assoc-reject
31 [ swap specializer-predicate append ] { } assoc>map
32 [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
35 : specializer-cases ( quot specializer -- alist )
36 dup [ array? ] all? [ 1array ] unless [
37 [ nip make-specializer ]
38 [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
39 ] with { } map>assoc ;
41 : specialize-quot ( quot specializer -- quot' )
42 [ drop ] [ specializer-cases ] 2bi alist>quot ;
44 : method-declaration ( method -- quot )
45 [ "method-generic" word-prop dispatch# object <array> ]
46 [ "method-class" word-prop ]
47 bi prefix [ declare ] curry [ ] like ;
49 : specialize-method ( quot method -- quot' )
50 [ method-declaration prepend ]
51 [ "method-generic" word-prop ] bi
52 specializer [ specialize-quot ] when* ;
54 : standard-method? ( method -- ? )
56 "method-generic" word-prop standard-generic?
59 : specialized-def ( word -- quot )
61 dup generic? [ drop ] [
62 [ dup standard-method? [ specialize-method ] [ drop ] if ]
63 [ specializer [ specialize-quot ] when* ]
67 : specialized-length ( specializer -- n )
68 dup [ array? ] all? [ first ] when length ;
70 ERROR: cannot-specialize word specializer ;
72 : set-specializer ( word specializer -- )
73 over inline-recursive? [ throw-cannot-specialize ] when
74 "specializer" set-word-prop ;
77 scan-object dup wrapper? [ wrapped>> ] when
78 [ changed-definition ]
79 [ subwords [ changed-definition ] each ]
80 [ parse-definition { } like set-specializer ] tri ;
82 ! Default specializers
83 { pop* pop push last } [
84 { vector } set-specializer
87 \ set-last { { object vector } } set-specializer
90 { { string sbuf } { array vector } { byte-array byte-vector } }
94 { { string string } { array array } }
98 { subseq subseq-unsafe } [
99 { { fixnum fixnum string } { fixnum fixnum array } }
104 { { string } { array } }
111 \ >string { sbuf } set-specializer
113 \ >array { { vector } } set-specializer
115 \ >vector { { array } { vector } } set-specializer
117 \ >sbuf { string } set-specializer
119 \ split { string string } set-specializer
121 \ member? { { array } { string } } set-specializer
123 \ member-eq? { { array } { string } } set-specializer
125 \ assoc-stack { vector } set-specializer
128 { { fixnum fixnum } { bignum fixnum } }
133 { byte-array } set-specializer
136 \ base> { string fixnum } set-specializer
139 { { fixnum object } { word object } }
143 { { object fixnum object } { object word object } }