From 71cc64ad35debb1950827e4be6c6a3d5cfc216fc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Sep 2013 16:22:06 -0400 Subject: Get -root working properly again --- src/compiler.sml | 29 ++++++++++++++++++++--------- src/elaborate.sml | 10 +++++----- src/mod_db.sml | 2 +- src/source.sml | 2 +- src/source_print.sml | 36 ++++++++++++++++++------------------ src/urweb.grm | 10 +++++----- 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 -- cgit v1.2.3