Mercurial > urweb
changeset 1527:cccf8bf64b30
Fix opening of shadowing, principal-signatured modules that open other modules
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Thu, 04 Aug 2011 16:44:05 -0400 |
| parents | b5d78407886d |
| children | 7770ef82c463 |
| files | src/corify.sml src/elaborate.sml tests/openRedef.ur |
| diffstat | 3 files changed, 68 insertions(+), 23 deletions(-) [+] |
line wrap: on
line diff
--- a/src/corify.sml Tue Aug 02 20:17:41 2011 -0400 +++ b/src/corify.sml Thu Aug 04 16:44:05 2011 -0400 @@ -212,7 +212,7 @@ FFfi {mod = m, ...} => CFfi m | FNormal {cons, ...} => case SM.find (cons, x) of - NONE => raise Fail "Corify.St.lookupConByName" + NONE => raise Fail ("Corify.St.lookupConByName " ^ x) | SOME n => CNormal n fun bindVal {basis, cons, constructors, vals, strs, funs, current, nested} s n = @@ -275,7 +275,7 @@ | SOME t => EFfi (m, t)) | FNormal {name, vals, ...} => case SM.find (vals, x) of - NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." name ^ "." ^ x) + NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." (rev name) ^ "." ^ x) | SOME n => ENormal n fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
--- a/src/elaborate.sml Tue Aug 02 20:17:41 2011 -0400 +++ b/src/elaborate.sml Thu Aug 04 16:44:05 2011 -0400 @@ -2723,6 +2723,8 @@ and dopen env {str, strs, sgn} = let + fun isVisible x = x <> "" andalso String.sub (x, 0) <> #"?" + val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn)) (L'.StrVar str, #2 sgn) strs in @@ -2734,37 +2736,64 @@ val d = case sgi of L'.SgiConAbs (x, n, k) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - [(L'.DCon (x, n, k, c), loc)] - end + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] | L'.SgiCon (x, n, k, c) => - [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + if isVisible x then + [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + else + [] | L'.SgiDatatype dts => - map (fn (x, n, xs, xncs) => (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts + List.mapPartial (fn (x, n, xs, xncs) => if isVisible x then + SOME (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc) + else + NONE) dts | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => - [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)] + if isVisible x then + [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)] + else + [] | L'.SgiVal (x, n, t) => - [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] + if isVisible x then + [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] + else + [] | L'.SgiStr (x, n, sgn) => - [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] + if isVisible x then + [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] + else + [] | L'.SgiSgn (x, n, sgn) => - [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)] + if isVisible x then + [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)] + else + [] | L'.SgiConstraint (c1, c2) => [(L'.DConstraint (c1, c2), loc)] | L'.SgiClassAbs (x, n, k) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - [(L'.DCon (x, n, k, c), loc)] - end + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] | L'.SgiClass (x, n, k, _) => - let - val c = (L'.CModProj (str, strs, x), loc) - in - [(L'.DCon (x, n, k, c), loc)] - end + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] in (d, foldl (fn (d, env') => E.declBinds env' d) env' d) end)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/openRedef.ur Thu Aug 04 16:44:05 2011 -0400 @@ -0,0 +1,16 @@ +structure M = struct + con num = int + val zero = 0 +end + +structure N = struct + open M + con num = num * num + val zero = zero + 1 +end + +structure O = struct + open N + + val one : num = (zero + 1, zero) +end