diff options
author | 2008-06-17 17:08:28 -0400 | |
---|---|---|
committer | 2008-06-17 17:08:28 -0400 | |
commit | 3fc43e22c438136877ca534fa6f75236c10350c8 (patch) | |
tree | b13b4acadebcd76da6644e143fe8e872a75cb692 | |
parent | b9406323848c150f5a8562ad206916c446529d65 (diff) |
Proper selfification
-rw-r--r-- | src/elaborate.sml | 42 | ||||
-rw-r--r-- | tests/modproj.lac | 20 |
2 files changed, 51 insertions, 11 deletions
diff --git a/src/elaborate.sml b/src/elaborate.sml index 7cc510ec..29d12b07 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1105,15 +1105,19 @@ fun sgiOfDecl (d, loc) = | L'.DSgn _ => NONE | L'.DStr (x, n, sgn, _) => SOME (L'.SgiStr (x, n, sgn), loc) -fun subSgn env (all1 as (sgn1, _)) (all2 as (sgn2, loc2)) = - case (sgn1, sgn2) of +fun hnormSgn env (all as (sgn, _)) = + case sgn of + L'.SgnError => all + | L'.SgnVar n => hnormSgn env (#2 (E.lookupSgnNamed env n)) + | L'.SgnConst _ => all + +fun subSgn env sgn1 (sgn2 as (_, loc2)) = + case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of (L'.SgnError, _) => () | (_, L'.SgnError) => () - | (L'.SgnVar n, _) => - subSgn env (#2 (E.lookupSgnNamed env n)) all2 - | (_, L'.SgnVar n) => - subSgn env all1 (#2 (E.lookupSgnNamed env n)) + | (L'.SgnVar n, _) => raise Fail "subSgn: Variable remains" + | (_, L'.SgnVar n) => raise Fail "subSgn: Variable remains" | (L'.SgnConst sgis1, L'.SgnConst sgis2) => let @@ -1195,6 +1199,18 @@ fun subSgn env (all1 as (sgn1, _)) (all2 as (sgn2, loc2)) = ignore (foldl folder env sgis2) end +fun selfify env {str, strs, sgn} = + case #1 (hnormSgn env sgn) of + L'.SgnError => sgn + | L'.SgnVar _ => sgn + + | L'.SgnConst sgis => + (L'.SgnConst (map (fn (L'.SgiConAbs (x, n, k), loc) => + (L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) + | (L'.SgiStr (x, n, sgn), loc) => + (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) + | x => x) sgis), #2 sgn) + fun elabDecl ((d, loc), env) = let @@ -1279,8 +1295,20 @@ fun elabDecl ((d, loc), env) = val formal = Option.map (elabSgn env) sgno val (str', actual) = elabStr env str + fun self (str, _) = + case str of + L'.StrVar x => SOME (x, []) + | L'.StrProj (str, x) => + (case self str of + NONE => NONE + | SOME (m, ms) => SOME (m, ms @ [x])) + | _ => NONE + val sgn' = case formal of - NONE => actual + NONE => + (case self str' of + NONE => actual + | SOME (str, strs) => selfify env {sgn = actual, str = str, strs = strs}) | SOME formal => (subSgn env actual formal; formal) diff --git a/tests/modproj.lac b/tests/modproj.lac index ef2364d1..31d70d5b 100644 --- a/tests/modproj.lac +++ b/tests/modproj.lac @@ -1,11 +1,23 @@ -signature S = sig +signature S1 = sig type t val zero : t end -structure S : S = struct +signature S2 = sig + type t = int + val zero : t +end +structure S = struct type t = int val zero = 0 end +structure S1 : S1 = S +structure S2 : S2 = S + +type t = S1.t +val zero : t = S1.zero + +type t = S2.t +val zero : int = S2.zero -type t = S.t -val zero : t = S.zero +structure T = S1 +val zero : S1.t = T.zero |