Location and Directory

[hcoop/domtool2.git] / src / tycheck.sml

diff --git a/src/tycheck.sml b/src/tycheck.sml
index ac9fad5..152eaf7 100644 (file)
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -170,6 +170,8 @@ fun predImplies (p1All as (p1, _), p2All as (p2, _)) =
       | (_, CPrefix p2) => predImplies (p1All, p2)
 
       | (CNot p1, CNot p2) => predImplies (p2, p1)
+      | (CRoot, CNot (CConst _, _)) => true
+      | (CConst s1, CNot (CConst s2, _)) => s1 <> s2
 
       | _ => false
 
@@ -334,6 +336,23 @@ fun checkTyp G (tAll as (t, loc)) =
          | TUnif _ => raise Fail "TUnif in parser-generated type"
     end
 
+fun envVarSetFrom v (e, _) =
+    case e of
+       ESet (v', e) =>
+       if v = v' then
+           SOME e
+       else
+           NONE
+      | EGet (_, _, e) => envVarSetFrom v e
+      | ESeq es => foldr (fn (e, found) =>
+                            case found of
+                                SOME _ => found
+                              | NONE => envVarSetFrom v e)
+                        NONE es
+      | ELocal (_, e) => envVarSetFrom v e
+
+      | _ => NONE
+
 fun checkExp G (eAll as (e, loc)) =
     let
        val dte = describe_type_error loc
@@ -467,21 +486,25 @@ fun checkExp G (eAll as (e, loc)) =
                                                        (case SM.find (d', name) of
                                                             NONE => SM.insert (d', name, t)
                                                           | SOME t' =>
-                                                            (subTyp (t, t')
+                                                            ((case envVarSetFrom name e1 of
+                                                                  NONE => subTyp (t, t')
+                                                                | SOME e => hasTyp (e, t, t'))
                                                              handle Unify ue =>
                                                                     dte (WrongType ("Shared environment variable",
                                                                                     (EVar name, loc),
-                                                                                    t,
                                                                                     t',
+                                                                                    t,
                                                                                     SOME ue));
                                                              d'))
                                                      | SOME t' =>
-                                                       (subTyp (t, t')
+                                                       ((case envVarSetFrom name e1 of
+                                                                  NONE => subTyp (t, t')
+                                                                | SOME e => hasTyp (e, t, t'))
                                                         handle Unify ue =>
                                                                dte (WrongType ("Shared environment variable",
                                                                                (EVar name, loc),
-                                                                               t,
                                                                                t',
+                                                                               t,
                                                                                SOME ue));
                                                         d'))
                                                d1 d2
@@ -525,21 +548,25 @@ fun checkExp G (eAll as (e, loc)) =
                                                        (case SM.find (d', name) of
                                                             NONE => SM.insert (d', name, t)
                                                           | SOME t' =>
-                                                            (subTyp (t, t')
+                                                            ((case envVarSetFrom name e1 of
+                                                                  NONE => subTyp (t', t)
+                                                                | SOME e => hasTyp (e, t', t))
                                                              handle Unify ue =>
                                                                     dte (WrongType ("Shared environment variable",
                                                                                     (EVar name, loc),
-                                                                                    t,
                                                                                     t',
+                                                                                    t,
                                                                                     SOME ue));
                                                              d'))
                                                      | SOME t' =>
-                                                       (subTyp (t, t')
+                                                       ((case envVarSetFrom name e1 of
+                                                                  NONE => subTyp (t', t)
+                                                                | SOME e => hasTyp (e, t', t))
                                                         handle Unify ue =>
                                                                dte (WrongType ("Shared environment variable",
                                                                                (EVar name, loc),
-                                                                               t,
                                                                                t',
+                                                                               t,
                                                                                SOME ue));
                                                         d'))
                                                d1 d2