-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions effects fry generic generic.single
-generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.parser namespaces parser sbufs
-sequences splitting splitting.private strings vectors words ;
+combinators definitions fry generic generic.single
+generic.standard hashtables kernel kernel.private math
+math.parser parser sbufs sequences splitting strings vectors
+words ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
-M: class specializer-predicate "predicate" word-prop ;
+M: class specializer-predicate '[ _ instance? ] ;
M: object specializer-predicate '[ _ eq? ] ;
M: class specializer-declaration ;
-M: object specializer-declaration class ;
-
-: specialized? ( types -- ? )
- [ object = ] all? not ;
+M: object specializer-declaration class-of ;
: specializer ( word -- specializer )
- [ "specializer" word-prop ]
- [ stack-effect effect-in-types ] bi
- dup specialized? [ suffix ] [ drop ] if ;
+ "specializer" word-prop ;
: make-specializer ( specs -- quot )
- dup length <reversed>
+ dup length <iota> <reversed>
[ (picker) 2array ] 2map
- [ drop object eq? not ] assoc-filter
+ [ drop object eq? ] assoc-reject
[ [ t ] ] [
[ swap specializer-predicate append ] { } assoc>map
[ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
-ERROR: type-mismatch-error word expected-types ;
-
-: fallback-def ( word -- quot )
- dup stack-effect effect-in-types dup specialized?
- [ [ type-mismatch-error ] 2curry ]
- [ drop def>> ] if ;
-
: specializer-cases ( quot specializer -- alist )
dup [ array? ] all? [ 1array ] unless [
[ nip make-specializer ]
[ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
] with { } map>assoc ;
-: specialize-quot ( quot word specializer -- quot' )
- [ drop nip fallback-def ] [ nip specializer-cases ] 3bi alist>quot ;
-
-! compiler.tree.propagation.inlining sets this to f
-SYMBOL: specialize-method?
-
-t specialize-method? set-global
+: specialize-quot ( quot specializer -- quot' )
+ [ drop ] [ specializer-cases ] 2bi alist>quot ;
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' )
- [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
- [ dup "method-generic" word-prop specializer ] bi
- [ specialize-quot ] [ drop ] if* ;
+ [ method-declaration prepend ]
+ [ "method-generic" word-prop ] bi
+ specializer [ specialize-quot ] when* ;
: standard-method? ( method -- ? )
- dup method-body? [
+ dup method? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ dup specializer [ specialize-quot ] [ drop ] if* ]
+ [ specializer [ specialize-quot ] when* ]
bi
] if ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
+ERROR: cannot-specialize word specializer ;
+
+: set-specializer ( word specializer -- )
+ over inline-recursive? [ cannot-specialize ] when
+ "specializer" set-word-prop ;
+
SYNTAX: HINTS:
scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ]
[ subwords [ changed-definition ] each ]
- [ parse-definition { } like "specializer" set-word-prop ] tri ;
+ [ parse-definition { } like set-specializer ] tri ;
! Default specializers
-{ first first2 first3 first4 }
-[ { array } "specializer" set-word-prop ] each
-
-{ last pop* pop } [
- { vector } "specializer" set-word-prop
+{ pop* pop push last } [
+ { vector } set-specializer
] each
-\ push { { vector } { sbuf } } "specializer" set-word-prop
-
-\ last { { vector } } "specializer" set-word-prop
-
-\ set-last { { object vector } } "specializer" set-word-prop
+\ set-last { { object vector } } set-specializer
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
-"specializer" set-word-prop
+set-specializer
-\ append
-{ { string string } { array array } }
-"specializer" set-word-prop
+{ append prepend } [
+ { { string string } { array array } }
+ set-specializer
+] each
+
+{ suffix prefix } [
+ { { string object } { array object } }
+ set-specializer
+] each
\ subseq
{ { fixnum fixnum string } { fixnum fixnum array } }
-"specializer" set-word-prop
+set-specializer
-\ reverse-here
+\ reverse!
{ { string } { array } }
-"specializer" set-word-prop
+set-specializer
\ mismatch
{ string string }
-"specializer" set-word-prop
-
-\ >string { sbuf } "specializer" set-word-prop
-
-\ >array { { vector } } "specializer" set-word-prop
+set-specializer
-\ >vector { { array } { vector } } "specializer" set-word-prop
+\ >string { sbuf } set-specializer
-\ >sbuf { string } "specializer" set-word-prop
+\ >array { { vector } } set-specializer
-\ split, { string string } "specializer" set-word-prop
+\ >vector { { array } { vector } } set-specializer
-\ memq? { array } "specializer" set-word-prop
+\ >sbuf { string } set-specializer
-\ member? { array } "specializer" set-word-prop
+\ split { string string } set-specializer
-\ assoc-stack { vector } "specializer" set-word-prop
+\ member? { { array } { string } } set-specializer
-\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
+\ member-eq? { { array } { string } } set-specializer
-\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
+\ assoc-stack { vector } set-specializer
-\ base> { string fixnum } "specializer" set-word-prop
+\ base> { string fixnum } set-specializer
-M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
+M\ hashtable at*
+{ { fixnum object } { word object } }
+set-specializer
-M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
+M\ hashtable set-at
+{ { object fixnum object } { object word object } }
+set-specializer
projects / factor.git / blobdiff