changeset 1868:d6b0ee53dc93

Get -root working properly again
author Adam Chlipala <adam@chlipala.net>
date Thu, 26 Sep 2013 16:22:06 -0400
parents 216a3a67ebe3
children 16b08de04f05
files src/compiler.sml src/elaborate.sml src/mod_db.sml src/source.sml src/source_print.sml src/urweb.grm
diffstat 6 files changed, 50 insertions(+), 39 deletions(-) [+]
line wrap: on
line diff
--- a/src/compiler.sml	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/compiler.sml	Thu Sep 26 16:22:06 2013 -0400
@@ -917,7 +917,10 @@
                            end)
 
 val moduleRoots = ref ([] : (string * string) list)
-fun addModuleRoot (k, v) = moduleRoots := (k, v) :: !moduleRoots
+fun addModuleRoot (k, v) = moduleRoots :=
+                           (OS.Path.mkAbsolute {path = k,
+                                                relativeTo = OS.FileSys.getDir ()},
+                            v) :: !moduleRoots
 
 structure SK = struct
 type ord_key = string
@@ -998,7 +1001,7 @@
 
                           val ds = #func parseUr ur
                           val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
-                                                (Source.StrConst ds, loc)), loc)
+                                                (Source.StrConst ds, loc), false), loc)
 
                           val fname = OS.Path.mkCanonical fname
                           val d = case List.find (fn (root, name) =>
@@ -1014,7 +1017,7 @@
                                           val pieces = map capitalize pieces
                                           val full = String.concatWith "." pieces
 
-                                          fun makeD prefix pieces =
+                                          fun makeD first prefix pieces =
                                               case pieces of
                                                   [] => (ErrorMsg.error "Empty module path";
                                                          (Source.DStyle "Boo", loc))
@@ -1056,7 +1059,7 @@
                                                                                          else
                                                                                              (Source.StrVar part, loc)
                                                                            in
-                                                                               (Source.DStr (part, NONE, NONE, imp),
+                                                                               (Source.DStr (part, NONE, NONE, imp, false),
                                                                                 loc) :: ds
                                                                            end
                                                                        else
@@ -1066,9 +1069,10 @@
                                                       (Source.DStr (piece, NONE, NONE,
                                                                     (Source.StrConst (if old then
                                                                                           simOpen ()
-                                                                                          @ [makeD this pieces]
+                                                                                          @ [makeD false this pieces]
                                                                                       else
-                                                                                          [makeD this pieces]), loc)),
+                                                                                          [makeD false this pieces]),
+                                                                     loc), first andalso old),
                                                        loc)
                                                   end
                                       in
@@ -1077,7 +1081,7 @@
                                           else
                                               ();
                                           
-                                          makeD "" pieces
+                                          makeD true "" pieces
                                           before ignore (foldl (fn (new, path) =>
                                                                    let
                                                                        val new' = case path of
@@ -1131,10 +1135,17 @@
                       val ds = case onError of
                                    NONE => ds
                                  | SOME v => ds @ [(Source.DOnError v, loc)]
+
+                      fun dummy fname = {file = Settings.libFile fname,
+                                         first = ErrorMsg.dummyPos,
+                                         last = ErrorMsg.dummyPos}
+
+                      val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
+                      val used = SM.insert (used, "Top", dummy "top.urs")
                   in
                       ignore (List.foldl (fn (d, used) =>
                                              case #1 d of
-                                                 Source.DStr (x, _, _, _) =>
+                                                 Source.DStr (x, _, _, _, false) =>
                                                  (case SM.find (used, x) of
                                                       SOME loc =>
                                                       (ErrorMsg.error ("Duplicate top-level module name " ^ x);
@@ -1143,7 +1154,7 @@
                                                        used)
                                                     | NONE =>
                                                       SM.insert (used, x, #2 d))
-                                               | _ => used) SM.empty ds);
+                                               | _ => used) used ds);
                       ds
                   end handle Empty => ds
               end,
--- a/src/elaborate.sml	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/elaborate.sml	Thu Sep 26 16:22:06 2013 -0400
@@ -3679,7 +3679,7 @@
                                    L.DCon (x, _, _) => ndelCon (nd, x)
                                  | L.DVal (x, _, _) => ndelVal (nd, x)
                                  | L.DOpen _ => nempty
-                                 | L.DStr (x, _, _, (L.StrConst ds', _)) =>
+                                 | L.DStr (x, _, _, (L.StrConst ds', _), _) =>
                                    (case SM.find (nmods nd, x) of
                                         NONE => nd
                                       | SOME (env, nd') => naddMod (nd, x, (env, removeUsed (nd', ds'))))
@@ -3748,11 +3748,11 @@
 
                          val ds = ds @ ds'
                      in
-                         map (fn d as (L.DStr (x, s, tm, (L.StrConst ds', loc')), loc) =>
+                         map (fn d as (L.DStr (x, s, tm, (L.StrConst ds', loc'), r), loc) =>
                                  (case SM.find (nmods nd, x) of
                                       NONE => d
                                     | SOME (env, nd') =>
-                                      (L.DStr (x, s, tm, (L.StrConst (extend (env, nd', ds')), loc')), loc))
+                                      (L.DStr (x, s, tm, (L.StrConst (extend (env, nd', ds')), loc'), r), loc))
                                | d => d) ds
                      end
              in
@@ -3963,7 +3963,7 @@
                     ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs))
                 end
 
-              | L.DStr (x, sgno, tmo, str) =>
+              | L.DStr (x, sgno, tmo, str, _) =>
                 (case ModDb.lookup dAll of
                      SOME d =>
                      let
@@ -4535,7 +4535,7 @@
 
         val d = (L.DStr ("Top", SOME (L.SgnConst topSgn, ErrorMsg.dummySpan),
                          SOME (if Time.< (top_tm, basis_tm) then basis_tm else top_tm),
-                         (L.StrConst topStr, ErrorMsg.dummySpan)), ErrorMsg.dummySpan)
+                         (L.StrConst topStr, ErrorMsg.dummySpan), false), ErrorMsg.dummySpan)
         val (top_n, env', topSgn, topStr) =
             case (if !incremental then ModDb.lookup d else NONE) of
                 NONE =>
--- a/src/mod_db.sml	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/mod_db.sml	Thu Sep 26 16:22:06 2013 -0400
@@ -126,7 +126,7 @@
 
 fun lookup (d : Source.decl) =
     case #1 d of
-        Source.DStr (x, _, SOME tm, _) =>
+        Source.DStr (x, _, SOME tm, _, _) =>
         (case SM.find (!byName, x) of
              NONE => NONE
            | SOME r =>
--- a/src/source.sml	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/source.sml	Thu Sep 26 16:22:06 2013 -0400
@@ -154,7 +154,7 @@
        | DVal of string * con option * exp
        | DValRec of (string * con option * exp) list
        | DSgn of string * sgn
-       | DStr of string * sgn option * Time.time option * str
+       | DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *)
        | DFfiStr of string * sgn * Time.time option
        | DOpen of string * string list
        | DConstraint of con * con
--- a/src/source_print.sml	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/source_print.sml	Thu Sep 26 16:22:06 2013 -0400
@@ -571,24 +571,24 @@
                               string "=",
                               space,
                               p_sgn sgn]
-      | DStr (x, NONE, _, str) => box [string "structure",
-                                       space,
-                                       string x,
-                                       space,
-                                       string "=",
-                                       space,
-                                       p_str str]
-      | DStr (x, SOME sgn, _, str) => box [string "structure",
-                                           space,
-                                           string x,
-                                           space,
-                                           string ":",
-                                           space,
-                                           p_sgn sgn,
-                                           space,
-                                           string "=",
-                                           space,
-                                           p_str str]
+      | DStr (x, NONE, _, str, _) => box [string "structure",
+                                          space,
+                                          string x,
+                                          space,
+                                          string "=",
+                                          space,
+                                          p_str str]
+      | DStr (x, SOME sgn, _, str, _) => box [string "structure",
+                                              space,
+                                              string x,
+                                              space,
+                                              string ":",
+                                              space,
+                                              p_sgn sgn,
+                                              space,
+                                              string "=",
+                                              space,
+                                              p_str str]
       | DFfiStr (x, sgn, _) => box [string "extern",
                                     space,
                                     string "structure",
--- a/src/urweb.grm	Fri Sep 13 10:24:10 2013 -0400
+++ b/src/urweb.grm	Thu Sep 26 16:22:06 2013 -0400
@@ -571,15 +571,15 @@
        | FUN valis                      ([(DValRec valis, s (FUNleft, valisright))])
 
        | SIGNATURE CSYMBOL EQ sgn       ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
-       | STRUCTURE CSYMBOL EQ str       ([(DStr (CSYMBOL, NONE, NONE, str), s (STRUCTUREleft, strright))])
-       | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str), s (STRUCTUREleft, strright))])
+       | STRUCTURE CSYMBOL EQ str       ([(DStr (CSYMBOL, NONE, NONE, str, false), s (STRUCTUREleft, strright))])
+       | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str, false), s (STRUCTUREleft, strright))])
        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
                                         ([(DStr (CSYMBOL1, NONE, NONE,
-                                                 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
+                                                 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright)), false),
                                            s (FUNCTORleft, strright))])
        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
                                         ([(DStr (CSYMBOL1, NONE, NONE,
-                                                 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
+                                                 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)), false),
                                            s (FUNCTORleft, strright))])
        | OPEN mpath                     (case mpath of
                                              [] => raise Fail "Impossible mpath parse [1]"
@@ -593,7 +593,7 @@
                                                          foldl (fn (m, str) => (StrProj (str, m), loc))
                                                          (StrVar m, loc) ms
                                          in
-                                             [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc)), loc),
+                                             [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc), false), loc),
                                               (DOpen ("anon", []), loc)]
                                          end)
        | OPEN CONSTRAINTS mpath         (case mpath of