summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2013-09-26 16:22:06 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2013-09-26 16:22:06 -0400
commit71cc64ad35debb1950827e4be6c6a3d5cfc216fc (patch)
treecad67680fb49f89df78b84d6266344d710cb0d62
parented7e4c443e611490ce83c8ee6bedea14c636011c (diff)
Get -root working properly again
Diffstat
-rw-r--r--src/compiler.sml29
-rw-r--r--src/elaborate.sml10
-rw-r--r--src/mod_db.sml2
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml36
-rw-r--r--src/urweb.grm10
6 files changed, 50 insertions, 39 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index ddd71c30..6410c932 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -917,7 +917,10 @@ structure SM = BinaryMapFn(struct
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 parse = {
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 parse = {
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 @@ val parse = {
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 @@ val parse = {
(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 @@ val parse = {
else
();
- makeD "" pieces
+ makeD true "" pieces
before ignore (foldl (fn (new, path) =>
let
val new' = case path of
@@ -1131,10 +1135,17 @@ val parse = {
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 @@ val parse = {
used)
| NONE =>
SM.insert (used, x, #2 d))
- | _ => used) SM.empty ds);
+ | _ => used) used ds);
ds
end handle Empty => ds
end,
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 45aca382..ace7a758 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3679,7 +3679,7 @@ and wildifyStr env (str, sgn) =
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 @@ and wildifyStr env (str, sgn) =
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 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([(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 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
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 =>
diff --git a/src/mod_db.sml b/src/mod_db.sml
index 6c89c114..2d6b285b 100644
--- a/src/mod_db.sml
+++ b/src/mod_db.sml
@@ -126,7 +126,7 @@ fun insert (d, tm) =
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 =>
diff --git a/src/source.sml b/src/source.sml
index d66160db..639ea716 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -154,7 +154,7 @@ datatype decl' =
| 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
diff --git a/src/source_print.sml b/src/source_print.sml
index c8a38922..ce095542 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -571,24 +571,24 @@ fun p_decl ((d, _) : decl) =
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",
diff --git a/src/urweb.grm b/src/urweb.grm
index 29019649..7063af38 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -571,15 +571,15 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
| 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 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-16 15:19:36 +0000