1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
|
functor RewriteGen
(structure AstRewriter : MDL_AST_REWRITER
structure AstPP : MDL_AST_PRETTY_PRINTER
structure AstTrans : MDL_AST_TRANSLATION
structure Parser : MDL_PARSER_DRIVER
structure PolyGen : POLY_GEN
sharing AstRewriter.Ast = AstPP.Ast = AstTrans.Ast =
Parser.Ast = PolyGen.Ast
) : REWRITE_GEN =
struct
structure Ast = AstRewriter.Ast
structure A = Ast
structure T = AstTrans
val NO = AstRewriter.noRewrite
val RW = AstRewriter.rewrite
exception RewriteGen
fun bug msg = MLRiscErrorMsg.error("RewriteGen",msg)
fun error msg = (TextIO.output(TextIO.stdErr,msg^"\n"); raise RewriteGen)
fun ID x = A.IDexp(A.IDENT([],x))
(*
* Collect datatype and function declaractions
*)
fun processDecls hook (decls,exps) =
let val datatypeBinds = ref []
val funBinds = ref []
val miscDecls = ref []
fun enterDb(db as A.DATATYPEbind _) =
datatypeBinds := db :: !datatypeBinds
| enterDb _ = ()
fun enterFb fbs = funBinds := fbs :: !funBinds
fun enterMisc d = miscDecls := d :: !miscDecls
fun decl _ (d as A.DATATYPEdecl(dbs, _)) = (app enterDb dbs; d)
| decl _ (d as A.FUNdecl fbs) = (enterFb fbs; d)
| decl _ (d as A.VALdecl vbs) = (enterMisc d; d)
| decl _ (d as A.OPENdecl vbs) = (enterMisc d; d)
| decl _ d = d (* ignore the rest *)
(* Collect info *)
val _ = map (#decl (RW{sexp=NO,ty=NO,decl=decl,exp=NO,pat=NO})) decls
(* Collect rules *)
fun findDb name =
let fun find((db as A.DATATYPEbind{id, ...})::dbs) =
if name = id then db else find dbs
| find(_::dbs) = find dbs
| find [] = error("unknown datatype "^name)
in find(!datatypeBinds)
end
fun processRules(A.FUNbind(name, clauses)) = (findDb(name), clauses)
val rules = map (map processRules) (rev(!funBinds))
val nonTerms = foldr (fn (fbs,ids) =>
foldr (fn (A.FUNbind(id,_),ids) => id::ids)
ids fbs) [] (!funBinds)
fun isNonTerm id = List.exists(fn id' => id=id') nonTerms
val generated = map (PolyGen.gen hook isNonTerm) rules
val miscs = rev(!miscDecls)
in A.LETexp(miscs @ generated, exps)
end
(*
* Hooks for various things
*)
val rewriteHook =
PolyGen.HOOK
{ name ="rewrite",
factor=true,
args =["redex"],
ret ="redex",
unit =fn x => x,
gen =fn(trans,cons) =>
T.mapConsToExp
{id=fn{newName,ty,...} => trans(ty,ID newName),
prefix=[]
} cons
}
val appHook =
PolyGen.HOOK
{ name ="app",
factor=false,
args =["redex"],
ret ="_",
unit =fn _ => A.TUPLEexp [],
gen =fn (trans,cons) =>
let fun f({origName,newName,ty},es) = trans(ty,ID newName)::es
in A.SEQexp (rev(T.foldCons f [] cons))
end
}
val foldHook =
PolyGen.HOOK
{ name ="fold",
factor=false,
args =["redex","foldArg"],
ret ="foldArg",
unit = fn _ => ID "foldArg",
gen = fn (trans,cons) =>
T.foldCons
(fn({origName,newName,ty},e) =>
trans(ty,A.TUPLEexp[ID newName,e]))
(ID "foldArg") cons
}
fun compile decl =
let fun exp _ (A.APPexp(A.IDexp(A.IDENT(["Generic"],"rewrite")),
A.LETexp(decls,exp))) =
processDecls rewriteHook (decls,exp)
| exp _ (A.APPexp(A.IDexp(A.IDENT(["Generic"],"app")),
A.LETexp(decls,exp))) =
processDecls appHook (decls,exp)
| exp _ (A.APPexp(A.IDexp(A.IDENT(["Generic"],"fold")),
A.LETexp(decls,exp))) =
processDecls foldHook (decls,exp)
| exp _ e = e
in #decl(RW{sexp=NO,ty=NO,decl=NO,exp=exp,pat=NO}) decl
end
fun gen filename =
let val decl = A.SEQdecl(Parser.load filename)
val decl =
A.SEQdecl
[A.$["(* WARNING: This file is generated using 'rwgen "^
filename^"' *)"],
compile decl
]
in PP.text(AstPP.decl decl)
end
fun main(_, [filename]) =
((print(gen filename); 0)
handle e => (print("Uncaught exception "^exnName e^"\n"); 1))
| main(_, _) = (print("Usage: rwgen <filename>\n"); 1)
end
|