value-infos off
constraints off ;
+DEFER: collect-variables
+
: infer-children ( node -- )
[ live-children ] [ child-constraints ] bi [
[
[ copy-value-info assume (propagate) ]
[ 2drop no-value-info ]
if
- ] H{ } make-assoc
+ collect-variables
+ ] with-scope
] 2map infer-children-data set ;
: compute-phi-input-infos ( phi-in -- phi-info )
SYMBOL: condition-value
+: collect-variables ( -- hash )
+ {
+ condition-value
+ constraints
+ infer-children-data
+ value-infos
+ } [ dup get ] H{ } map>assoc ;
+
M: #phi propagate-before ( #phi -- )
[ annotate-phi-inputs ]
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
] if-empty ;
: branch-variable ( seq symbol -- seq )
- '[ [ _ ] dip at ] map ;
+ '[ _ of ] map ;
: active-variable ( seq symbol -- seq )
[ [ terminated? over at [ drop f ] when ] map ] dip
input-count [ ] 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 )
M: literal-tuple infer-branch
copy-inference
nest-visitor
[ value>> quotation set ] [ infer-literal-quot ] bi
- ] H{ } make-assoc ;
+ collect-variables
+ ] with-scope ;
M: declared-effect infer-branch
known>> infer-branch ;
copy-inference
nest-visitor
[ quotation set ] [ infer-quot-here ] bi
- ] H{ } make-assoc ;
+ collect-variables
+ ] with-scope ;
: infer-branches ( branches -- input children data )
[ pop-d ] dip
SYMBOL: text-now?
+: collect-variables ( -- hash )
+ {
+ input-stream
+ extra-entities
+ spot
+ ns-stack
+ text-now?
+ } [ dup get ] H{ } map>assoc ;
+
PRIVATE>
TUPLE: pull-xml scope ;
: <pull-xml> ( -- pull-xml )
[
- init-parser
- input-stream [ ] change ! bring var in this scope
- init-xml text-now? on
- ] H{ } make-assoc
- pull-xml boa ;
+ init-parser init-xml text-now? on collect-variables
+ ] with-scope pull-xml boa ;
! pull-xml needs to call start-document somewhere
: pull-event ( pull -- xml-event/f )
ARTICLE: "namespaces-combinators" "Namespace combinators"
{ $subsections
- make-assoc
with-scope
with-variable
with-variables
{ $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
{ $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" } "." } ;
: dec ( variable -- ) -1 swap +@ ; inline
: with-variables ( ns quot -- ) swap >n call ndrop ; 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-variable ( value key quot -- ) [ associate ] dip with-variables ; inline
: with-global ( quot -- ) [ global ] dip with-variables ; inline