Mercurial > urweb
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