Mercurial > urweb

comparison src/compiler.sml @ 1868:d6b0ee53dc93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Get -root working properly again
author Adam Chlipala <adam@chlipala.net>
date Thu, 26 Sep 2013 16:22:06 -0400
parents 3683d1a8c1c8
children c3119c263bd3
comparison
equal deleted inserted replaced
1867:216a3a67ebe3 1868:d6b0ee53dc93
915 type ord_key = string 915 type ord_key = string
916 val compare = String.compare 916 val compare = String.compare
917 end) 917 end)
918 918
919 val moduleRoots = ref ([] : (string * string) list) 919 val moduleRoots = ref ([] : (string * string) list)
920 fun addModuleRoot (k, v) = moduleRoots := (k, v) :: !moduleRoots 920 fun addModuleRoot (k, v) = moduleRoots :=
921 (OS.Path.mkAbsolute {path = k,
922 relativeTo = OS.FileSys.getDir ()},
923 v) :: !moduleRoots
921 924
922 structure SK = struct 925 structure SK = struct
923 type ord_key = string 926 type ord_key = string
924 val compare = String.compare 927 val compare = String.compare
925 end 928 end
996 val urt = OS.FileSys.modTime ur 999 val urt = OS.FileSys.modTime ur
997 val urst = (OS.FileSys.modTime urs) handle _ => urt 1000 val urst = (OS.FileSys.modTime urs) handle _ => urt
998 1001
999 val ds = #func parseUr ur 1002 val ds = #func parseUr ur
1000 val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE, 1003 val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
1001 (Source.StrConst ds, loc)), loc) 1004 (Source.StrConst ds, loc), false), loc)
1002 1005
1003 val fname = OS.Path.mkCanonical fname 1006 val fname = OS.Path.mkCanonical fname
1004 val d = case List.find (fn (root, name) => 1007 val d = case List.find (fn (root, name) =>
1005 String.isPrefix (root ^ "/") fname) mrs of 1008 String.isPrefix (root ^ "/") fname) mrs of
1006 NONE => d 1009 NONE => d
1012 andalso Char.isAlpha (String.sub (s, 0))) 1015 andalso Char.isAlpha (String.sub (s, 0)))
1013 pieces 1016 pieces
1014 val pieces = map capitalize pieces 1017 val pieces = map capitalize pieces
1015 val full = String.concatWith "." pieces 1018 val full = String.concatWith "." pieces
1016 1019
1017 fun makeD prefix pieces = 1020 fun makeD first prefix pieces =
1018 case pieces of 1021 case pieces of
1019 [] => (ErrorMsg.error "Empty module path"; 1022 [] => (ErrorMsg.error "Empty module path";
1020 (Source.DStyle "Boo", loc)) 1023 (Source.DStyle "Boo", loc))
1021 | [_] => d 1024 | [_] => d
1022 | piece :: pieces => 1025 | piece :: pieces =>
1054 loc), 1057 loc),
1055 part), loc) 1058 part), loc)
1056 else 1059 else
1057 (Source.StrVar part, loc) 1060 (Source.StrVar part, loc)
1058 in 1061 in
1059 (Source.DStr (part, NONE, NONE, imp), 1062 (Source.DStr (part, NONE, NONE, imp, false),
1060 loc) :: ds 1063 loc) :: ds
1061 end 1064 end
1062 else 1065 else
1063 ds) [] (!fulls) 1066 ds) [] (!fulls)
1064 in 1067 in
1065 defed := SS.add (!defed, this); 1068 defed := SS.add (!defed, this);
1066 (Source.DStr (piece, NONE, NONE, 1069 (Source.DStr (piece, NONE, NONE,
1067 (Source.StrConst (if old then 1070 (Source.StrConst (if old then
1068 simOpen () 1071 simOpen ()
1069 @ [makeD this pieces] 1072 @ [makeD false this pieces]
1070 else 1073 else
1071 [makeD this pieces]), loc)), 1074 [makeD false this pieces]),
1075 loc), first andalso old),
1072 loc) 1076 loc)
1073 end 1077 end
1074 in 1078 in
1075 if SS.member (!fulls, full) then 1079 if SS.member (!fulls, full) then
1076 ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") 1080 ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
1077 else 1081 else
1078 (); 1082 ();
1079 1083
1080 makeD "" pieces 1084 makeD true "" pieces
1081 before ignore (foldl (fn (new, path) => 1085 before ignore (foldl (fn (new, path) =>
1082 let 1086 let
1083 val new' = case path of 1087 val new' = case path of
1084 "" => new 1088 "" => new
1085 | _ => path ^ "." ^ new 1089 | _ => path ^ "." ^ new
1129 | SOME s => (Source.DDatabase s, loc) :: ds 1133 | SOME s => (Source.DDatabase s, loc) :: ds
1130 1134
1131 val ds = case onError of 1135 val ds = case onError of
1132 NONE => ds 1136 NONE => ds
1133 | SOME v => ds @ [(Source.DOnError v, loc)] 1137 | SOME v => ds @ [(Source.DOnError v, loc)]
1138
1139 fun dummy fname = {file = Settings.libFile fname,
1140 first = ErrorMsg.dummyPos,
1141 last = ErrorMsg.dummyPos}
1142
1143 val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
1144 val used = SM.insert (used, "Top", dummy "top.urs")
1134 in 1145 in
1135 ignore (List.foldl (fn (d, used) => 1146 ignore (List.foldl (fn (d, used) =>
1136 case #1 d of 1147 case #1 d of
1137 Source.DStr (x, _, _, _) => 1148 Source.DStr (x, _, _, _, false) =>
1138 (case SM.find (used, x) of 1149 (case SM.find (used, x) of
1139 SOME loc => 1150 SOME loc =>
1140 (ErrorMsg.error ("Duplicate top-level module name " ^ x); 1151 (ErrorMsg.error ("Duplicate top-level module name " ^ x);
1141 Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)), 1152 Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)),
1142 ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))]; 1153 ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))];
1143 used) 1154 used)
1144 | NONE => 1155 | NONE =>
1145 SM.insert (used, x, #2 d)) 1156 SM.insert (used, x, #2 d))
1146 | _ => used) SM.empty ds); 1157 | _ => used) used ds);
1147 ds 1158 ds
1148 end handle Empty => ds 1159 end handle Empty => ds
1149 end, 1160 end,
1150 print = SourcePrint.p_file 1161 print = SourcePrint.p_file
1151 } 1162 }