type Macro (Macro( AST , AST ));
type MacroList MEOF | (MSeq( MacroList[] , Macro ));
type IndexList IEOF | (ISeq( IndexList[] , String , U64 ));
preprocess-macros := (: MEOF MacroList);
preprocess-tag-indices := (: IEOF IndexList);
preprocess-tag-index-eof := 99999_u64;
preprocess-index-of-tag := λ(: tag String). (: (tail(
(let index preprocess-tag-index-eof)
(let indices preprocess-tag-indices)
(while (non-zero indices) (match indices (
()
( (ISeq( rst (*( tag-name tag-index )) )) (tail(
(if (==( tag tag-name )) (
(set index tag-index)
) ())
(set indices rst)
)))
)))
index
)) U64);
close := λ(: x MacroList). (: (tail(
(mov( (malloc(sizeof MacroList)) R8 ))
(mov( x 0_u64 (as R8 MacroList[]) ))
(as R8 MacroList[])
)) MacroList[]);
close := λ(: x IndexList). (: (tail(
(mov( (malloc(sizeof IndexList)) R8 ))
(mov( x 0_u64 (as R8 IndexList[]) ))
(as R8 IndexList[])
)) IndexList[]);
non-zero := λ(: x MacroList). (: (tail(
(let r 1_u64)
(match x (
()
( MEOF (set r 0_u64))
( _ () )
))
r
)) U64);
non-zero := λ(: x IndexList). (: (tail(
(let r 1_u64)
(match x (
()
( IEOF (set r 0_u64))
( _ () )
))
r
)) U64);
preprocess := λ. (: (tail(
(preprocess-index-typedefs ast-parsed-program)
(let program (maybe-deref(preprocess-apply ast-parsed-program)))
(set ast-parsed-program program)
)) Nil);
preprocess-index-typedefs := λ(: program AST). (: (
(while (non-zero program) (match program (
()
( (Seq( rst term )) (tail(
(preprocess-index-typedef term)
(set program rst)
)))
( _ (set program ASTEOF) )
)))
) Nil);
preprocess-index-typedef := λ(: term AST). (: (match term (
()
( (ASTType( lhs rhs )) (
(preprocess-index-indices( rhs 0_u64 ))
))
( _ () )
)) Nil);
preprocess-index-indices := λ(: def AST)(: index U64) . (: (tail(
()
(match def (
()
( (App( (App( tds (Var '|_s) )) body )) (tail(
(preprocess-index-indices( tds (+( index 1_u64 )) ))
(preprocess-index-index( body index ))
)))
( body (
(preprocess-index-index( body index ))
))
))
)) Nil);
preprocess-index-index := λ(: body AST)(: index U64). (: (tail(
(match body (
()
( (Lit tag) (
(set preprocess-tag-indices (ISeq(
(close preprocess-tag-indices)
tag
index
)))
))
( (App( (Lit tag) args )) (
(set preprocess-tag-indices (ISeq(
(close preprocess-tag-indices)
tag
index
)))
))
( _ () )
))
()
)) Nil);
preprocess-apply := λ(: program AST). (: (tail(
(let r program)
(match program (
()
( (App( (App( (Lit ':_s) mvar )) (Lit mtype) )) (
(set r (Asc( (preprocess-apply mvar) (parse-type mtype) )))
))
( (App( (App( (Lit ':_s) mvar )) (Var mtype) )) (
(set r (Asc( (preprocess-apply mvar) (parse-type mtype) )))
))
( (Lit l) (tail(
(let suffixes parse-suffixes)
(while (non-zero suffixes) (match suffixes (
()
( (SfxSeq( rst (*( sfxs sfxtt )) )) (
(if (is-suffix( l sfxs )) (tail(
(let lloc (maybe-deref(location l)))
(let lpfx (remove-suffix( l sfxs )))
(add-location( lpfx lloc ))
(set r (Asc( (close (Lit lpfx)) (close sfxtt) )))
(set suffixes SfxEOF)
)) (
(set suffixes rst)
))
))
)))
)))
( (Var l) (tail(
(let suffixes parse-suffixes)
(while (non-zero suffixes) (match suffixes (
()
( (SfxSeq( rst (*( sfxs sfxtt )) )) (
(if (is-suffix( l sfxs )) (tail(
(let lloc (maybe-deref(location l)))
(let lpfx (remove-suffix( l sfxs )))
(add-location( lpfx lloc ))
(set r (Asc( (close (Lit lpfx)) (close sfxtt) )))
(set suffixes SfxEOF)
)) (
(set suffixes rst)
))
))
)))
)))
( (App( (Var vn) vt )) (
if (is-macro-head vn) (tail(
(let applied (maybe-deref(preprocess-apply-maybe program)))
(set r applied)
)) (set r (App( (close(Var vn)) (preprocess-apply vt) )))
))
( (App( (App( (Var vn) vt1 )) vt2 )) (
if (is-macro-head vn) (tail(
(let applied (maybe-deref(preprocess-apply-maybe program)))
(set r applied)
)) (set r (App( (close(App( (close(Var vn)) (preprocess-apply vt1) ))) (preprocess-apply vt2) )))
))
( (Seq( al ar )) (set r (Seq(
(preprocess-apply al)
(preprocess-apply ar)
))))
( (App( al ar )) (set r (App(
(preprocess-apply al)
(preprocess-apply ar)
))))
( (Abs( al ar )) (set r (Abs(
(preprocess-apply al)
(preprocess-apply ar)
))))
( (Asc( al at )) (set r (Asc(
(preprocess-apply al)
(close at)
))))
( (Fragment( al ar )) (set r (Fragment(
al
(preprocess-apply ar)
))))
( (Glb( k ar )) (set r (Glb(
k
(preprocess-apply ar)
))))
( u (set r u))
))
(close r)
)) AST[]);
is-macro-head := λ(: s String). (: (tail(
(let r 0_u64)
(match s (
()
( 'let_s (set r 1_u64) )
( 'match_s (set r 1_u64) )
( 'match-pats_s (set r 1_u64) )
( 'match-pats-arm_s (set r 1_u64) )
( _ () )
))
r
)) U64);
merge := λ(: l Context)(: r Context). (: (tail(
(match (CPair( l r )) (
()
( (CPair( CtxEOF _ )) (set l CtxEOF ) )
( (CPair( _ CtxEOF )) (set l CtxEOF ) )
( (CPair( CtxNil cr )) (set l cr) )
( (CPair( cl CtxNil )) (set l cl) )
( (CPair( (CtxBind( cl (*( kl vl )) ))
(CtxBind( cr (*( kr vr )) )) )) (tail(
(let c1 (merge( cl cr )))
(let c2 (close(CtxBind( c1 kl (close vl) ))))
(let c3 (CtxBind( c2 kr (close vr) )))
(set l c3)
)))
))
(close l)
)) Context[]);
try-destructure-macro := λ(: lhs AST)(: term AST). (: (tail(
(let r CtxEOF)
(match (Pair( lhs term )) (
()
( (Pair( ASTNil ASTNil )) (set r CtxNil) )
( (Pair( (App(pl pr)) (App(el er)) )) (tail(
(let ll (maybe-deref(try-destructure-macro( pl el ))))
(if (non-zero ll) (tail(
(let rl (maybe-deref(try-destructure-macro( pr er ))))
(if (non-zero rl) (tail(
(let m (maybe-deref(merge( ll rl ))))
(set r m)
)) ())
)) ())
)))
( (Pair( (Abs(pl pr)) (Abs(el er)) )) (tail(
(let ll (maybe-deref(try-destructure-macro( pl el ))))
(if (non-zero ll) (tail(
(let rl (maybe-deref(try-destructure-macro( pr er ))))
(if (non-zero rl) (tail(
(let m (maybe-deref(merge( ll rl ))))
(set r m)
)) ())
)) ())
)))
( (Pair( (Lit pl) (Var el) )) (
(if (==( pl el )) (set r CtxNil) ())
))
( (Pair( (Lit pl) (Lit el) )) (
(if (==( pl el )) (set r CtxNil) ())
))
( (Pair( (App( (Lit ':Literal:_s) (Var pv) )) (Lit el) )) (
(if (==( (preprocess-index-of-tag el) preprocess-tag-index-eof ))
(set r (CtxBind( (close CtxNil) pv (close term) )))
()
)
))
( (Pair( (App( (Lit ':Variable:_s) (Var pv) )) (Var el) )) (
(set r (CtxBind( (close CtxNil) pv (close term) )))
))
( (Pair( (App( (App( (Lit ':Tag:_s) (Var pv) )) (Var pt) )) (Lit el) )) (
(if (==( (preprocess-index-of-tag el) preprocess-tag-index-eof )) () (tail(
(set r CtxNil)
(set r (CtxBind( (close r) pv (close(
(Asc(
(close(Lit (to-string(preprocess-index-of-tag el)) ))
(parse-type 'Constant+Literal+U64_s)
))
)) )))
(set r (CtxBind( (close r) pt (close(Lit el)) )))
)))
))
( (Pair( (Var pv) _ )) (
(set r (CtxBind( (close CtxNil) pv (close term) )))
))
( _ () )
))
(close r)
)) Context[]);
apply-context := λ(: ctx Context)(: term AST). (: (tail(
(match term (
()
( (Var n) (
(while (non-zero ctx) (match ctx (
()
( (CtxBind( rst (*(k v)) )) (
(if (==( k n )) (tail(
(set term v)
(set ctx CtxEOF)
)) (
(set ctx rst)
))
))
( _ (set ctx CtxEOF))
)))
))
( (App( vl vr )) (
(set term (App(
(apply-context( ctx vl ))
(apply-context( ctx vr ))
)))
))
( (Abs( vl vr )) (
(set term (Abs(
(apply-context( ctx vl ))
(apply-context( ctx vr ))
)))
))
( _ () )
))
(close term)
)) AST[]);
substitute-uuids := λ(: ctx Context)(: term AST). (: (tail(
(match term (
()
( (App( (Var 'uuid_s) (Var x ) )) (
(while (non-zero ctx) (match ctx (
()
( (CtxBind( rst (*( k v )) )) (
(if (==( x k )) (tail(
(set term v)
(set ctx rst)
)) (
(set ctx rst)
))
))
( _ (set ctx CtxEOF) )
)))
))
( (App( l r )) (
(set term (App(
(substitute-uuids( ctx l ))
(substitute-uuids( ctx r ))
)))
))
( (Abs( l r )) (
(set term (Abs(
(substitute-uuids( ctx l ))
(substitute-uuids( ctx r ))
)))
))
( (Asc( l rt )) (
(set term (Asc(
(substitute-uuids( ctx l ))
(close rt)
)))
))
( _ () )
))
(close term)
)) AST[]);
extract-uuids := λ(: ctx Context)(: term AST). (: (tail(
(match term (
()
( (App( (Var 'uuid_s) (Var x) )) (tail(
(let lctx (CtxBind( (close ctx) x (close(Var (uuid()))) )))
(set ctx lctx)
)))
( (App( l r )) (tail(
(let lctx (maybe-deref(extract-uuids( ctx l ))))
(let rctx (maybe-deref(extract-uuids( lctx r ))))
(set ctx rctx)
)))
( (Abs( l r )) (tail(
(let lctx (maybe-deref(extract-uuids( ctx l ))))
(let rctx (maybe-deref(extract-uuids( lctx r ))))
(set ctx rctx)
)))
( (Asc( l rt )) (tail(
(let lctx (maybe-deref(extract-uuids( ctx l ))))
(set ctx lctx)
)))
( _ () )
))
(close ctx)
)) Context[]);
preprocess-apply-maybe := λ(: program AST). (: (tail(
(let macros preprocess-macros)
(let matched False_u8)
(while (non-zero macros) (match macros (
()
( (MSeq( rst (Macro( lhs rhs )) )) (
(match (try-destructure-macro( lhs program )) (
()
( CtxEOF (set macros rst) )
( ctx (tail(
#(print 'Match:\s_s)
#(print ctx)
(let p (maybe-deref(apply-context( ctx rhs ))))
(let c (maybe-deref(extract-uuids( CtxEOF p ))))
(let u (maybe-deref(substitute-uuids( c p ))))
#(print 'Yield:\s_s)
#(print u)
#(print '\n_s)
(let n (maybe-deref(preprocess-apply u)))
(set program n)
(set macros MEOF)
(set matched True_u8)
)))
))
))
( _ (set macros MEOF) )
)))
(if (==( matched False_u8 )) (tail(
(print 'Match\sFailed:\s_s)
(print program)
(print '\n_s)
(exit 1_u64)
)) ())
(match program (
()
( (App( l r )) (tail(
(let np (App(
(preprocess-apply l)
(preprocess-apply r)
)))
(set program np)
)))
( _ () )
))
(close program)
)) AST[]);