fragment::new := λ . (: ( (let r (Fragment( ASTEOF (close FKVEOF) 0_i64 TAny (close(fragment-context::new())) ))) r ) Fragment); fragment::get := λ(: e Fragment)(: k String). (: ( (let r SNil) (match e ( () ( (Fragment( e-t kvs offset ft ctx )) ( (while (non-zero kvs) (match kvs ( () ( (FKVSeq( rst kvs-k kvs-v )) ( (if (==( k kvs-k )) ( (set r kvs-v) (set kvs FKVEOF) ) (set kvs rst)) )) ))) )) )) r ) S); fragment::set := λ(: e Fragment)(: k String)(: v S). (: ( (match e ( () ( (Fragment( e-t kvs offset ft ctx )) ( (set e (Fragment( e-t (close(FKVSeq( (close kvs) k v ))) offset ft (close ctx) ))) )) )) e ) Fragment); fragment::get-type := λ(: e Fragment) . (: ( (let tt (.2( (as e Tag) ))) tt ) Type); fragment::set-type := λ(: e Fragment)(: tt Type). (: ( (match e ( () ( (Fragment( e-t e-kvs e-offset e-tt e-ctx )) ( (set e (Fragment( e-t (close e-kvs) e-offset tt (close e-ctx) ))) )) )) e ) Fragment); fragment::get-term := λ(: e Fragment) . (: ( (let t (.5( (as e Tag) ))) t ) AST); fragment::set-term := λ(: e Fragment)(: t AST). (: ( (match e ( () ( (Fragment( e-t e-kvs e-offset e-tt e-ctx )) ( (set e (Fragment( t (close e-kvs) e-offset e-tt (close e-ctx) ))) )) )) e ) Fragment); fragment::local-variable := λ(: offset I64)(: tt Type). (: ( (let r (fragment::new())) (set r (fragment::set( r 'expression_s (SAtom(to-string offset)) ))) (set r (fragment::set( r 'fragment-type_s (SAtom 'LocalVariable_s) ))) (set r (fragment::set-type( r tt ))) r ) Fragment); fragment::label := λ(: id String). (: ( (let r (fragment::new())) (set r (fragment::set( r 'expression_s (SAtom id) ))) (set r (fragment::set( r 'fragment-type_s (SAtom 'Label_s) ))) (set r (fragment::set-type( r (t1 'Label_s) ))) r ) Fragment); fragment::expression := λ(: val String). (: ( (let r (fragment::new())) (set r (fragment::set( r 'expression_s (SAtom val) ))) r ) Fragment); fragment::expression := λ(: val S). (: ( (let r (fragment::new())) (set r (fragment::set( r 'expression_s val ))) r ) Fragment); fragment::get-context := λ(: e Fragment) . (: ( (let ctx (open(.1( (as e Tag) )))) ctx ) FContext); fragment::set-context := λ(: e Fragment)(: ctx FContext). (: ( (let r e) (match e ( () ( (Fragment( e-t e-kvs e-offset e-tt e-ctx )) ( (set r (Fragment( e-t (close e-kvs) e-offset e-tt (close ctx) ))) )) )) r ) Fragment); fragment::get-offset := λ(: e Fragment). (: ( (let offset 0_i64) (match e ( () ( (Fragment( e-t e-kvs e-offset e-tt e-ctx )) ( (set offset e-offset) )) )) offset ) I64); fragment::set-offset := λ(: e Fragment)(: offset I64). (: ( (let r e) (match e ( () ( (Fragment( e-t e-kvs e-offset e-tt e-ctx )) ( (set r (Fragment( e-t (close e-kvs) offset e-tt (close e-ctx) ))) )) )) r ) Fragment); fragment::unlet := λ(: s S). (: ( (let return s) (match s ( () ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Abs_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom _) )) SNil )) )) v )) )) (set return SNil) ) ( (SCons( (SAtom 'App_s) (SCons( ls rs )) )) ( (let ls-2 (fragment::unlet( ls ))) (if (not(is( ls ls-2 ))) ( (set return (SCons( (close(SAtom 'App_s)) (close(SCons( (close ls-2) (close rs) ))) )) ) ) ()) )) ( _ () ) )) return ) S); fragment::let := λ(: ctx FContext)(: s S). (: ( (let return ctx) (match s ( () ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Abs_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom k) )) SNil )) )) v )) )) ( (set v (fragment::render( return v ))) (set return (FCtxBind( (close return) k TAny (fragment::expression( v )) ))) )) ( (SCons( (SAtom 'App_s) (SCons( ls rs )) )) ( (set return (fragment::let( return ls ))) )) ( _ () ) )) return ) FContext); fragment::render := λ(: ctx FContext)(: s S). (: ( (let s-2 (fragment::unlet( s ))) (while (not(is( s s-2 ))) ( (set ctx (fragment::let( ctx s ))) (set s s-2) (set s-2 (fragment::unlet( s ))) ) ()) (let return (fragment::render-impl( ctx s ))) return ) S); fragment::render-ctx := (: FCtxEOF FContext); fragment::render-impl := λ(: ctx FContext)(: s S). (: ( (set fragment::render-ctx ctx) (let r (fragment::render-impl( s ))) r ) S); fragment::render-impl := λ(: s S). (: ( (let ctx fragment::render-ctx) (let r SNil) (match s ( () ( SNil () ) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'uuid_s) )) (SCons( (SAtom 'Var_s) (SAtom v) )) )) )) ( (let f (fragment-context::lookup-soft( ctx v TAny ASTEOF ))) (set r (fragment::get( f 'expression_s ))) (if (non-zero r) () ( (set f (fragment::expression(uuid()))) (set fragment::render-ctx (FCtxBind( (close fragment::render-ctx) v TAny f ))) (set r (fragment::get( f 'expression_s ))) )) )) ( (SCons( (SAtom 'Var_s) (SAtom v) )) ( (print 'Raw\sVariables\sNot\sPermitted\sIn\sFragments:\s_s) (print v)(print '\n_s) (exit 1_u64) )) ( (SCons( (SAtom 'Lit_s) (SAtom v) )) (set r (SAtom v)) ) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'inv_s) )) lc )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (set r (SAtom(to-string (-( 0_i64 li )) ))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'align_s) )) lc )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (max( (to-i64 lai) 8_i64 ))) ) ( _ () ) )) (set r (SAtom(to-string li))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '>_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (if (>( li ri )) ( (set r (SAtom '1_s)) ) ( (set r (SAtom '0_s)) )) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'max_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (set r (SAtom(to-string(max( li ri ))))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '+_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (set r (SAtom(to-string(+( li ri ))))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '-_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (set r (SAtom(to-string(-( li ri ))))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '*_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (set r (SAtom(to-string(*( li ri ))))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '/_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (if (>( ri 0_i64 )) ( (set r (SAtom(to-string(/( li ri ))))) ) ()) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom '%_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (if (>( ri 0_i64 )) ( (set r (SAtom(to-string(%( li ri ))))) ) ()) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'range_s) )) (SCons( (SAtom 'App_s) (SCons( lc rc )) )) )) )) ( (let lt (fragment::render-impl( lc ))) (let li 0_i64) (match lt ( () ( (SAtom lai) (set li (to-i64 lai)) ) ( _ () ) )) (let rt (fragment::render-impl( rc ))) (let ri 0_i64) (match rt ( () ( (SAtom rai) (set ri (to-i64 rai)) ) ( _ () ) )) (while (<( li ri )) ( (set ri (-( ri 1_i64 ))) (set r (SCons( (close(SAtom(to-string ri))) (close r) ))) )) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'if-eq_s) )) lc )) )) rc )) )) body )) )) ( (let lt (fragment::render-impl( lc ))) (let rt (fragment::render-impl( rc ))) (if (==( lt rt )) ( (let bodyt (fragment::render( ctx body ))) (set r bodyt) ) ()) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'if-neq_s) )) lc )) )) rc )) )) body )) )) ( (let lt (fragment::render-impl( lc ))) (let rt (fragment::render-impl( rc ))) (if (!=( lt rt )) ( (let bodyt (fragment::render( ctx body ))) (set r bodyt) ) ()) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'for_s) )) (SCons( (SAtom 'Var_s) (SAtom binding) )) )) )) (SCons( (SAtom 'Var_s) (SAtom 'in_s) )) )) )) iter )) )) body )) )) ( (let iter-result (fragment::render-impl( iter ))) (while (non-zero iter-result) (match iter-result ( () ( (SCons( (SAtom i) rst )) ( (let fi (fragment::expression i)) (let fi-2 (fragment::set( fi 'program_s (SAtom i) )))(set fi fi-2) (let inner-ctx (FCtxBind( (close ctx) binding TAny fi ))) (let body-instance (fragment::render( inner-ctx body ))) (set r (SCons( (close r) (close body-instance) ))) (set iter-result rst) )) ))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom 'for-arg_s) )) (SCons( (SAtom 'Var_s) (SAtom binding) )) )) )) (SCons( (SAtom 'Var_s) (SAtom 'in_s) )) )) )) (SCons( (SAtom 'Var_s) (SAtom iter) )) )) )) body )) )) ( (let iter-result (reverse(fragment-context::lookup-vararg( ctx iter TAny ASTEOF )))) (while (non-zero iter-result) (match iter-result ( () ( (FLSeq( rst fi )) ( (let inner-ctx (FCtxBind( (close ctx) binding TAny fi ))) (let body-instance (fragment::render( inner-ctx body ))) (set r (SCons( (close r) (close body-instance) ))) (set iter-result rst) )) ))) )) ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom op) )) (SCons( (SAtom 'Var_s) (SAtom v) )) )) )) ( (if (==( (head-string op) 46_u8 )) ( (let f (fragment-context::lookup( ctx v TAny ASTEOF ))) (let fe (fragment::get( f (tail-string op) ))) (set r fe) ) ( (print 'Raw\sVariables\sNot\sPermitted\sIn\sFragments:\s_s) (print op)(print '\n_s) (exit 1_u64) )) )) ( (SCons( (SAtom 'App_s) (SCons( ls rs )) )) ( (let lf (fragment::render-impl( ls ))) (let rf (fragment::render-impl( rs ))) (set r (SCons( (close lf) (close rf) ))) )) ( u ( (print 'Fragment\sRender\sUnknown\s_s)(print u)(print '\n_s)(exit 1_u64) )) )) r ) S); union := λ(: ctx FContext)(: tctx TContext). (: ( (let r ctx) (while (non-zero tctx) (match tctx ( () ( TCtxNil (set tctx TCtxEOF) ) ( (TCtxBind( rst k vt _ )) ( (let fragment (fragment::expression(to-string vt))) (set fragment (fragment::set( fragment 'program_s (SAtom(to-string vt)) ))) (set r (FCtxBind( (close r) k TAny fragment ))) (set tctx rst) )) ))) r ) FContext); fragment::render := λ(: ctx FContext)(: rhs S)(: prototype Fragment). (: ( (let return prototype) (match rhs ( () ( (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom mode) )) prg )) )) ( (if (!=( (head-string mode) 46_u8 )) (fail 'Invalid\sMode\sIn\sfragment::render_s) ()) (let s (fragment::render( ctx prg ))) (set return (fragment::set( return (tail-string mode) s ))) )) ( (SCons( (SAtom 'App_s) (SCons( rst (SCons( (SAtom 'App_s) (SCons( (SCons( (SAtom 'Var_s) (SAtom mode) )) prg )) )) )) )) ( (if (!=( (head-string mode) 46_u8 )) (fail 'Invalid\sMode\sIn\sfragment::render_s) ()) (let s (fragment::render( ctx prg ))) (set return (fragment::set( return (tail-string mode) s ))) (set return (fragment::render( ctx rst return ))) )) ( SNil () ) ( prg ( (print 'Invalid\sRHS\sIn\sfragment::render\s_s) (print prg) (exit 1_u64) )) )) return ) Fragment); fragment::chain := λ(: l Fragment)(: r Fragment). (: ( (set l (fragment::set-context( l (fragment::get-context r) ))) (set l (fragment::set-offset( l (fragment::get-offset r) ))) (set l (fragment::set-type( l (fragment::get-type r) ))) (set l (fragment::set( l 'expression_s (fragment::get( r 'expression_s )) ))) (set l (fragment::set( l 'frame_s (SCons( (close(fragment::get( l 'frame_s ))) (close(fragment::get( r 'frame_s ))) )) ))) (set l (fragment::set( l 'del_s (SCons( (close(fragment::get( l 'del_s ))) (close(fragment::get( r 'del_s ))) )) ))) (set l (fragment::set( l 'unframe_s (SCons( (close(fragment::get( l 'unframe_s ))) (close(fragment::get( r 'unframe_s ))) )) ))) (set l (fragment::set( l 'program_s (SCons( (close(fragment::get( l 'program_s ))) (close(fragment::get( r 'program_s ))) )) ))) l ) Fragment); fragment::chain := λ(: fragment-ctx FragmentList)(: e Fragment). (: ( (while (non-zero fragment-ctx) (match fragment-ctx ( () ( (FLSeq( rst cf )) ( (set e (fragment::chain( cf e ))) (set fragment-ctx rst) )) ))) e ) Fragment); apply-direct := λ(: ctx FContext)(: arrow Fragment)(: args FragmentList)(: e-proto Fragment)(: chain U8)(: already-destructured U8). (: ( (match (fragment::get( arrow 'fragment_s )) ( () ( (SCons( (SAtom 'Abs_s) (SCons( lhs rhs )) )) ( (if (==( already-destructured True_u8 )) () ( (set ctx (destructure-lhs( ctx lhs args ))) )) (set e-proto (fragment::render( ctx rhs e-proto ))) )) ( _ ( (print 'Invalid\sFragment\sApplied:\n_s) (print arrow)(print '\n_s) )) )) (if (==( chain True_u8 )) ( (set e-proto (fragment::chain( args e-proto ))) ) ()) e-proto ) Fragment); destructure-lhs := λ(: ctx FContext)(: lhs S)(: args FragmentList). (: ( (match lhs ( () ( (SCons( (SAtom 'Var_s) (SAtom k) )) ( (let a-type (typeof lhs)) (match args ( () ( (FLSeq( _ f )) ( (let ft (with-size(fragment::get-type f))) (if (non-zero ft) () ( (print 'Fragment\sHas\sNo\sType:\n_s) (print f) (exit 1_u64) )) (set ctx (union( ctx (unify( a-type ft )) ))) # destructure tctx (set ctx (FCtxBind( (close ctx) k ft f ))) )) )) )) ( (SCons( (SAtom 'App_s) (SCons( lhs-rst (SCons( (SAtom 'Var_s) (SAtom k) )) )) )) ( (let a-type TAny) (match lhs ( () ( (SCons( (SAtom 'App_s) (SCons( _ binding )) )) ( (set a-type (typeof binding)) )) )) (match args ( () ( (FLSeq( fl-rst f )) ( (let ft (with-size(fragment::get-type f))) (if (non-zero ft) () ( (print 'Fragment\sHas\sNo\sType:\n_s) (print f) (exit 1_u64) )) (set ctx (union( ctx (unify( a-type ft )) ))) (set ctx (FCtxBind( (close ctx) k ft f ))) (set args fl-rst) )) )) (set ctx (destructure-lhs( ctx lhs-rst args ))) )) ( SNil () ) ( _ ( (print 'Unexpected\sDestructure\sLHS:\s_s) (print lhs)(print '\n_s) (exit 1_u64) )) )) ctx ) FContext); typeof := λ(: args FragmentList). (: ( (let r TAny) (match args ( () ( (FLSeq( rst f )) ( (set r (typeof rst)) (if (non-zero r) ( (set r (t3( 'Cons_s r (with-size(fragment::get-type f)) ))) ) ( (set r (with-size(fragment::get-type f))) )) )) ( _ () ) )) r ) Type); fragment-apply := λ(: ctx FContext)(: offset I64)(: k String)(: args FragmentList)(: direct-type Type)(: sloc AST). (: ( (fragment-apply( ctx offset k args direct-type sloc False_u8 )) ) Fragment); fragment-apply := λ(: ctx FContext)(: offset I64)(: k String)(: args FragmentList)(: direct-type Type)(: sloc AST)(: already-destructured U8). (: ( (let e-proto (fragment::new())) (set e-proto (fragment::set-context( e-proto ctx ))) (set e-proto (fragment::set-offset( e-proto offset ))) (let args-tt (typeof args)) (if (non-zero args-tt) () ( (print 'Apply\s_s)(print k)(print args-tt) (let msg (clone-rope(SCons( (close(SAtom 'Untyped\sFragment\sArguments:\s_s)) (close(SAtom k)) )))) (exit-error( msg sloc )) )) (let arrow (fragment-context::lookup( ctx k args-tt sloc ))) (let arrow-tt (fragment::get-type arrow)) (let chain True_u8) (if (non-zero(slot( arrow-tt 'DontChain_s ))) ( (set chain False_u8) ) ()) (let tctx (unify( (slot( arrow-tt 'Arrow_s )) direct-type ))) (set ctx (union( ctx tctx ))) (match (fragment::get( arrow 'fragment_s )) ( () ( (SCons( (SAtom 'Abs_s) (SCons( lhs rhs )) )) () ) ( _ ( (print 'Fragment\sWas\sNot\sAn\sArrow:\s_s) (print k)(print '\s:\s_s)(print arrow-tt)(print '\n_s) (print (fragment::get( arrow 'fragment_s ))) (exit 1_u64) )) )) (let return (apply-direct( ctx arrow args e-proto chain already-destructured ))) # add comments if in GNU mode (if (is( config-assemble-mode AssembleGNU )) ( (let comment (SAtom '\oCall\sFragment\s_s)) (set comment (SCons( (close comment) (close(SAtom k)) ))) (set comment (SCons( (close comment) (close(SAtom '\s:\s_s)) ))) (set comment (SCons( (close comment) (close(SAtom(to-string arrow-tt))) ))) (set comment (SCons( (close comment) (close(SAtom '\n_s)) ))) (set return (fragment::set( return 'program_s (SCons( (close comment) (close(fragment::get( return 'program_s ))) ))))) ) ()) (set return (fragment::set-type( return (range arrow-tt) ))) return ) Fragment);