namespaces: removing make-assoc in favor of explicit get's.

db4
John Benediktsson 2014-04-24 09:16:14 -07:00
parent c9585b936b
commit 9d3a654443
5 changed files with 42 additions and 15 deletions

View File

@ -57,6 +57,8 @@ SYMBOL: infer-children-data
value-infos off value-infos off
constraints off ; constraints off ;
DEFER: collect-variables
: infer-children ( node -- ) : infer-children ( node -- )
[ live-children ] [ child-constraints ] bi [ [ live-children ] [ child-constraints ] bi [
[ [
@ -64,7 +66,8 @@ SYMBOL: infer-children-data
[ copy-value-info assume (propagate) ] [ copy-value-info assume (propagate) ]
[ 2drop no-value-info ] [ 2drop no-value-info ]
if if
] H{ } make-assoc collect-variables
] with-scope
] 2map infer-children-data set ; ] 2map infer-children-data set ;
: compute-phi-input-infos ( phi-in -- phi-info ) : compute-phi-input-infos ( phi-in -- phi-info )
@ -86,6 +89,14 @@ SYMBOL: infer-children-data
SYMBOL: condition-value SYMBOL: condition-value
: collect-variables ( -- hash )
{
condition-value
constraints
infer-children-data
value-infos
} [ dup get ] H{ } map>assoc ;
M: #phi propagate-before ( #phi -- ) M: #phi propagate-before ( #phi -- )
[ annotate-phi-inputs ] [ annotate-phi-inputs ]
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]

View File

@ -61,7 +61,7 @@ SYMBOLS: combinator quotations ;
] if-empty ; ] if-empty ;
: branch-variable ( seq symbol -- seq ) : branch-variable ( seq symbol -- seq )
'[ [ _ ] dip at ] map ; '[ _ of ] map ;
: active-variable ( seq symbol -- seq ) : active-variable ( seq symbol -- seq )
[ [ terminated? over at [ drop f ] when ] map ] dip [ [ terminated? over at [ drop f ] when ] map ] dip
@ -92,6 +92,20 @@ SYMBOLS: combinator quotations ;
input-count [ ] change input-count [ ] change
inner-d-index [ ] change ; inner-d-index [ ] change ;
: collect-variables ( -- hash )
{
(meta-d)
(meta-r)
current-word
inner-d-index
input-count
literals
quotation
recursive-state
stack-visitor
terminated?
} [ dup get ] H{ } map>assoc ;
GENERIC: infer-branch ( literal -- namespace ) GENERIC: infer-branch ( literal -- namespace )
M: literal-tuple infer-branch M: literal-tuple infer-branch
@ -99,7 +113,8 @@ M: literal-tuple infer-branch
copy-inference copy-inference
nest-visitor nest-visitor
[ value>> quotation set ] [ infer-literal-quot ] bi [ value>> quotation set ] [ infer-literal-quot ] bi
] H{ } make-assoc ; collect-variables
] with-scope ;
M: declared-effect infer-branch M: declared-effect infer-branch
known>> infer-branch ; known>> infer-branch ;
@ -109,7 +124,8 @@ M: callable infer-branch
copy-inference copy-inference
nest-visitor nest-visitor
[ quotation set ] [ infer-quot-here ] bi [ quotation set ] [ infer-quot-here ] bi
] H{ } make-assoc ; collect-variables
] with-scope ;
: infer-branches ( branches -- input children data ) : infer-branches ( branches -- input children data )
[ pop-d ] dip [ pop-d ] dip

View File

@ -103,16 +103,22 @@ M: closer process
SYMBOL: text-now? SYMBOL: text-now?
: collect-variables ( -- hash )
{
input-stream
extra-entities
spot
ns-stack
text-now?
} [ dup get ] H{ } map>assoc ;
PRIVATE> PRIVATE>
TUPLE: pull-xml scope ; TUPLE: pull-xml scope ;
: <pull-xml> ( -- pull-xml ) : <pull-xml> ( -- pull-xml )
[ [
init-parser init-parser init-xml text-now? on collect-variables
input-stream [ ] change ! bring var in this scope ] with-scope pull-xml boa ;
init-xml text-now? on
] H{ } make-assoc
pull-xml boa ;
! pull-xml needs to call start-document somewhere ! pull-xml needs to call start-document somewhere
: pull-event ( pull -- xml-event/f ) : pull-event ( pull -- xml-event/f )

View File

@ -5,7 +5,6 @@ IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators" ARTICLE: "namespaces-combinators" "Namespace combinators"
{ $subsections { $subsections
make-assoc
with-scope with-scope
with-variable with-variable
with-variables with-variables
@ -146,10 +145,6 @@ HELP: with-variable
{ $code "3 x [ foo ] with-variable" } { $code "3 x [ foo ] with-variable" }
} ; } ;
HELP: make-assoc
{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
HELP: with-variables HELP: with-variables
{ $values { "ns" assoc } { "quot" quotation } } { $values { "ns" assoc } { "quot" quotation } }
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ; { $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;

View File

@ -61,7 +61,6 @@ PRIVATE>
: dec ( variable -- ) -1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline
: with-variables ( ns quot -- ) swap >n call ndrop ; inline : with-variables ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; inline : counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; inline
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap with-variables ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline : with-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline
: with-variable ( value key quot -- ) [ associate ] dip with-variables ; inline : with-variable ( value key quot -- ) [ associate ] dip with-variables ; inline
: with-global ( quot -- ) [ global ] dip with-variables ; inline : with-global ( quot -- ) [ global ] dip with-variables ; inline