Add some more compiled-usage tests

db4
Slava Pestov 2008-01-02 23:08:28 -04:00
parent 3fd5d8c40e
commit c86e95bc30
3 changed files with 40 additions and 5 deletions

View File

@ -22,11 +22,18 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-usage ( word -- seq )
compiled-crossref get at keys ;
: sensitive? ( word -- ? )
dup "inline" word-prop
over "infer" word-prop
pick "specializer" word-prop
roll generic?
or or or ;
: compiled-usages ( words -- seq )
compiled-crossref get [
[
over dup set
over "inline" word-prop pick generic? or
over sensitive?
[ at namespace swap update ] [ 2drop ] if
] curry each
] H{ } make-assoc keys ;

View File

@ -143,3 +143,33 @@ DEFER: g-test-7
[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
[ 138 ] [ g-test-7 ] unit-test
USE: macros
DEFER: macro-test-3
[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
[ 625 ] [ 5 macro-test-3 ] unit-test
[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
[ 8 ] [ 5 macro-test-3 ] unit-test
USE: hints
DEFER: hints-test-2
[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
[ 8 ] [ hints-test-2 ] unit-test
[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
[ 10 ] [ hints-test-2 ] unit-test

View File

@ -76,7 +76,7 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ;
M: wrapper apply-object wrapped apply-literal ;
M: wrapper apply-object wrapped dup depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@ -336,7 +336,6 @@ TUPLE: unbalanced-branches-error quots in out ;
recursive-label #call-label [ consume/produce ] keep
set-node-in-d
] [
dup depends-on
over effect-in length reify-curries
#call consume/produce
] if ;
@ -437,7 +436,6 @@ M: #call-label collect-recursion*
[ set ] 2each ;
: inline-word ( word -- )
dup depends-on
dup inline-block over recursive-label? [
flatten-meta-d >r
drop join-values inline-block apply-infer
@ -451,7 +449,7 @@ M: #call-label collect-recursion*
] if ;
M: word apply-object
[
dup depends-on [
dup inline-recursive-label
[ declared-infer ] [ inline-word ] if
] [