1 ! Copyright (C) 2006, 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors arrays generic hashtables kernel kernel.private
\r
4 math namespaces sequences vectors words strings layouts
\r
5 combinators sequences.private classes generic.standard
\r
6 generic.standard.engines assocs ;
\r
7 IN: optimizer.specializers
\r
9 : (make-specializer) ( class picker -- quot )
\r
10 swap "predicate" word-prop append ;
\r
12 : make-specializer ( classes -- quot )
\r
13 dup length <reversed>
\r
14 [ (picker) 2array ] 2map
\r
15 [ drop object eq? not ] assoc-filter
\r
16 dup empty? [ drop [ t ] ] [
\r
17 [ (make-specializer) ] { } assoc>map
\r
18 unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
\r
21 : specializer-cases ( quot word -- default alist )
\r
22 dup [ array? ] all? [ 1array ] unless [
\r
23 [ make-specializer ] keep
\r
24 [ declare ] curry pick append
\r
27 : method-declaration ( method -- quot )
\r
28 dup "method-generic" word-prop dispatch# object <array>
\r
29 swap "method-class" word-prop prefix ;
\r
31 : specialize-method ( quot method -- quot' )
\r
32 method-declaration [ declare ] curry prepend ;
\r
34 : specialize-quot ( quot specializer -- quot' )
\r
35 specializer-cases alist>quot ;
\r
37 : standard-method? ( method -- ? )
\r
39 "method-generic" word-prop standard-generic?
\r
42 : specialized-def ( word -- quot )
\r
44 { [ dup standard-method? ] [ specialize-method ] }
\r
46 [ dup "specializer" word-prop ]
\r
47 [ "specializer" word-prop specialize-quot ]
\r
52 : specialized-length ( specializer -- n )
\r
53 dup [ array? ] all? [ first ] when length ;
\r