signature POSTELAB = sig (* Take an Absyn.dec, and get rid of nested patterns (Match-compilation) *) val transDec : { rootdec: Absyn.dec, env: StaticEnv.staticEnv, compInfo: Absyn.dec CompInfo.compInfo } -> Absyn.dec val debug : bool ref end structure PostElab : POSTELAB = struct val debug = ref false local structure PU = PEUtil open Absyn val region = ref (0, 0) in fun withRegion loc f x = let val r = !region in (region := loc; f x before region := r) handle e => (if ! debug then print ("PostElab: Exception handled for region " ^ Int.toString (#1 (! region)) ^ "--" ^ Int.toString (#2 (! region)) ^ "\n") else (); region := r; raise e) end fun transDec {rootdec, env, compInfo as {error,...} : Absyn.dec CompInfo.compInfo} = let fun mkv () = (#mkLvar compInfo) NONE fun complain s = error (!region) s fun mkDec (VALdec vbs) = VALdec (map mkVB vbs) | mkDec (VALRECdec rvbs) = VALRECdec (map mkRVB rvbs) | mkDec (x as TYPEdec _) = x | mkDec (x as DATATYPEdec _) = x | mkDec (ABSTYPEdec {abstycs, withtycs, body}) = ABSTYPEdec {abstycs=abstycs, withtycs=withtycs, body=mkDec body} | mkDec (EXCEPTIONdec ebs) = EXCEPTIONdec (map mkEB ebs) | mkDec (STRdec strs) = STRdec (map mkSTR strs) | mkDec (ABSdec strs) = ABSdec (map mkSTR strs) | mkDec (FCTdec fcts) = FCTdec (map mkFCT fcts) | mkDec (x as SIGdec _) = x | mkDec (x as FSIGdec _) = x | mkDec (x as OPENdec _) = x | mkDec (LOCALdec (d, d')) = LOCALdec (mkDec d, mkDec d') | mkDec (SEQdec decs) = SEQdec (map mkDec decs) | mkDec (x as OVLDdec _) = x | mkDec (x as FIXdec _) = x | mkDec (MARKdec (dec, r)) = MARKdec (withRegion r mkDec dec, r) and mkVB (VB {pat=vp as (VARpat _), exp, boundtvs,tyvars}) = VB {pat=vp, exp=mkExp exp, boundtvs=boundtvs, tyvars=tyvars} | mkVB (VB {pat=p as (CONSTRAINTpat (VARpat _, _)), exp, boundtvs,tyvars}) = VB {pat=p, exp=mkExp exp, boundtvs=boundtvs, tyvars=tyvars} (* | mkVB ((VB {pat=p as (RECORDpat {fields=[], ...}), exp, boundtvs, tyvars})) = VB {pat=p, exp=mkExp exp, boundtvs=boundtvs, tyvars=tyvars} *) | mkVB (VB {pat=WILDpat, exp, boundtvs, tyvars}) = VB {pat=WILDpat, exp=mkExp exp, boundtvs=boundtvs, tyvars=tyvars} | mkVB (VB {pat, exp, boundtvs, tyvars}) = raise Fail "Can't call Matchcompiler from vb yet" (* Elaboration seems to prevent this from ever happening *) and mkRVB (RVB {var, exp, boundtvs, resultty, tyvars}) = RVB {var=var, exp=mkExp exp, boundtvs=boundtvs, tyvars=tyvars, resultty=resultty} and mkEB (EBgen {exn, etype, ident}) = EBgen {exn=exn, etype=etype, ident=mkExp ident} | mkEB ebgen = ebgen and mkSTR (STRB {name, str, def}) = STRB {name=name, str=str, def=mkStrexp def} and mkStrexp (x as VARstr _) = x | mkStrexp (x as STRstr _) = x | mkStrexp (x as APPstr _) = x | mkStrexp (LETstr (dec, strexp)) = LETstr (mkDec dec, mkStrexp strexp) | mkStrexp (MARKstr (strexp, r)) = MARKstr (withRegion r mkStrexp strexp, r) and mkFCT (FCTB {name, fct, def}) = FCTB {name=name, fct=fct, def=mkFctexp def} and mkFctexp (x as VARfct _) = x | mkFctexp (FCTfct {param, argtycs, def}) = FCTfct {param=param, argtycs=argtycs, def=mkStrexp def} | mkFctexp (LETfct (dec, fctexp)) = LETfct (mkDec dec, mkFctexp fctexp) | mkFctexp (MARKfct (fctexp, r)) = MARKfct (withRegion r mkFctexp fctexp, r) and mkRules rules = map (fn (RULE (p, e)) => RULE (p, mkExp e)) rules and mkExp (x as VARexp _) = x | mkExp (x as CONexp _) = x | mkExp (x as INTexp _) = x | mkExp (x as WORDexp _) = x | mkExp (x as REALexp _) = x | mkExp (x as STRINGexp _) = x | mkExp (x as CHARexp _) = x | mkExp (RECORDexp les) = RECORDexp (map (fn (l,e) => (l, mkExp e)) les) | mkExp (SELECTexp (lab, exp)) = SELECTexp (lab, mkExp exp) | mkExp (VECTORexp (exps, ty)) = VECTORexp (map mkExp exps, ty) | mkExp (PACKexp (exp, ty, cons)) = PACKexp (mkExp exp, ty, cons) | mkExp (APPexp (exp, exp')) = APPexp (mkExp exp, mkExp exp') | mkExp (HANDLEexp (exp, HANDLER(fnexp as FNexp _))) = HANDLEexp (mkExp exp, HANDLER (mkExp fnexp)) | mkExp (HANDLEexp (exp, HANDLER _)) = raise Fail "HANDLEexp HANDLE not FNexp!" | mkExp (RAISEexp (e, ty)) = RAISEexp (mkExp e, ty) | mkExp (CASEexp (sv, rules, isMatch)) = let val rules' = mkRules rules val sv' = mkExp sv in if PU.needsMatchCompile rules' then let val pes = map (fn (RULE x) => x) rules' val rootv = PU.newVALvar ("caseSwitchVal", (PU.getType sv' handle x => raise x), mkv) fun finish x = let val vb = VB {pat=VARpat rootv, exp=sv', boundtvs=[], tyvars=ref []} in LETexp (VALdec [vb], x) end in if isMatch then PEMatch.matchCompile(env, pes, finish, rootv, complain) handle x => raise x else PEMatch.bindCompile(env, pes, finish, rootv, complain) handle x => raise x end else (* no matchcompile required *) CASEexp (sv', rules', isMatch) end | mkExp (FNexp (rules, domain)) = let val rules' = mkRules rules in if PU.needsMatchCompile rules' then let val rootv = PU.newVALvar ("fnArg", domain, mkv) val pes = map (fn (RULE x) => x) rules' fun finish x = let val rs = PU.finishRules (env, [RULE (VARpat rootv, x)], "Match") in FNexp (rs, domain) end in PEMatch.matchCompile (env, pes, finish, rootv, complain) handle x => raise x end else (* no matchcompile required *) FNexp (rules', domain) end | mkExp (LETexp (d, e)) = LETexp (mkDec d, mkExp e) | mkExp (SEQexp exps) = SEQexp (map mkExp exps) | mkExp (CONSTRAINTexp (e, ty)) = CONSTRAINTexp (mkExp e, ty) | mkExp (MARKexp (e, r)) = MARKexp (withRegion r mkExp e, r) in mkDec rootdec end end (* local *) end (* struct *)