namespaces: removing make-assoc in favor of explicit get's.
							parent
							
								
									c9585b936b
								
							
						
					
					
						commit
						9d3a654443
					
				| 
						 | 
				
			
			@ -57,6 +57,8 @@ SYMBOL: infer-children-data
 | 
			
		|||
    value-infos off
 | 
			
		||||
    constraints off ;
 | 
			
		||||
 | 
			
		||||
DEFER: collect-variables
 | 
			
		||||
 | 
			
		||||
: infer-children ( node -- )
 | 
			
		||||
    [ live-children ] [ child-constraints ] bi [
 | 
			
		||||
        [
 | 
			
		||||
| 
						 | 
				
			
			@ -64,7 +66,8 @@ SYMBOL: infer-children-data
 | 
			
		|||
            [ 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 )
 | 
			
		||||
| 
						 | 
				
			
			@ -86,6 +89,14 @@ SYMBOL: infer-children-data
 | 
			
		|||
 | 
			
		||||
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 ]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -61,7 +61,7 @@ SYMBOLS: combinator quotations ;
 | 
			
		|||
    ] 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
 | 
			
		||||
| 
						 | 
				
			
			@ -92,6 +92,20 @@ SYMBOLS: combinator quotations ;
 | 
			
		|||
    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
 | 
			
		||||
| 
						 | 
				
			
			@ -99,7 +113,8 @@ 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 ;
 | 
			
		||||
| 
						 | 
				
			
			@ -109,7 +124,8 @@ M: callable 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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -103,16 +103,22 @@ M: closer process
 | 
			
		|||
 | 
			
		||||
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 )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -5,7 +5,6 @@ IN: namespaces
 | 
			
		|||
 | 
			
		||||
ARTICLE: "namespaces-combinators" "Namespace combinators"
 | 
			
		||||
{ $subsections
 | 
			
		||||
    make-assoc
 | 
			
		||||
    with-scope
 | 
			
		||||
    with-variable
 | 
			
		||||
    with-variables
 | 
			
		||||
| 
						 | 
				
			
			@ -146,10 +145,6 @@ HELP: 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
 | 
			
		||||
{ $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" } "." } ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -61,7 +61,6 @@ PRIVATE>
 | 
			
		|||
: 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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue