diff options
| -rw-r--r-- | src/core_print.sml | 2 | ||||
| -rw-r--r-- | src/corify.sml | 4 | ||||
| -rw-r--r-- | src/elaborate.sml | 8 | ||||
| -rw-r--r-- | src/especialize.sml | 17 | ||||
| -rw-r--r-- | src/expl_print.sml | 14 |
5 files changed, 29 insertions, 16 deletions
diff --git a/src/core_print.sml b/src/core_print.sml index 7de31568..c4341e51 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -93,7 +93,7 @@ fun p_con' par env (c, _) = 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, diff --git a/src/corify.sml b/src/corify.sml index 2b90a8f0..fdb4e7b7 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -387,7 +387,7 @@ fun bindStr ({basis, cons, constructors, vals, strs, funs, 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 @@ fun corifyExp st (e, loc) = | 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 diff --git a/src/elaborate.sml b/src/elaborate.sml index 17133d93..70429c1b 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2615,14 +2615,14 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | (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))) diff --git a/src/especialize.sml b/src/especialize.sml index adb444b5..92e29da3 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -106,6 +106,11 @@ fun exp (e, st : state) = 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 @@ fun exp (e, st : state) = 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))];*) diff --git a/src/expl_print.sml b/src/expl_print.sml index 2d41ab34..e3153ef2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -97,7 +97,7 @@ fun p_con' par env (c, _) = | 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 @@ fun p_exp' par env (e, loc) = | 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 @@ and p_sgn env (sgn, loc) = 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 @@ and p_sgn env (sgn, loc) = | 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 @@ and p_str env (str, _) = | 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 @@ and p_str env (str, _) = box [string "functor", space, string "(", - string x, + p_named x n, space, string ":", space, |