Mercurial > urweb
changeset 480:40c737913075
Especialize handles records better
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 08 Nov 2008 16:02:59 -0500 |
| parents | ffa18975e661 |
| children | 2280193bf298 |
| files | src/core_print.sml src/corify.sml src/elaborate.sml src/especialize.sml src/expl_print.sml |
| diffstat | 5 files changed, 29 insertions(+), 16 deletions(-) [+] |
line wrap: on
line diff
--- a/src/core_print.sml Sat Nov 08 14:42:52 2008 -0500 +++ b/src/core_print.sml Sat Nov 08 16:02:59 2008 -0500 @@ -93,7 +93,7 @@ string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupCNamed env n))) - handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] | CApp (c1, c2) => parenIf par (box [p_con env c1,
--- a/src/corify.sml Sat Nov 08 14:42:52 2008 -0500 +++ b/src/corify.sml Sat Nov 08 16:02:59 2008 -0500 @@ -387,7 +387,7 @@ fun lookupStrById ({basis, strs, ...} : t) n = case IM.find (strs, n) of - NONE => raise Fail "Corify.St.lookupStrById" + NONE => raise Fail ("Corify.St.lookupStrById(" ^ Int.toString n ^ ")") | SOME f => dummy (basis, f) fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) = @@ -602,7 +602,7 @@ | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) -fun corifyDecl mods ((d, loc : EM.span), st) = +fun corifyDecl mods (all as (d, loc : EM.span), st) = case d of L.DCon (x, n, k, c) => let
--- a/src/elaborate.sml Sat Nov 08 14:42:52 2008 -0500 +++ b/src/elaborate.sml Sat Nov 08 16:02:59 2008 -0500 @@ -2615,14 +2615,14 @@ | (L'.SgnFun (m1, n1, dom1, ran1), L'.SgnFun (m2, n2, dom2, ran2)) => let - val ran1 = + val ran2 = if n1 = n2 then - ran1 + ran2 else - subStrInSgn (n1, n2) ran1 + subStrInSgn (n2, n1) ran2 in subSgn (env, denv) dom2 dom1; - subSgn (E.pushStrNamedAs env m2 n2 dom2, denv) ran1 ran2 + subSgn (E.pushStrNamedAs env m1 n1 dom2, denv) ran1 ran2 end | _ => sgnError env (SgnWrongForm (sgn1, sgn2)))
--- a/src/especialize.sml Sat Nov 08 14:42:52 2008 -0500 +++ b/src/especialize.sml Sat Nov 08 16:02:59 2008 -0500 @@ -106,6 +106,11 @@ fun getApp e = case e of ENamed f => SOME (f, [], []) + | EField ((ERecord xes, _), (CName x, _), _) => + (case List.find (fn ((CName x', _), _,_) => x' = x + | _ => false) xes of + NONE => NONE + | SOME (_, (e, _), _) => getApp e) | EApp (e1, e2) => (case getApp (#1 e1) of NONE => NONE @@ -125,10 +130,18 @@ in case getApp e of NONE => (e, st) - | SOME (_, [], _) => (e, st) + | SOME (f, [], xs') => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f, ErrorMsg.dummySpan) xs'), st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => ((*print ("SHOT DOWN! " ^ Int.toString f ^ "\n");*) (e, st)) + NONE => + let + val e = foldl (fn (arg, e) => (EApp (e, skeyOut arg), ErrorMsg.dummySpan)) + (ENamed f, ErrorMsg.dummySpan) xs + in + (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + e xs'), st) + end | SOME {name, args, body, typ, tag} => case KM.find (args, xs) of SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
--- a/src/expl_print.sml Sat Nov 08 14:42:52 2008 -0500 +++ b/src/expl_print.sml Sat Nov 08 16:02:59 2008 -0500 @@ -97,7 +97,7 @@ | CModProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) - handle E.UnboundNamed _ => "UNBOUND" + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString m1 val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -226,7 +226,7 @@ | EModProj (m1, ms, x) => let val (m1x, sgn) = E.lookupStrNamed env m1 - handle E.UnboundNamed _ => ("UNBOUND", (SgnConst [], loc)) + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -487,11 +487,11 @@ newline, string "end"] | SgnVar n => string ((#1 (E.lookupSgnNamed env n)) - handle E.UnboundNamed _ => "UNBOUND") + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n) | SgnFun (x, n, sgn, sgn') => box [string "functor", space, string "(", - string x, + p_named x n, space, string ":", space, @@ -515,7 +515,7 @@ | SgnProj (m1, ms, x) => let val (m1x, sgn) = E.lookupStrNamed env m1 - handle E.UnboundNamed _ => ("UNBOUND", (SgnConst [], loc)) + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -643,7 +643,7 @@ | StrVar n => let val x = #1 (E.lookupStrNamed env n) - handle E.UnboundNamed _ => "UNBOUND" + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n val s = if !debug then x ^ "__" ^ Int.toString n @@ -662,7 +662,7 @@ box [string "functor", space, string "(", - string x, + p_named x n, space, string ":", space,