signature PE_UTIL = sig val getType : Absyn.exp -> Types.ty val pat2type : Absyn.pat -> Types.ty val extractCONty : Types.ty -> Types.ty val extractCONty' : Types.ty -> Types.ty val getConstructorTy : Types.ty * Types.ty list -> Types.ty val newVALvar : string * Types.ty * (unit -> LambdaVar.lvar) -> VarCon.var val finishRules : StaticEnv.staticEnv * Absyn.rule list * string -> Absyn.rule list val getRuleTy : Absyn.rule list -> Types.ty val needsMatchCompile : Absyn.rule list -> bool val getLabel : int * Absyn.exp -> Absyn.numberedLabel exception BadParseResult of MLParser.parseResult exception ElaborationError val ppAbsynDec : Absyn.dec -> unit val ppAbsynExp : Absyn.exp -> unit val debug : bool ref val toInspect : Types.ty list ref val toInspectExp : Absyn.exp list ref end structure PEUtil : PE_UTIL = struct val debug = ref false; val toInspect : Types.ty list ref = ref [] val toInspectExp : Absyn.exp list ref = ref [] local structure BT = BasicTypes structure DA = Access structure CBT = CoreBasicTypes structure EU = ElabUtil structure TU = TypesUtil open Absyn VarCon Types in exception BadParseResult of MLParser.parseResult exception ElaborationError fun flush () = TextIO.flushOut (TextIO.stdOut) val ppc = {consumer=TextIO.print, linewidth=78, flush = flush} val stream = PrettyPrint.mk_ppstream ppc fun ppAbsynDec tree = (PPAbsyn.ppDec (StaticEnv.empty, NONE) stream (tree, 10000); PrettyPrint.flush_ppstream stream) fun ppAbsynExp exp = (PPAbsyn.ppExp (StaticEnv.empty, NONE) stream (exp, 10000); PrettyPrint.flush_ppstream stream) fun newVALvar (name, typ, mkv) = let val newvar = mkv () val name' = "<" ^ name ^ (Int.toString newvar) ^ ">" in (VALvar {path = SymPath.SPATH [Symbol.varSymbol name'], typ = ref typ, access = DA.LVAR (newvar), info = II.Null}) handle x => raise Fail ("Failing newVALvar on " ^ name' ^ "!") end fun getConstructorTy (POLYty {tyfun, ...}, ts) = TU.applyTyfun (tyfun, ts) | getConstructorTy (t, []) = t | getConstructorTy (t, _) = raise Fail "getConstructorTy: non-POLYty..." fun pat2type pat = case pat of WILDpat => UNDEFty | VARpat (VALvar {typ=ref ty, ...}) => ty | INTpat _ => BT.intTy | WORDpat _ => BT.wordTy | REALpat _ => BT.realTy | STRINGpat _ => BT.stringTy | CHARpat _ => BT.charTy | CONpat (dc, ts) => TU.dconType (TU.dconTyc dc, NONE) (* You'd think we could just use !typ for this... We can't. Elaboration will usually leave this as UNDEFty. *) | RECORDpat {fields, typ, flex=false, ...} => let fun g (label, pat) = (label, pat2type pat) in BT.recordTy (map g fields) end | RECORDpat {flex=true, ...} => raise Fail "Can't get type of flex record" | APPpat (dc, ts, pat) => TU.dconType (TU.dconTyc dc, NONE) | CONSTRAINTpat (_, ty) => ty | LAYEREDpat (_, pat) => pat2type pat | _ => (print "Warning: pat2type: returning UNDEFty\n"; UNDEFty) fun extractCONty ty = (case ty of CONty _ => ty | POLYty {tyfun = TYFUN {body = ty',... },... } => extractCONty ty' | VARty (ref (INSTANTIATED ty')) => extractCONty ty' | UNDEFty => (print "Warning: UNDEFty in extractCONty\n"; UNDEFty) | _ => raise Fail "getType: couldn't extract CONty") (* Like the above function, this digs down through POLYtys and VARtys to get at an inner CONty. However, if the CONty is a user-defined type (DEFtyc, not a simple RECORDtyc) it keeps recurring until it finds a CONty (RECORDtyc, _). *) fun extractCONty' ty = (case ty of CONty (RECORDtyc _, _) => ty | CONty (DEFtyc {tyfun=TYFUN {body=ty', ...}, ...}, _) => extractCONty' ty' | POLYty {tyfun = TYFUN {body = ty',... },... } => extractCONty' ty' | VARty (ref (INSTANTIATED ty')) => extractCONty' ty' | UNDEFty => (print "Warning: UNDEFty in extractCONty'\n"; UNDEFty) | _ => (print "\n\nType\n"; PPType.ppType StaticEnv.empty stream ty; PrettyPrint.flush_ppstream stream; print "\n"; flush(); toInspect := ty :: (! toInspect); raise Fail "getType: couldn't extract CONty'")) fun getType exp = (case exp of VARexp (ref v, _) => (case v of VALvar {typ=ref ty,...} => ty | _ => raise Fail "getType: VARexp") | CONexp (DATACON {typ = ty, ...}, _) => ty | INTexp _ => BT.intTy | WORDexp _ => BT.wordTy | REALexp _ => BT.realTy | STRINGexp _ => BT.stringTy | CHARexp _ => BT.charTy | RECORDexp fields => let fun g (LABEL {name = sym,...}, exp) = (sym, (getType exp) handle x => raise x) val fields' = map g fields in BT.recordTy fields' end | e as (SELECTexp (LABEL {name as Symbol.SYMBOL (symword, symstr), number}, exp)) => let val ety = extractCONty' (getType exp) handle x => raise x in (case ety of CONty (RECORDtyc syms, tys) => let val ty = List.nth (tys, number) handle x => raise x val sym as Symbol.SYMBOL (symword', symstr') = List.nth (syms, number) handle x => raise x in if Symbol.eq (sym, name) then ty else ((*print "\nLABEL of key\n"; print ("{name=(" ^ Word.toString symword ^ ", \""); print (symstr ^ "\"), number=" ^ Int.toString number); print "}\n"; print "\nSymbol from RECORDtyc\n"; print ("(" ^ Word.toString symword' ^ ", \""); print (symstr' ^ "\")\n"); print "\nExpression\n"; ppAbsynExp e; print "\n\nType\n"; PPType.ppType StaticEnv.empty stream (getType exp); PrettyPrint.flush_ppstream stream; print "\n\nCONty\n"; PPType.ppType StaticEnv.empty stream ety; PrettyPrint.flush_ppstream stream; print "\n\n";*) raise Fail "getType: SELECTexp fields don't match!") end | CONty (_, tys) => (print "\nExpression\n"; ppAbsynExp e; print "\n\nType\n"; PPType.ppType StaticEnv.empty stream (getType exp); PrettyPrint.flush_ppstream stream; print "\n\nCONty\n"; PPType.ppType StaticEnv.empty stream ety; PrettyPrint.flush_ppstream stream; print "\n\n"; print "Warning: getType: SELECTexp: not a RECORDtyc\n"; List.nth (tys, number) handle x => raise x) | _ => raise Fail "getType: SELECTexp") end | VECTORexp (exps, ty) => TU.mkCONty (CBT.vectorTycon, [ty]) (* PACKexp *) (* For this one, find the type of fcn, and take the second * element of the list that accompanies the "->" CONty. This * is the return type of the function being applied. *) (* "->" is PRIMITIVE 5 (right now) *) | APPexp (fcn, arg) => (case extractCONty (getType fcn) handle x => raise x of CONty (GENtyc {kind=PRIMITIVE 5, ...}, tys) => List.last tys | _ => raise Fail "getType: APPexp") | HANDLEexp (exp, HANDLER hexp) => ((getType hexp) handle x => raise x) | RAISEexp (exp, ty) => ty | CASEexp (_, rules,_) => getRuleTy rules | FNexp (rules, ty) => CBT.--> (ty, getRuleTy rules) | LETexp (_, exp) => ((getType exp) handle x => raise x) | SEQexp exps => ((getType (List.last exps)) handle x => raise x) | CONSTRAINTexp (_, ty) => ty | MARKexp (exp, _) => ((getType exp) handle x => raise x) | _ => raise Fail "getType: don't know type for this one") and getRuleTy rules = (case rules of RULE (p, e)::rs => ((getType e) handle x => raise x) | _ => raise Fail "getType: no rules in rule list") fun finishRules (env, rules as r::rs, str) = let val RULE (_, exp) = r val ty = ((getType exp) handle x => raise x) val _ = case ty of UNDEFty => raise Fail "finishRules: ty is UNDEF" | _ => () val rules' = EU.completeMatch (env, str) rules (* completeMatch leaves an UNDEFty in the RAISEexp *) fun g (RULE (WILDpat, e)) = let fun h (MARKexp (e, r)) = MARKexp (h e, r) | h (RAISEexp (conexp, UNDEFty)) = if ! debug then (print "\nfinishRules: RAISEexp\n"; ppAbsynExp conexp; print "\nType\n"; PPType.ppType StaticEnv.empty stream ty; PrettyPrint.flush_ppstream stream; print "\n\n"; toInspectExp := exp :: (! toInspectExp); toInspect := ty :: (! toInspect); RAISEexp (conexp, ty) ) else RAISEexp (conexp, ty) | h e = e in RULE (WILDpat, h e) end | g x = x in map g rules' end | finishRules (env, [], str) = raise Fail "finishRules: empty rule list" fun needsMatchCompile rules = let fun l2 (RECORDpat _) = true | l2 (APPpat _) = true | l2 (CONSTRAINTpat _) = true | l2 (LAYEREDpat _) = true | l2 (ORpat _) = raise Fail "needsMatchCompile: ORpat" | l2 (VECTORpat _) = raise Fail "needsMatchCompile: VECTORpat" | l2 NOpat = raise Fail "needsMatchCompile: NOpat" | l2 _ = false fun g (RULE (pat, _)) = case pat of (RECORDpat {flex=true, ...}) => true | (RECORDpat {fields=fs, flex=false, ...}) => foldr (fn ((_, p), b) => (l2 p orelse b)) false fs | (APPpat (_, _, p)) => l2 p | (CONSTRAINTpat _) => true | (LAYEREDpat _) => true | (ORpat _) => raise Fail "needsMatchCompile: ORpat" | (VECTORpat _) => raise Fail "needsMatchCompile: VECTORpat" | NOpat => raise Fail "needsMatchCompile: NOpat" | _ => false (* constant patterns, CONpat, and VARpat okay *) in foldr (fn (r, b) => (g r orelse b)) false rules end fun getLabel (n, exp) = let val labs = case (extractCONty' (getType exp) handle x => (toInspectExp := exp :: (!toInspectExp);raise x)) of CONty (RECORDtyc labels, _) => labels | _ => raise Fail "getLabel: no labels in exp's type?" in Absyn.LABEL {name=List.nth (labs, n), number=n} end end (* local *) end (* struct *)