fragment-substitute-context := λ ctx fragment-rhs . (match fragment-rhs (
()
( () () )
( (Variable Dontchain) () )
( DontChain () )
( (Variable( v )) (tail(
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-expr (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
v
)))
( ('label v) (tail(
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-expr (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
v
)))
( (App( (Variable 'label) (Variable v) )) (tail(
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-expr (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
v
)))
( ('inv( x )) (tail(
(set x (fragment-substitute-context( ctx x )))
(i2s(inv( (s2i x) )))
)))
( (App( (Variable 'inv) x )) (tail(
(set x (fragment-substitute-context( ctx x )))
(i2s(inv( (s2i x) )))
)))
( ('+( l r )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(add( (s2i l) (s2i r) )))
)))
( (App( (Variable '+) (App( l r )) )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(add( (s2i l) (s2i r) )))
)))
( ('*( l r )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(mul( (s2i l) (s2i r) )))
)))
( (App( (Variable '*) (App( l r )) )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(mul( (s2i l) (s2i r) )))
)))
( ('/( l r )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(div( (s2i l) (s2i r) )))
)))
( (App( (Variable '/) (App( l r )) )) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(i2s(div( (s2i l) (s2i r) )))
)))
( (App( (Variable 'range) (App( low high )) )) (tail(
(set low (fragment-substitute-context( ctx low )))
(set high (fragment-substitute-context( ctx high )))
(local return)
(while (not(eq( low high ))) (tail(
(set return (return low))
(set low (i2s(inc(s2i( low )))) )
)))
(reverse-list return)
)))
( (App(
(App(
(App(
(App(
(Variable 'for)
(Variable v)
))
(Variable 'in)
))
iterator
))
body
)) (tail(
(local result)
(set iterator (fragment-substitute-context( ctx iterator )))
(while iterator (tail(
(local inner-e)
(set inner-e (expr::new()))
(set inner-e (expr::set-expr( inner-e (head iterator) )))
(local inner-ctx)
(set inner-ctx (ctx (
(v inner-e)
)))
(set result (result (
(fragment-substitute-context( inner-ctx body ))
)))
(set iterator (tail iterator))
)))
result
)))
( (App(
(App(
(App(
(Variable 'if-eq)
l
))
r
))
body
)) (tail(
(set l (fragment-substitute-context( ctx l )))
(set r (fragment-substitute-context( ctx r )))
(local result)
(if (eq( l r )) (
(set result (
(fragment-substitute-context( ctx body ))
))
) ())
result
)))
( ('.expression v ) (tail(
(if (is-atom v) (
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-expr (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
) (
(set v (fragment-substitute-context( ctx v )))
))
v
)))
( (App( (Variable '.expression) (Variable v) )) (tail(
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-expr (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
v
)))
( (App( (Variable '.program) (Variable v) )) (tail(
(while ctx (tail(
(if (eq( v (head (tail ctx)) )) (
(set v (expr::get-prog (tail (tail ctx))))
) ())
(set ctx (head ctx))
)))
v
)))
( (Literal v) (
(match v (
()
(\\[ \[)
(\\] \])
(\\s \s)
(\\t \t)
(\\n \n)
(u u)
))
))
( (App( l r )) (
(fragment-substitute-context( ctx l ))
(fragment-substitute-context( ctx r ))
))
( (l r) (
(fragment-substitute-context( ctx l ))
(fragment-substitute-context( ctx r ))
))
( u u )
));
fragment-gensym-labels := λctx fragment . (match fragment (
()
(() ctx)
( ('label l) (tail(
(set ctx (ctx (
(l (expr::set-expr( () (uuid()) )))
)))
ctx
)))
( (App( (Variable 'label) (Variable l) )) (tail(
(set ctx (ctx (
(l (expr::set-expr( () (uuid()) )))
)))
ctx
)))
( (l r) (tail(
(set ctx (fragment-gensym-labels( ctx l )))
(set ctx (fragment-gensym-labels( ctx r )))
ctx
)))
( x ctx )
));
fragment-apply-context := λctx fragment-rhs e . (tail(
(assert-typeof( 'fragment-apply-context::ctx ctx List<[Atom,StrictExpr]> ))
(assert-typeof( 'fragment-apply-context::e e StrictExpr ))
(local return)
(set ctx (fragment-gensym-labels( ctx fragment-rhs )))
(set return (match fragment-rhs (
()
( Nil (
e
))
( (App( (App( (Literal ':) fe )) ft )) (
(fragment-apply-context( ctx fe e ))
))
( (App( (Variable '.program) f )) (
(expr::set-prog( e (
(expr::get-prog e)
(fragment-substitute-context( ctx f ))
)))
))
( (App( inner (App( (Variable '.program) f )) )) (
(fragment-apply-context(
ctx inner
(expr::set-prog( e (
(expr::get-prog e)
(fragment-substitute-context( ctx f ))
)))
))
))
( (App( (Variable '.expression) f )) (
(expr::set-expr( e (
(fragment-substitute-context( ctx f ))
)))
))
( (App( inner (App( (Variable '.expression) f )) )) (
(fragment-apply-context(
ctx inner
(expr::set-expr( e (
(fragment-substitute-context( ctx f ))
)))
))
))
( u (fail (UnknownSubstituteFragment fragment-rhs)))
)))
(assert-typeof( 'fragment-apply-context::return return StrictExpr ))
return
));
fragment-is-dont-chain := λ f . (match f (
()
( DontChain DontChain )
( (l r) (
if (fragment-is-dont-chain l) DontChain
(fragment-is-dont-chain r)
))
( _ () )
));
fragment-apply := λ ctx function-name function-type function-args e-proto . (tail(
(assert-typeof( 'fragment-apply::e-proto e-proto StrictExpr ))
(assert-typeof( 'fragment-apply::function-name function-name Atom ))
(assert-typeof( 'fragment-apply::function-args function-args List<StrictExpr> ))
(local arrow)
(set arrow (get-strict-function( ctx function-name function-type )))
(if arrow () (tail(
(print-s NoSuchFragment)(print-s \s)
(print-s function-name)(print-s \s)
(print-s function-type)(print-s \n)
(exit 1)
)))
(local dont-chain)
(match (typecheck-slot( function-type DontChain )) (
()
( DontChain (set dont-chain DontChain))
))
(if (fragment-is-dont-chain arrow) (
(set dont-chain DontChain)
) ())
(local return)
(set return (fragment-apply-direct( arrow function-args e-proto dont-chain )))
(assert-typeof( 'fragment-apply::return return StrictExpr ))
return
));
fragment-chain := λ fragment-ctx e . (tail(
(assert-typeof( 'fragment-chain::fragment-ctx fragment-ctx List<[Atom,StrictExpr]> ))
(assert-typeof( 'fragment-chain::e e StrictExpr ))
(while fragment-ctx (tail(
(set e (expr::chain( (tail(tail fragment-ctx)) e )))
(set fragment-ctx (head fragment-ctx))
)))
e
));
fragment-apply-direct := λ fragment function-args e-proto dont-chain . (tail(
(assert-typeof( 'fragment-apply-direct::fragment fragment Fragment ))
(assert-typeof( 'fragment-apply-direct::function-args function-args List<StrictExpr> ))
(assert-typeof( 'fragment-apply-direct::e-proto e-proto StrictExpr ))
(match fragment (
()
( (Fragment( (Lambda( lhs
(App( (App( (Literal ':) rhs )) rtype ))
)) )) (tail(
(set rtype (typecheck-infer-type-compound rtype))
(local fctx)
(set fctx (fragment-destructure-lhs( () lhs function-args )))
(assert-typeof( 'fragment-apply-direct::fctx fctx List<[Atom,StrictExpr]> ))
(local e-seed)
(set e-seed (expr::new()))
(set e-seed (expr::set-offset( e-seed (expr::get-offset e-proto) )))
(set e-seed (expr::set-context( e-seed (expr::get-context e-proto) )))
(local e-return)
(set e-return (fragment-apply-context( fctx rhs e-seed )))
(if dont-chain () (
(set e-return (fragment-chain( fctx e-return )))
))
(assert-typeof( 'fragment-apply-direct::return e-return StrictExpr ))
(set e-return (expr::set-type( e-return rtype )))
e-return
)))
( (Fragment( (Lambda( lhs rhs )) )) (tail(
(local fctx)
(set fctx (fragment-destructure-lhs( () lhs function-args )))
(assert-typeof( 'fragment-apply-direct::fctx fctx List<[Atom,StrictExpr]> ))
(local e-seed)
(set e-seed (expr::new()))
(set e-seed (expr::set-offset( e-seed (expr::get-offset e-proto) )))
(set e-seed (expr::set-context( e-seed (expr::get-context e-proto) )))
(local e-return)
(set e-return (fragment-apply-context( fctx rhs e-seed )))
(if dont-chain () (
(set e-return (fragment-chain( fctx e-return )))
))
(assert-typeof( 'fragment-apply-direct::return e-return StrictExpr ))
e-return
)))
( u (fail (InvalidFragment fragment)))
))
));
fragment-bind-types := λctx tctx . (match tctx (
()
( (Bind( k v )) (tail(
(local e)
(set e (expr::new()))
(set e (expr::set-expr( e v )))
(ctx (k e))
)))
( () ctx )
( Accept ctx )
( (l r) (tail(
(set ctx (fragment-bind-types( ctx l )))
(set ctx (fragment-bind-types( ctx r )))
ctx
)))
));
fragment-destructure-lhs := λ ctx lhs args . (tail(
(assert-typeof( 'fragment-destructure-lhs::ctx ctx List<[Atom,StrictExpr]> ))
(assert-typeof( 'fragment-destructure-lhs::args args List<StrictExpr> ))
(assert-not-typeof( 'fragment-destructure-lhs::args args Nil ))
(local return)
(set return (match lhs (
()
( Nil (tail(
(set ctx ())
ctx
)))
( (App( (App( (Literal ':) (Variable vname) )) vtype )) (tail(
(local ctype)
(set ctype (typecheck-infer-type-compound vtype))
(local tctx)
(set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
(set ctx (fragment-bind-types( ctx tctx )))
(set ctx ( ctx (vname (tail args)) ))
ctx
)))
( (App( inner (App( (App( (Literal ':) (Variable vname) )) vtype )) )) (tail(
(local ctype)
(set ctype (typecheck-infer-type-compound vtype))
(local tctx)
(set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
(set ctx (fragment-bind-types( ctx tctx )))
(set ctx ( ctx (vname (tail args)) ))
(set ctx (fragment-destructure-lhs( ctx inner (head args) )))
ctx
)))
( u (fail (PatternDefaultCase 'fragment-destructure-lhs u)))
)))
(assert-typeof( 'fragment-destructure-lhs::return return List<[Atom,StrictExpr]> ))
return
));
fragment-get-local := λctx v offset . (tail(
(assert-typeof( 'fragment-get-local::ctx ctx Context ))
(assert-typeof( 'fragment-get-local::v v Atom ))
(assert-typeof( 'fragment-get-local::offset offset Atom ))
(local r)
(match (context::lookup( ctx v () )) (
()
( (Label( uid )) (tail(
(set r (expr::new()) )
(set r (expr::set-expr( r uid )))
(set r (expr::set-context( r ctx )))
(set r (expr::set-offset( r offset )))
)))
( (LocalVariable( loffset )) (tail(
(set r (expr::new()) )
(set r (expr::set-expr( r loffset )))
(set r (expr::set-context( r ctx )))
(set r (expr::set-offset( r offset )))
)))
( (GlobalVariable( uid )) (tail(
(set r (expr::new()) )
(set r (expr::set-expr( r uid )))
(set r (expr::set-context( r ctx )))
(set r (expr::set-offset( r offset )))
)))
( u (fail (InvalidFragmentLocal v u)))
))
(assert-typeof( 'fragment-get-local::return r StrictExpr ))
r
));