assemble-text-section                    := (: SNil S);
assemble-init-section                    := (: SNil S);
assemble-data-section                    := (: SNil S);
assemble-final                           := '_s;
assemble-argv-referenced                 := False_u8;

compile := λ. (: (match config-assemble-mode (
   ()
   ( AssembleGNU (compile-gnu()) )
   ( AssembleBlob (compile-blob()) )
)) Nil);

compile-blob := λ. (: (
   (let global-ctx (fragment-context::new()))
   (let preview-program ast-parsed-program)
   (while (non-zero preview-program) (match preview-program (
      ()
      # blob globals could provide mutable compile-time state or something?
      ( (Seq( rst (Frg( k_t rhs )) )) (
         (let fragment (fragment::new()))
         (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
         (set fragment (fragment::set( fragment 'fragment_s (to-s rhs) )))
         (set fragment (fragment::set-term( fragment rhs )))
         (set fragment (fragment::set-type( fragment (typeof rhs) )))
         (set global-ctx (fragment-context::bind(
            global-ctx k (typeof rhs) fragment
         )))
         (set preview-program rst)
      ))
      ( (Seq( rst (Frg( k_t (Abs( _ _ _ )) )) )) (
         (set preview-program rst)
      ))
      ( (Seq( rst (Typedef( lhs rhs )) )) (
         (set global-ctx (compile-type( global-ctx lhs rhs )))
         (set preview-program rst)
      ))
      ( (Seq( rst (Glb( k_t rhs )) )) (
         (match rhs (
            ()
            ( (Abs( _ _ _ )) (
               (let fragment (fragment::new()))
               (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Function_s) )))
               (set fragment (fragment::set-term( fragment rhs )))
               (set fragment (fragment::set-type( fragment (typeof rhs) )))
               (set global-ctx (fragment-context::bind(
                  global-ctx k (typeof rhs) fragment
               )))
            ))
            ( _ () )
         ))
         (set preview-program rst)
      ))
      ( (Seq( rst rhs )) (
         (set preview-program rst)
      ))
   )))
   (let blob SNil)
   (set preview-program ast-parsed-program)
   (while (non-zero preview-program) (match preview-program (
      ()
      ( (Seq( rst (Glb( k_t rhs )) )) (
         (set preview-program rst)
      ))
      ( (Seq( rst (Frg( k_t rhs )) )) (
         (set preview-program rst)
      ))
      ( (Seq( rst (Typedef( lhs rhs )) )) (
         (set preview-program rst)
      ))
      ( (Seq( rst expr )) (
         (let f (blob-expr( global-ctx expr )))
         (set blob (SCons(
             (close blob)
             (close(fragment::get( f 'program_s )))
         )))
         (set preview-program rst)
      ))
   )))
   (set assemble-final (clone-rope(escape-string blob)))
   (compile-write())
) Nil);

compile-gnu := λ. (: (
   (let global-ctx (fragment-context::new()))
   (let preview-program ast-parsed-program)
   (while (non-zero preview-program) (match preview-program (
      ()
      ( (Seq( rst (Frg( k_t rhs )) )) (
         (let is-template False_u8)
         (match k (
            ()
            ( 'template::push_s (set is-template True_u8) )
            ( 'template::mov_s (set is-template True_u8) )
            ( _ () )
         ))
         (if (==( is-template True_u8 )) (
            (let fragment (fragment::new()))
            (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
            (set fragment (fragment::set( fragment 'fragment_s (to-s rhs) )))
            (set fragment (fragment::set-type( fragment (typeof rhs) )))
            (set global-ctx (fragment-context::bind(
               global-ctx k (typeof rhs) fragment
            )))
            (match preview-program (
               ()
               ( (Seq( _ frg )) (ascript( (fragment::get( fragment 'fragment_s )) (typeof frg) )) )
            ))
         ) ())
         (set preview-program rst)
      ))
      ( (Seq( rst _ )) (
         (set preview-program rst)
      ))
   )))
   (set preview-program ast-parsed-program)
   (while (non-zero preview-program) (match preview-program (
      ()
      ( (Seq( rst (Glb( k_t rhs )) )) (
         (if (==( k 'main_s )) (set assemble-argv-referenced True_u8) ())
         (let kt (typeof rhs))
         (if (is-open kt) () (
            (let fragment (fragment::new()))
            (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Global_s) )))
            (match (slot( kt '->_s )) (
               ()
               ( (TGround( '->_s _ )) (
                  (set fragment (fragment::set-type( fragment kt )))
                  (set global-ctx (fragment-context::bind(
                     global-ctx k kt fragment
                  )))
               ))
               ( _ (
                  (let clean-tt (without-representation kt))
                  (let repr-tt (and( clean-tt (t1 'GlobalVariable_s) )))
                  (set fragment (fragment::set-type( fragment repr-tt )))
                  (let mid (mangle-identifier( k clean-tt )))
                  (set fragment (fragment::set( fragment 'expression_s (SAtom mid) )))
                  (set global-ctx (fragment-context::bind(
                     global-ctx k repr-tt fragment
                  )))
               ))
            ))
         ))
         (set preview-program rst)
      ))
      ( (Seq( rst (Frg( k_t rhs )) )) (
         (let fragment (fragment::new()))
         (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
         (set fragment (fragment::set( fragment 'fragment_s (to-s rhs) )))
         (set fragment (fragment::set-type( fragment (typeof rhs) )))
         (set global-ctx (fragment-context::bind(
            global-ctx k (typeof rhs) fragment
         )))
         (set preview-program rst)
      ))
      ( (Seq( rst (Typedef( lhs rhs )) )) (
         (set global-ctx (compile-type( global-ctx lhs rhs )))
         (set preview-program rst)
      ))
      ( (Seq( rst _ )) (
         (set preview-program rst)
      ))
   )))
   (compile-program-ordered( global-ctx ast-parsed-program ))
   (compile-finish())
   (compile-write())
) Nil);

compile-program-ordered := λ(: global-ctx FContext)(: program AST). (: (
   (let open? False_u8)
   (match program (
      ()
      ( (Seq( _ e )) (
         (if (is-open(typeof e)) (set open? True_u8) ())
      ))
      ( _ () )
   ))
   (match program (
      ()
      ( (Seq( rst (Glb( k_t rhs )) )) (
         (compile-program-ordered( global-ctx rst ))
         (if (==( open? True_u8 )) () (
            (compile-global( global-ctx k rhs ))
         ))
      ))
      ( (Seq( rst _ )) (compile-program-ordered( global-ctx rst )) )
      ( ASTEOF () )
   ))
) Nil);

compile-type := λ(: ctx FContext)(: lhs AST)(: rhs AST). (: (
   (let def rhs)
   (let base-type (type-of-s( lhs )))
   (let case-number 0_u64)
   (if (is-fragment base-type) () (
      (while (non-zero def) (match def (
         ()
         ( (App( (App( tds (Var( '|_s _ )) )) body )) (
            (set ctx (compile-type-case( ctx base-type body case-number )))
            (set case-number (+( case-number 1_u64 )))
            (set def tds)
         ))
         ( body (
            (set ctx (compile-type-case( ctx base-type body case-number )))
            (set case-number (+( case-number 1_u64 )))
            (set def ASTEOF)
         ))
      )))
   ))
   ctx
) FContext);

compile-type-case := λ(: ctx FContext)(: base-type Type)(: rhs AST)(: case-number U64). (: (
   (match rhs (
      ()
      ( (Lit( tag _ )) (
         (let rtype (TAnd( (close base-type) (close(parse-type tag)) )) )
         (set ctx (compile-define-tag-constructor( ctx tag TAny base-type rtype case-number )))
      ))
      ( (App( (Lit( tag _ )) args )) (
         (let atype (type-of-s args))
         (let rtype (TAnd( (close base-type) (close(parse-type tag)) )))
         (set ctx (compile-define-tag-constructor( ctx tag atype base-type rtype case-number )))
      ))
      ( _ () )
   ))
   ctx
) FContext);

compile-define-tag-constructor := λ(: ctx FContext)(: tag String)(: arg-types Type)(: base-type Type)(: rtype Type)(: case-number U64). (: (
   (let tg (and( (t2( 'Constructor_s (t1 tag) )) (and( (t2( 'Sized_s (t1 '0_s) )) (t2( 'FieldsSized_s (t1 '0_s) )) )) )))
   (let push-template (fragment-context::lookup( ctx 'template::push_s tg ASTEOF )))
   (let movl-template (fragment-context::lookup( ctx 'template::mov_s (t3( 'Cons_s tg (t1 'LocalVariable_s) )) ASTEOF )))
   (let movg-template (fragment-context::lookup( ctx 'template::mov_s (t3( 'Cons_s tg (t1 'GlobalVariable_s) )) ASTEOF )))

   (let tag-tctx (TCtxBind( (close TCtxEOF) 'tag_s (t1 tag) ASTEOF )))
   (let case-tctx (SSLSeq( (close SSLEOF) 'case-number_s (SAtom(to-string case-number)) )))

   (let fragment push-template)
   (let arrow-tt (substitute( tag-tctx (fragment::get-type fragment) )))
   (set fragment (fragment::set-type( fragment arrow-tt )))
   (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
   (let spt (substitute( case-tctx (fragment::get( fragment 'fragment_s )) )))
   (ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
   (set fragment (fragment::set( fragment 'fragment_s spt )))
   (set ctx (fragment-context::bind(
      ctx 'push_s arrow-tt fragment
   )))

   (set fragment movl-template)
   (set arrow-tt (substitute( tag-tctx (fragment::get-type fragment) )))
   (set fragment (fragment::set-type( fragment arrow-tt )))
   (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
   (set spt (substitute( case-tctx (fragment::get( fragment 'fragment_s )) )))
   (ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
   (set fragment (fragment::set( fragment 'fragment_s spt )))
   (set ctx (fragment-context::bind(
      ctx 'mov_s arrow-tt fragment
   )))

   (set fragment movg-template)
   (set arrow-tt (substitute( tag-tctx (fragment::get-type fragment) )))
   (set fragment (fragment::set-type( fragment arrow-tt )))
   (set fragment (fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) )))
   (set spt (substitute( case-tctx (fragment::get( fragment 'fragment_s )) )))
   (ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
   (set fragment (fragment::set( fragment 'fragment_s spt )))
   (set ctx (fragment-context::bind(
      ctx 'mov_s arrow-tt fragment
   )))

   ctx
) FContext);

compile-finish := λ. (: (
   (let output SNil)
   (set output (SCons( (close output) (close(compile-text-header())) )))
   (set output (SCons( (close output) (close(compile-exit-cleanup())) )))
   (set output (SCons( (close output) (close assemble-text-section) )))
   (if (non-zero assemble-data-section) (
      (set output (SCons( (close output) (close(compile-data-header())) )))
      (set output (SCons( (close output) (close assemble-data-section) )))
   ) ())
   (set assemble-final (clone-rope(escape-string output)))
) Nil);

compile-write := λ. (: (
   (write-file( config-target assemble-final ))
) Nil);