Mercurial > urweb

annotate src/compiler.sml @ 1634:f4cb4eebf7ae

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some new List functions, based on code by Ron de Bruijn
author Adam Chlipala <adam@chlipala.net>
date Sun, 11 Dec 2011 15:02:55 -0500
parents 438561303d02
children e374b6b8ab38
rev   line source
adam@1603 1 (* Copyright (c) 2008-2011, Adam Chlipala
adamc@1 2 * All rights reserved.
adamc@1 3 *
adamc@1 4 * Redistribution and use in source and binary forms, with or without
adamc@1 5 * modification, are permitted provided that the following conditions are met:
adamc@1 6 *
adamc@1 7 * - Redistributions of source code must retain the above copyright notice,
adamc@1 8 * this list of conditions and the following disclaimer.
adamc@1 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1 10 * this list of conditions and the following disclaimer in the documentation
adamc@1 11 * and/or other materials provided with the distribution.
adamc@1 12 * - The names of contributors may not be used to endorse or promote products
adamc@1 13 * derived from this software without specific prior written permission.
adamc@1 14 *
adamc@1 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@1 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@1 26 *)
adamc@1 27
adamc@1 28 structure Compiler :> COMPILER = struct
adamc@1 29
adamc@244 30 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
adamc@244 31 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
adamc@244 32 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
adamc@1 33 structure Lex = Lex
adamc@1 34 structure LrParser = LrParser)
adamc@1 35
adamc@270 36 type job = {
adamc@385 37 prefix : string,
adamc@270 38 database : string option,
adamc@274 39 sources : string list,
adamc@274 40 exe : string,
adamc@274 41 sql : string option,
adamc@502 42 debug : bool,
adamc@673 43 profile : bool,
adamc@764 44 timeout : int,
adamc@764 45 ffi : string list,
adamc@764 46 link : string list,
adamc@765 47 headers : string list,
adamc@766 48 scripts : string list,
adamc@765 49 clientToServer : Settings.ffi list,
adamc@765 50 effectful : Settings.ffi list,
adamc@1171 51 benignEffectful : Settings.ffi list,
adamc@765 52 clientOnly : Settings.ffi list,
adamc@765 53 serverOnly : Settings.ffi list,
adamc@768 54 jsFuncs : (Settings.ffi * string) list,
adamc@769 55 rewrites : Settings.rewrite list,
adamc@769 56 filterUrl : Settings.rule list,
adamc@866 57 filterMime : Settings.rule list,
adam@1465 58 filterRequest : Settings.rule list,
adam@1465 59 filterResponse : Settings.rule list,
adamc@866 60 protocol : string option,
adamc@1164 61 dbms : string option,
adamc@1183 62 sigFile : string option,
adam@1294 63 safeGets : string list,
adam@1332 64 onError : (string * string list * string) option,
adam@1332 65 minHeap : int
adamc@270 66 }
adamc@201 67
adamc@201 68 type ('src, 'dst) phase = {
adamc@201 69 func : 'src -> 'dst,
adamc@201 70 print : 'dst -> Print.PD.pp_desc
adamc@201 71 }
adamc@201 72
adamc@201 73 type pmap = (string * Time.time) list
adamc@201 74
adamc@201 75 type ('src, 'dst) transform = {
adamc@201 76 func : 'src -> 'dst option,
adamc@201 77 print : 'dst -> Print.PD.pp_desc,
adamc@201 78 time : 'src * pmap -> 'dst option * pmap
adamc@201 79 }
adamc@201 80
adamc@1079 81 val debug = ref false
adamc@1240 82 val doIflow = ref false
adamc@1079 83
adamc@201 84 fun transform (ph : ('src, 'dst) phase) name = {
adamc@201 85 func = fn input => let
adamc@1079 86 val () = if !debug then
adamc@1079 87 print ("Starting " ^ name ^ "....\n")
adamc@1079 88 else
adamc@1079 89 ()
adamc@201 90 val v = #func ph input
adamc@201 91 in
adamc@1079 92 if !debug then
adamc@1079 93 print ("Finished " ^ name ^ ".\n")
adamc@1079 94 else
adamc@1079 95 ();
adamc@201 96 if ErrorMsg.anyErrors () then
adamc@201 97 NONE
adamc@201 98 else
adamc@201 99 SOME v
adamc@201 100 end,
adamc@201 101 print = #print ph,
adamc@201 102 time = fn (input, pmap) => let
adamc@1186 103 val () = if !debug then
adamc@1186 104 print ("Starting " ^ name ^ "....\n")
adamc@1186 105 else
adamc@1186 106 ()
adamc@201 107 val befor = Time.now ()
adamc@201 108 val v = #func ph input
adamc@201 109 val elapsed = Time.- (Time.now (), befor)
adamc@201 110 in
adamc@1186 111 if !debug then
adamc@1186 112 print ("Finished " ^ name ^ ".\n")
adamc@1186 113 else
adamc@1186 114 ();
adamc@201 115 (if ErrorMsg.anyErrors () then
adamc@201 116 NONE
adamc@201 117 else
adamc@201 118 SOME v,
adamc@201 119 (name, elapsed) :: pmap)
adamc@201 120 end
adamc@201 121 }
adamc@201 122
adamc@346 123 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@346 124 ignore (#func tr x))
adamc@346 125
adamc@280 126 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
adamc@280 127 #func tr x)
adamc@201 128
adamc@201 129 fun runPrint (tr : ('src, 'dst) transform) input =
adamc@280 130 (ErrorMsg.resetErrors ();
adamc@280 131 case #func tr input of
adamc@280 132 NONE => print "Failure\n"
adamc@280 133 | SOME v =>
adamc@280 134 (print "Success\n";
adamc@280 135 Print.print (#print tr v);
adamc@280 136 print "\n"))
adamc@201 137
adam@1362 138 fun runPrintToFile (tr : ('src, 'dst) transform) input fname =
adam@1362 139 (ErrorMsg.resetErrors ();
adam@1362 140 case #func tr input of
adam@1362 141 NONE => print "Failure\n"
adam@1362 142 | SOME v =>
adam@1362 143 let
adam@1362 144 val outf = TextIO.openOut fname
adam@1362 145 val str = Print.openOut {dst = outf, wid = 80}
adam@1362 146 in
adam@1362 147 print "Success\n";
adam@1362 148 Print.fprint str (#print tr v);
adam@1362 149 Print.PD.PPS.closeStream str;
adam@1362 150 TextIO.closeOut outf
adam@1362 151 end)
adam@1362 152
adamc@201 153 fun time (tr : ('src, 'dst) transform) input =
adamc@55 154 let
adamc@201 155 val (_, pmap) = #time tr (input, [])
adamc@201 156 in
adamc@201 157 app (fn (name, time) =>
adamc@201 158 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 159 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 160 print "\n"
adamc@201 161 end
adamc@55 162
adamc@201 163 fun timePrint (tr : ('src, 'dst) transform) input =
adamc@201 164 let
adamc@201 165 val (ro, pmap) = #time tr (input, [])
adamc@55 166 in
adamc@201 167 app (fn (name, time) =>
adamc@201 168 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
adamc@201 169 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
adamc@201 170 print "\n";
adamc@201 171 case ro of
adamc@201 172 NONE => print "Failure\n"
adamc@201 173 | SOME v =>
adamc@201 174 (print "Success\n";
adamc@201 175 Print.print (#print tr v);
adamc@201 176 print "\n")
adamc@55 177 end
adamc@55 178
adam@1362 179 fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input =
adam@1362 180 (ErrorMsg.resetErrors ();
adam@1362 181 case #func tr input of
adam@1362 182 NONE => print "Failure\n"
adam@1362 183 | SOME file =>
adam@1362 184 (print "Success\n";
adam@1362 185 app (fn (d, _) =>
adam@1362 186 case d of
adam@1362 187 Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)
adam@1362 188 | Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts
adam@1362 189 | _ => ()) file))
adam@1362 190
adamc@244 191 val parseUrs =
adamc@201 192 {func = fn filename => let
adamc@201 193 val fname = OS.FileSys.tmpName ()
adamc@201 194 val outf = TextIO.openOut fname
adamc@201 195 val () = TextIO.output (outf, "sig\n")
adamc@201 196 val inf = TextIO.openIn filename
adamc@201 197 fun loop () =
adamc@201 198 case TextIO.inputLine inf of
adamc@201 199 NONE => ()
adamc@201 200 | SOME line => (TextIO.output (outf, line);
adamc@201 201 loop ())
adamc@201 202 val () = loop ()
adamc@201 203 val () = TextIO.closeIn inf
adamc@201 204 val () = TextIO.closeOut outf
adamc@201 205
adamc@201 206 val () = (ErrorMsg.resetErrors ();
adamc@201 207 ErrorMsg.resetPositioning filename;
adamc@201 208 Lex.UserDeclarations.initialize ())
adamc@201 209 val file = TextIO.openIn fname
adamc@201 210 fun get _ = TextIO.input file
adamc@201 211 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 212 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 213 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 214 in
adamc@201 215 TextIO.closeIn file;
adamc@201 216 case absyn of
adamc@201 217 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
adamc@201 218 | _ => (ErrorMsg.errorAt {file = filename,
adamc@201 219 first = {line = 0,
adamc@201 220 char = 0},
adamc@201 221 last = {line = 0,
adamc@201 222 char = 0}} "Not a signature";
adamc@201 223 [])
adamc@201 224 end
adamc@201 225 handle LrParser.ParseError => [],
adamc@201 226 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
adamc@55 227
adamc@1 228 (* The main parsing routine *)
adamc@244 229 val parseUr = {
adamc@201 230 func = fn filename =>
adamc@201 231 let
adamc@201 232 val () = (ErrorMsg.resetErrors ();
adamc@201 233 ErrorMsg.resetPositioning filename;
adamc@201 234 Lex.UserDeclarations.initialize ())
adamc@201 235 val file = TextIO.openIn filename
adamc@201 236 fun get _ = TextIO.input file
adamc@201 237 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@201 238 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@244 239 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
adamc@201 240 in
adamc@201 241 TextIO.closeIn file;
adamc@201 242 case absyn of
adamc@201 243 [(Source.DSgn ("?", _), _)] =>
adamc@201 244 (ErrorMsg.errorAt {file = filename,
adamc@201 245 first = {line = 0,
adamc@201 246 char = 0},
adamc@201 247 last = {line = 0,
adamc@201 248 char = 0}} "File starts with 'sig'";
adamc@201 249 [])
adamc@201 250 | _ => absyn
adamc@201 251 end
adamc@201 252 handle LrParser.ParseError => [],
adamc@201 253 print = SourcePrint.p_file}
adamc@56 254
adamc@768 255 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
adamc@768 256 timeout, ffi, link, headers, scripts,
adamc@1171 257 clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
adamc@270 258 let
adamc@270 259 open Print.PD
adamc@270 260 open Print
adamc@765 261
adamc@765 262 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
adamc@765 263 box [string name, space, string m, string ".", string s, newline])
adamc@270 264 in
adamc@274 265 box [if debug then
adamc@274 266 box [string "DEBUG", newline]
adamc@274 267 else
adamc@274 268 box [],
adamc@502 269 if profile then
adamc@502 270 box [string "PROFILE", newline]
adamc@502 271 else
adamc@502 272 box [],
adamc@274 273 case database of
adamc@270 274 NONE => string "No database."
adamc@270 275 | SOME db => string ("Database: " ^ db),
adamc@270 276 newline,
adamc@274 277 string "Exe: ",
adamc@274 278 string exe,
adamc@274 279 newline,
adamc@274 280 case sql of
adamc@274 281 NONE => string "No SQL file."
adamc@274 282 | SOME sql => string ("SQL fle: " ^ sql),
adamc@673 283 newline,
adamc@673 284 string "Timeout: ",
adamc@673 285 string (Int.toString timeout),
adamc@673 286 newline,
adamc@764 287 p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
adamc@764 288 p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
adamc@766 289 p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
adamc@764 290 p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
adamc@765 291 p_ffi "ClientToServer" clientToServer,
adamc@765 292 p_ffi "Effectful" effectful,
adamc@1171 293 p_ffi "BenignEffectful" benignEffectful,
adamc@765 294 p_ffi "ClientOnly" clientOnly,
adamc@765 295 p_ffi "ServerOnly" serverOnly,
adamc@765 296 p_list_sep (box []) (fn ((m, s), s') =>
adamc@765 297 box [string "JsFunc", space, string m, string ".", string s,
adamc@765 298 space, string "=", space, string s', newline]) jsFuncs,
adamc@270 299 string "Sources:",
adamc@270 300 p_list string sources,
adamc@270 301 newline]
adamc@270 302 end
adamc@270 303
adamc@270 304 fun trim s =
adamc@270 305 let
adamc@270 306 val (_, s) = Substring.splitl Char.isSpace s
adamc@270 307 val (s, _) = Substring.splitr Char.isSpace s
adamc@270 308 in
adamc@270 309 s
adamc@270 310 end
adamc@270 311
adam@1433 312 val trimS = Substring.string o trim o Substring.full
adam@1433 313
adamc@794 314 structure M = BinaryMapFn(struct
adamc@794 315 type ord_key = string
adamc@794 316 val compare = String.compare
adamc@794 317 end)
adamc@794 318
adamc@1089 319 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
adamc@1089 320
adamc@1089 321 fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v)
adamc@1089 322
adam@1296 323 fun capitalize "" = ""
adam@1296 324 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adam@1296 325
adam@1296 326 fun institutionalizeJob (job : job) =
adam@1483 327 (Settings.setDebug (#debug job);
adam@1483 328 Settings.setUrlPrefix (#prefix job);
adam@1296 329 Settings.setTimeout (#timeout job);
adam@1296 330 Settings.setHeaders (#headers job);
adam@1296 331 Settings.setScripts (#scripts job);
adam@1296 332 Settings.setClientToServer (#clientToServer job);
adam@1296 333 Settings.setEffectful (#effectful job);
adam@1296 334 Settings.setBenignEffectful (#benignEffectful job);
adam@1296 335 Settings.setClientOnly (#clientOnly job);
adam@1296 336 Settings.setServerOnly (#serverOnly job);
adam@1296 337 Settings.setJsFuncs (#jsFuncs job);
adam@1296 338 Settings.setRewriteRules (#rewrites job);
adam@1296 339 Settings.setUrlRules (#filterUrl job);
adam@1296 340 Settings.setMimeRules (#filterMime job);
adam@1465 341 Settings.setRequestHeaderRules (#filterRequest job);
adam@1465 342 Settings.setResponseHeaderRules (#filterResponse job);
adam@1296 343 Option.app Settings.setProtocol (#protocol job);
adam@1296 344 Option.app Settings.setDbms (#dbms job);
adam@1296 345 Settings.setSafeGets (#safeGets job);
adam@1332 346 Settings.setOnError (#onError job);
adam@1408 347 Settings.setMinHeap (#minHeap job);
adam@1408 348 Settings.setSigFile (#sigFile job))
adam@1296 349
adam@1603 350 datatype commentableLine =
adam@1603 351 EndOfFile
adam@1603 352 | OnlyComment
adam@1603 353 | Content of string
adam@1603 354
adam@1331 355 fun inputCommentableLine inf =
adam@1603 356 case TextIO.inputLine inf of
adam@1603 357 NONE => EndOfFile
adam@1603 358 | SOME s =>
adam@1603 359 let
adam@1603 360 val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s)
adam@1603 361 in
adam@1603 362 if not (Substring.isEmpty after)
adam@1603 363 andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then
adam@1603 364 OnlyComment
adam@1603 365 else
adam@1603 366 let
adam@1603 367 val s = #1 (Substring.splitr (not o Char.isSpace) befor)
adam@1603 368 in
adam@1603 369 Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then
adam@1603 370 if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then
adam@1603 371 Substring.trimr 2 s
adam@1603 372 else
adam@1603 373 Substring.trimr 1 s
adam@1603 374 else
adam@1603 375 s))
adam@1603 376 end
adam@1603 377 end
adam@1331 378
adamc@1082 379 fun parseUrp' accLibs fname =
adam@1296 380 if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
adam@1296 381 andalso Posix.FileSys.access (fname ^ ".ur", []) then
adam@1296 382 let
adam@1296 383 val job = {prefix = "/",
adam@1296 384 database = NONE,
adam@1296 385 sources = [fname],
adam@1296 386 exe = fname ^ ".exe",
adam@1296 387 sql = NONE,
adam@1396 388 debug = Settings.getDebug (),
adam@1296 389 profile = false,
adam@1296 390 timeout = 60,
adam@1296 391 ffi = [],
adam@1296 392 link = [],
adam@1296 393 headers = [],
adam@1296 394 scripts = [],
adam@1296 395 clientToServer = [],
adam@1296 396 effectful = [],
adam@1296 397 benignEffectful = [],
adam@1296 398 clientOnly = [],
adam@1296 399 serverOnly = [],
adam@1296 400 jsFuncs = [],
adam@1296 401 rewrites = [{pkind = Settings.Any,
adam@1296 402 kind = Settings.Prefix,
adam@1296 403 from = capitalize (OS.Path.file fname) ^ "/", to = ""}],
adam@1296 404 filterUrl = [],
adam@1296 405 filterMime = [],
adam@1465 406 filterRequest = [],
adam@1465 407 filterResponse = [],
adam@1296 408 protocol = NONE,
adam@1296 409 dbms = NONE,
adam@1296 410 sigFile = NONE,
adam@1296 411 safeGets = [],
adam@1332 412 onError = NONE,
adam@1332 413 minHeap = 0}
adam@1296 414 in
adam@1296 415 institutionalizeJob job;
adam@1296 416 {Job = job, Libs = []}
adam@1296 417 end
adam@1296 418 else
adam@1296 419 let
adam@1296 420 val pathmap = ref (!pathmap)
adam@1296 421 val bigLibs = ref []
adamc@767 422
adam@1296 423 fun pu filename =
adam@1296 424 let
adam@1338 425 val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
adam@1338 426
adam@1296 427 val dir = OS.Path.dir filename
adam@1296 428 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
adamc@1151 429
adam@1296 430 val inf = opener ()
adamc@1151 431
adam@1296 432 fun hasSpaceLine () =
adam@1331 433 case inputCommentableLine inf of
adam@1603 434 Content s => s = "debug" orelse s = "profile"
adam@1603 435 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
adam@1605 436 | EndOfFile => false
adam@1605 437 | OnlyComment => hasSpaceLine ()
adamc@1151 438
adam@1296 439 val hasBlankLine = hasSpaceLine ()
adamc@1151 440
adam@1296 441 val inf = (TextIO.closeIn inf; opener ())
adamc@767 442
adam@1296 443 fun pathify fname =
adam@1296 444 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
adam@1296 445 let
adam@1296 446 val fname' = Substring.extract (fname, 1, NONE)
adam@1296 447 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
adam@1296 448 in
adam@1340 449 case M.find (!pathmap, Substring.string befor) of
adam@1340 450 NONE => fname
adam@1340 451 | SOME rep => rep ^ Substring.string after
adam@1296 452 end
adam@1296 453 else
adam@1296 454 fname
adam@1296 455
adam@1296 456 fun relify fname =
adamc@794 457 let
adam@1296 458 val fname = pathify fname
adamc@794 459 in
adam@1296 460 OS.Path.concat (dir, fname)
adam@1296 461 handle OS.Path.Path => fname
adamc@794 462 end
adamc@767 463
adam@1296 464 fun libify path =
adam@1296 465 (if Posix.FileSys.access (path ^ ".urp", []) then
adam@1296 466 path
adam@1296 467 else
adam@1296 468 path ^ "/lib")
adam@1296 469 handle SysErr => path
adamc@767 470
adam@1296 471 fun libify' path =
adam@1296 472 (if Posix.FileSys.access (relify path ^ ".urp", []) then
adam@1296 473 path
adam@1296 474 else
adam@1296 475 path ^ "/lib")
adam@1296 476 handle SysErr => path
adamc@767 477
adam@1296 478 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
adamc@794 479
adam@1296 480 fun relifyA fname =
adam@1296 481 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
adamc@794 482
adam@1296 483 fun readSources acc =
adam@1331 484 case inputCommentableLine inf of
adam@1603 485 Content line =>
adam@1296 486 let
adam@1296 487 val acc = if CharVector.all Char.isSpace line then
adam@1296 488 acc
adam@1296 489 else
adam@1296 490 let
adam@1296 491 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
adam@1296 492 (String.explode line))
adam@1296 493 val fname = relifyA fname
adam@1296 494 in
adam@1296 495 fname :: acc
adam@1296 496 end
adam@1296 497 in
adam@1296 498 readSources acc
adam@1296 499 end
adam@1606 500 | OnlyComment => readSources acc
adam@1606 501 | EndOfFile => rev acc
adamc@794 502
adam@1335 503 val prefix = ref (case Settings.getUrlPrefix () of "/" => NONE | s => SOME s)
adam@1296 504 val database = ref (Settings.getDbstring ())
adam@1296 505 val exe = ref (Settings.getExe ())
adam@1296 506 val sql = ref (Settings.getSql ())
adam@1296 507 val debug = ref (Settings.getDebug ())
adam@1296 508 val profile = ref false
adam@1296 509 val timeout = ref NONE
adam@1296 510 val ffi = ref []
adam@1296 511 val link = ref []
adam@1296 512 val headers = ref []
adam@1296 513 val scripts = ref []
adam@1296 514 val clientToServer = ref []
adam@1296 515 val effectful = ref []
adam@1296 516 val benignEffectful = ref []
adam@1296 517 val clientOnly = ref []
adam@1296 518 val serverOnly = ref []
adam@1296 519 val jsFuncs = ref []
adam@1296 520 val rewrites = ref []
adam@1296 521 val url = ref []
adam@1296 522 val mime = ref []
adam@1465 523 val request = ref []
adam@1465 524 val response = ref []
adam@1296 525 val libs = ref []
adam@1296 526 val protocol = ref NONE
adam@1296 527 val dbms = ref NONE
adam@1296 528 val sigFile = ref (Settings.getSigFile ())
adam@1296 529 val safeGets = ref []
adam@1296 530 val onError = ref NONE
adam@1332 531 val minHeap = ref 0
adamc@794 532
adam@1296 533 fun finish sources =
adam@1296 534 let
adam@1296 535 val job = {
adam@1296 536 prefix = Option.getOpt (!prefix, "/"),
adam@1296 537 database = !database,
adam@1296 538 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
adam@1296 539 ext = SOME "exe"}),
adam@1296 540 sql = !sql,
adam@1296 541 debug = !debug,
adam@1296 542 profile = !profile,
adam@1296 543 timeout = Option.getOpt (!timeout, 60),
adam@1296 544 ffi = rev (!ffi),
adam@1296 545 link = rev (!link),
adam@1296 546 headers = rev (!headers),
adam@1296 547 scripts = rev (!scripts),
adam@1296 548 clientToServer = rev (!clientToServer),
adam@1296 549 effectful = rev (!effectful),
adam@1296 550 benignEffectful = rev (!benignEffectful),
adam@1296 551 clientOnly = rev (!clientOnly),
adam@1296 552 serverOnly = rev (!serverOnly),
adam@1296 553 jsFuncs = rev (!jsFuncs),
adam@1296 554 rewrites = rev (!rewrites),
adam@1296 555 filterUrl = rev (!url),
adam@1296 556 filterMime = rev (!mime),
adam@1465 557 filterRequest = rev (!request),
adam@1465 558 filterResponse = rev (!response),
adam@1296 559 sources = sources,
adam@1296 560 protocol = !protocol,
adam@1296 561 dbms = !dbms,
adam@1296 562 sigFile = !sigFile,
adam@1296 563 safeGets = rev (!safeGets),
adam@1332 564 onError = !onError,
adam@1332 565 minHeap = !minHeap
adam@1296 566 }
adamc@794 567
adam@1296 568 fun mergeO f (old, new) =
adam@1296 569 case (old, new) of
adam@1296 570 (NONE, _) => new
adam@1296 571 | (_, NONE) => old
adam@1296 572 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adamc@794 573
adam@1296 574 fun same desc = mergeO (fn (x : string, y) =>
adam@1296 575 (if x = y then
adam@1296 576 ()
adam@1296 577 else
adam@1296 578 ErrorMsg.error ("Multiple "
adam@1296 579 ^ desc ^ " values that don't agree");
adam@1296 580 x))
adamc@794 581
adam@1296 582 fun merge (old : job, new : job) = {
adam@1296 583 prefix = #prefix old,
adam@1296 584 database = mergeO (fn (old, _) => old) (#database old, #database new),
adam@1296 585 exe = #exe old,
adam@1296 586 sql = #sql old,
adam@1296 587 debug = #debug old orelse #debug new,
adam@1296 588 profile = #profile old orelse #profile new,
adam@1296 589 timeout = #timeout old,
adam@1296 590 ffi = #ffi old @ #ffi new,
adam@1296 591 link = #link old @ #link new,
adam@1296 592 headers = #headers old @ #headers new,
adam@1296 593 scripts = #scripts old @ #scripts new,
adam@1296 594 clientToServer = #clientToServer old @ #clientToServer new,
adam@1296 595 effectful = #effectful old @ #effectful new,
adam@1296 596 benignEffectful = #benignEffectful old @ #benignEffectful new,
adam@1296 597 clientOnly = #clientOnly old @ #clientOnly new,
adam@1296 598 serverOnly = #serverOnly old @ #serverOnly new,
adam@1296 599 jsFuncs = #jsFuncs old @ #jsFuncs new,
adam@1296 600 rewrites = #rewrites old @ #rewrites new,
adam@1296 601 filterUrl = #filterUrl old @ #filterUrl new,
adam@1296 602 filterMime = #filterMime old @ #filterMime new,
adam@1465 603 filterRequest = #filterRequest old @ #filterRequest new,
adam@1465 604 filterResponse = #filterResponse old @ #filterResponse new,
adam@1296 605 sources = #sources new
adam@1296 606 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
adam@1296 607 (#sources old),
adam@1296 608 protocol = mergeO #2 (#protocol old, #protocol new),
adam@1296 609 dbms = mergeO #2 (#dbms old, #dbms new),
adam@1296 610 sigFile = mergeO #2 (#sigFile old, #sigFile new),
adam@1296 611 safeGets = #safeGets old @ #safeGets new,
adam@1332 612 onError = mergeO #2 (#onError old, #onError new),
adam@1332 613 minHeap = Int.max (#minHeap old, #minHeap new)
adam@1296 614 }
adamc@794 615 in
adam@1296 616 if accLibs then
adam@1296 617 foldr (fn (job', job) => merge (job, job')) job (!libs)
adam@1296 618 else
adam@1296 619 job
adamc@794 620 end
adamc@794 621
adam@1296 622 fun parsePkind s =
adam@1296 623 case s of
adam@1296 624 "all" => Settings.Any
adam@1296 625 | "url" => Settings.Url
adam@1296 626 | "table" => Settings.Table
adam@1296 627 | "sequence" => Settings.Sequence
adam@1296 628 | "view" => Settings.View
adam@1296 629 | "relation" => Settings.Relation
adam@1296 630 | "cookie" => Settings.Cookie
adam@1296 631 | "style" => Settings.Style
adam@1296 632 | _ => (ErrorMsg.error "Bad path kind spec";
adam@1296 633 Settings.Any)
adam@1296 634
adam@1296 635 fun parseFrom s =
adam@1296 636 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
adam@1296 637 (Settings.Prefix, String.substring (s, 0, size s - 1))
adam@1296 638 else
adam@1296 639 (Settings.Exact, s)
adam@1296 640
adam@1296 641 fun parseFkind s =
adam@1296 642 case s of
adam@1296 643 "url" => url
adam@1296 644 | "mime" => mime
adam@1465 645 | "requestHeader" => request
adam@1465 646 | "responseHeader" => response
adam@1296 647 | _ => (ErrorMsg.error "Bad filter kind";
adam@1296 648 url)
adam@1296 649
adam@1296 650 fun parsePattern s =
adam@1296 651 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
adam@1296 652 (Settings.Prefix, String.substring (s, 0, size s - 1))
adam@1296 653 else
adam@1296 654 (Settings.Exact, s)
adam@1296 655
adam@1296 656 fun read () =
adam@1331 657 case inputCommentableLine inf of
adam@1603 658 EndOfFile => finish []
adam@1603 659 | OnlyComment => read ()
adam@1603 660 | Content "" => finish (readSources [])
adam@1603 661 | Content line =>
adam@1296 662 let
adam@1296 663 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
adam@1296 664 val cmd = Substring.string (trim cmd)
adam@1296 665 val arg = Substring.string (trim arg)
adam@1296 666
adam@1296 667 fun ffiS () =
adam@1296 668 case String.fields (fn ch => ch = #".") arg of
adam@1296 669 [m, x] => (m, x)
adam@1296 670 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
adam@1296 671 ("", ""))
adam@1296 672
adam@1296 673 fun ffiM () =
adam@1296 674 case String.fields (fn ch => ch = #"=") arg of
adam@1296 675 [f, s] =>
adam@1433 676 let
adam@1433 677 val f = trimS f
adam@1433 678 val s = trimS s
adam@1433 679 in
adam@1433 680 case String.fields (fn ch => ch = #".") f of
adam@1433 681 [m, x] => ((m, x), s)
adam@1433 682 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adam@1433 683 (("", ""), ""))
adam@1433 684 end
adam@1296 685 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adam@1296 686 (("", ""), ""))
adam@1296 687 in
adam@1296 688 case cmd of
adam@1336 689 "prefix" => prefix := SOME arg
adam@1296 690 | "database" =>
adam@1296 691 (case !database of
adam@1296 692 NONE => database := SOME arg
adam@1296 693 | SOME _ => ())
adam@1296 694 | "dbms" =>
adam@1296 695 (case !dbms of
adam@1296 696 NONE => dbms := SOME arg
adam@1296 697 | SOME _ => ())
adam@1296 698 | "sigfile" =>
adam@1296 699 (case !sigFile of
adam@1296 700 NONE => sigFile := SOME arg
adam@1296 701 | SOME _ => ())
adam@1296 702 | "exe" =>
adam@1296 703 (case !exe of
adam@1296 704 NONE => exe := SOME (relify arg)
adam@1296 705 | SOME _ => ())
adam@1296 706 | "sql" =>
adam@1296 707 (case !sql of
adam@1296 708 NONE => sql := SOME (relify arg)
adam@1296 709 | SOME _ => ())
adam@1296 710 | "debug" => debug := true
adam@1296 711 | "profile" => profile := true
adam@1296 712 | "timeout" =>
adam@1296 713 (case !timeout of
adam@1296 714 NONE => ()
adam@1296 715 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
adam@1296 716 timeout := SOME (valOf (Int.fromString arg)))
adam@1296 717 | "ffi" => ffi := relify arg :: !ffi
adam@1296 718 | "link" => let
adam@1296 719 val arg = if size arg >= 1
adam@1296 720 andalso String.sub (arg, 0) = #"-" then
adam@1296 721 arg
adam@1296 722 else
adam@1296 723 relifyA arg
adam@1296 724 in
adam@1296 725 link := arg :: !link
adam@1296 726 end
adam@1296 727 | "include" => headers := relifyA arg :: !headers
adam@1296 728 | "script" => scripts := arg :: !scripts
adam@1296 729 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
adam@1296 730 | "safeGet" => safeGets := arg :: !safeGets
adam@1296 731 | "effectful" => effectful := ffiS () :: !effectful
adam@1296 732 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
adam@1296 733 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
adam@1296 734 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
adam@1296 735 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
adam@1296 736 | "rewrite" =>
adam@1296 737 let
adam@1296 738 fun doit (pkind, from, to) =
adam@1296 739 let
adam@1296 740 val pkind = parsePkind pkind
adam@1296 741 val (kind, from) = parseFrom from
adam@1296 742 in
adam@1296 743 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
adam@1296 744 end
adam@1296 745 in
adam@1296 746 case String.tokens Char.isSpace arg of
adam@1296 747 [pkind, from, to] => doit (pkind, from, to)
adam@1296 748 | [pkind, from] => doit (pkind, from, "")
adam@1296 749 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
adam@1296 750 end
adam@1296 751 | "allow" =>
adam@1296 752 (case String.tokens Char.isSpace arg of
adam@1296 753 [fkind, pattern] =>
adam@1296 754 let
adam@1296 755 val fkind = parseFkind fkind
adam@1296 756 val (kind, pattern) = parsePattern pattern
adam@1296 757 in
adam@1296 758 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
adam@1296 759 end
adam@1296 760 | _ => ErrorMsg.error "Bad 'allow' syntax")
adam@1296 761 | "deny" =>
adam@1296 762 (case String.tokens Char.isSpace arg of
adam@1296 763 [fkind, pattern] =>
adam@1296 764 let
adam@1296 765 val fkind = parseFkind fkind
adam@1296 766 val (kind, pattern) = parsePattern pattern
adam@1296 767 in
adam@1296 768 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
adam@1296 769 end
adam@1296 770 | _ => ErrorMsg.error "Bad 'deny' syntax")
adam@1296 771 | "library" => if accLibs then
adam@1296 772 libs := pu (libify (relify arg)) :: !libs
adam@1296 773 else
adam@1296 774 bigLibs := libify' arg :: !bigLibs
adam@1296 775 | "path" =>
adam@1296 776 (case String.fields (fn ch => ch = #"=") arg of
adam@1338 777 [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
adam@1338 778 handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
adam@1296 779 | _ => ErrorMsg.error "path argument not of the form name=value'")
adam@1296 780 | "onError" =>
adam@1296 781 (case String.fields (fn ch => ch = #".") arg of
adam@1296 782 m1 :: (fs as _ :: _) =>
adam@1296 783 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
adam@1296 784 | _ => ErrorMsg.error "invalid 'onError' argument")
adam@1307 785 | "limit" =>
adam@1307 786 (case String.fields Char.isSpace arg of
adam@1307 787 [class, num] =>
adam@1307 788 (case Int.fromString num of
adam@1307 789 NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
adam@1307 790 | SOME n =>
adam@1307 791 if n < 0 then
adam@1307 792 ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
adam@1307 793 else
adam@1307 794 Settings.addLimit (class, n))
adam@1307 795 | _ => ErrorMsg.error "invalid 'limit' arguments")
adam@1332 796 | "minHeap" =>
adam@1332 797 (case Int.fromString arg of
adam@1332 798 NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
adam@1332 799 | SOME n => minHeap := n)
adam@1393 800 | "alwaysInline" => Settings.addAlwaysInline arg
adam@1478 801 | "noXsrfProtection" => Settings.addNoXsrfProtection arg
adam@1629 802 | "timeFormat" => Settings.setTimeFormat arg
adam@1296 803
adam@1296 804 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
adam@1296 805 read ()
adam@1296 806 end
adam@1296 807
adam@1296 808 val job = if hasBlankLine then
adam@1296 809 read ()
adam@1296 810 else
adam@1296 811 finish (readSources [])
adam@1296 812 in
adam@1296 813 TextIO.closeIn inf;
adam@1296 814 institutionalizeJob job;
adam@1296 815 job
adam@1296 816 end
adam@1296 817 in
adam@1296 818 {Job = pu fname, Libs = !bigLibs}
adam@1296 819 end
adamc@767 820
adamc@1082 821 fun p_job' {Job = j, Libs = _ : string list} = p_job j
adamc@1082 822
adamc@270 823 val parseUrp = {
adamc@1083 824 func = #Job o parseUrp' true,
adamc@270 825 print = p_job
adamc@270 826 }
adamc@270 827
adamc@1082 828 val parseUrp' = {
adamc@1083 829 func = parseUrp' false,
adamc@1082 830 print = p_job'
adamc@1082 831 }
adamc@1082 832
adamc@270 833 val toParseJob = transform parseUrp "parseJob"
adamc@1082 834 val toParseJob' = transform parseUrp' "parseJob'"
adamc@1082 835
adamc@1082 836 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
adamc@1082 837 func = fn input => case #func tr1 input of
adamc@1082 838 NONE => NONE
adamc@1082 839 | SOME v => #func tr2 v,
adamc@1082 840 print = #print tr2,
adamc@1082 841 time = fn (input, pmap) => let
adamc@1082 842 val (ro, pmap) = #time tr1 (input, pmap)
adamc@1082 843 in
adamc@1082 844 case ro of
adamc@1082 845 NONE => (NONE, pmap)
adamc@1082 846 | SOME v => #time tr2 (v, pmap)
adamc@1082 847 end
adamc@1082 848 }
adamc@270 849
adamc@1090 850 structure SM = BinaryMapFn(struct
adamc@1090 851 type ord_key = string
adamc@1090 852 val compare = String.compare
adamc@1090 853 end)
adamc@1090 854
adamc@1090 855 val moduleRoots = ref ([] : (string * string) list)
adamc@1090 856 fun addModuleRoot (k, v) = moduleRoots := (k, v) :: !moduleRoots
adamc@1090 857
adamc@1090 858 structure SS = BinarySetFn(struct
adamc@1090 859 type ord_key = string
adamc@1090 860 val compare = String.compare
adamc@1090 861 end)
adamc@1090 862
adamc@201 863 val parse = {
adam@1294 864 func = fn {database, sources = fnames, ffi, onError, ...} : job =>
adamc@201 865 let
adamc@1090 866 val mrs = !moduleRoots
adamc@1090 867
adamc@834 868 val anyErrors = ref false
adamc@834 869 fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
adam@1343 870 fun nameOf fname =
adam@1343 871 let
adam@1343 872 val fname = OS.Path.file fname
adam@1343 873 val fst = if size fname = 0 then #"!" else String.sub (fname, 0)
adam@1343 874 in
adam@1343 875 if not (Char.isAlpha fst) then
adam@1343 876 ErrorMsg.error ("Filename doesn't start with letter: " ^ fname)
adam@1343 877 else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then
adam@1343 878 ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname)
adam@1343 879 else
adam@1343 880 ();
adam@1343 881 capitalize fname
adam@1343 882 end
adamc@109 883
adamc@764 884 fun parseFfi fname =
adamc@764 885 let
adamc@764 886 val mname = nameOf fname
adamc@764 887 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@764 888
adamc@764 889 val loc = {file = urs,
adamc@764 890 first = ErrorMsg.dummyPos,
adamc@764 891 last = ErrorMsg.dummyPos}
adamc@764 892
adamc@764 893 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
adamc@764 894 in
adamc@834 895 checkErrors ();
adamc@764 896 (Source.DFfiStr (mname, sgn), loc)
adamc@764 897 end
adamc@764 898
adamc@1090 899 val defed = ref SS.empty
adamc@1092 900 val fulls = ref SS.empty
adamc@1090 901
adamc@201 902 fun parseOne fname =
adamc@201 903 let
adamc@201 904 val mname = nameOf fname
adamc@244 905 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
adamc@244 906 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@56 907
adamc@201 908 val sgnO =
adamc@244 909 if Posix.FileSys.access (urs, []) then
adamc@244 910 SOME (Source.SgnConst (#func parseUrs urs),
adamc@244 911 {file = urs,
adamc@201 912 first = ErrorMsg.dummyPos,
adamc@201 913 last = ErrorMsg.dummyPos})
adamc@834 914 before checkErrors ()
adamc@201 915 else
adamc@201 916 NONE
adamc@56 917
adamc@244 918 val loc = {file = ur,
adamc@201 919 first = ErrorMsg.dummyPos,
adamc@201 920 last = ErrorMsg.dummyPos}
adamc@56 921
adamc@244 922 val ds = #func parseUr ur
adamc@1090 923 val d = (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
adamc@1090 924
adamc@1126 925 val fname = OS.Path.mkCanonical fname
adamc@1090 926 val d = case List.find (fn (root, name) =>
adamc@1090 927 String.isPrefix (root ^ "/") fname) mrs of
adamc@1090 928 NONE => d
adamc@1090 929 | SOME (root, name) =>
adamc@1090 930 let
adamc@1090 931 val fname = String.extract (fname, size root + 1, NONE)
adamc@1090 932 val pieces = name :: String.tokens (fn ch => ch = #"/") fname
adamc@1090 933 val pieces = List.filter (fn s => size s > 0
adamc@1090 934 andalso Char.isAlpha (String.sub (s, 0)))
adamc@1090 935 pieces
adamc@1090 936 val pieces = map capitalize pieces
adamc@1092 937 val full = String.concatWith "." pieces
adamc@1090 938
adamc@1090 939 fun makeD prefix pieces =
adamc@1090 940 case pieces of
adamc@1090 941 [] => (ErrorMsg.error "Empty module path";
adamc@1090 942 (Source.DStyle "Boo", loc))
adamc@1090 943 | [_] => d
adamc@1090 944 | piece :: pieces =>
adamc@1090 945 let
adamc@1146 946 val this = case prefix of
adamc@1146 947 "" => piece
adamc@1146 948 | _ => prefix ^ "." ^ piece
adamc@1090 949 val old = SS.member (!defed, this)
adamc@1146 950
adamc@1146 951 fun notThere (ch, s) =
adamc@1146 952 Substring.isEmpty (#2 (Substring.splitl
adamc@1146 953 (fn ch' => ch' <> ch) s))
adamc@1146 954
adamc@1146 955 fun simOpen () =
adamc@1146 956 SS.foldl (fn (full, ds) =>
adamc@1146 957 if String.isPrefix (this ^ ".") full
adamc@1146 958 andalso notThere (#".",
adamc@1146 959 Substring.extract (full,
adamc@1146 960 size
adamc@1146 961 this + 1,
adamc@1146 962 NONE)) then
adamc@1146 963 let
adamc@1146 964 val parts = String.tokens
adamc@1146 965 (fn ch => ch = #".") full
adamc@1146 966
adamc@1146 967 val part = List.last parts
adamc@1146 968
adamc@1146 969 val imp = if length parts >= 2 then
adamc@1146 970 (Source.StrProj
adamc@1146 971 ((Source.StrVar
adamc@1146 972 (List.nth (parts,
adamc@1146 973 length
adamc@1146 974 parts
adamc@1146 975 - 2)),
adamc@1146 976 loc),
adamc@1146 977 part), loc)
adamc@1146 978 else
adamc@1146 979 (Source.StrVar part, loc)
adamc@1146 980 in
adamc@1146 981 (Source.DStr (part, NONE, imp),
adamc@1146 982 loc) :: ds
adamc@1146 983 end
adamc@1146 984 else
adamc@1146 985 ds) [] (!fulls)
adamc@1090 986 in
adamc@1090 987 defed := SS.add (!defed, this);
adamc@1090 988 (Source.DStr (piece, NONE,
adamc@1090 989 (Source.StrConst (if old then
adamc@1146 990 simOpen ()
adamc@1146 991 @ [makeD this pieces]
adamc@1090 992 else
adamc@1146 993 [makeD this pieces]), loc)),
adamc@1090 994 loc)
adamc@1090 995 end
adamc@1090 996 in
adamc@1092 997 if SS.member (!fulls, full) then
adamc@1092 998 ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
adamc@1092 999 else
adamc@1092 1000 ();
adamc@1146 1001
adamc@1090 1002 makeD "" pieces
adamc@1146 1003 before ignore (foldl (fn (new, path) =>
adamc@1146 1004 let
adamc@1146 1005 val new' = case path of
adamc@1146 1006 "" => new
adamc@1146 1007 | _ => path ^ "." ^ new
adamc@1146 1008 in
adamc@1146 1009 fulls := SS.add (!fulls, new');
adamc@1146 1010 new'
adamc@1146 1011 end) "" pieces)
adamc@1090 1012 end
adamc@201 1013 in
adamc@834 1014 checkErrors ();
adamc@1090 1015 d
adamc@201 1016 end
adamc@56 1017
adamc@764 1018 val dsFfi = map parseFfi ffi
adamc@201 1019 val ds = map parseOne fnames
adamc@1090 1020 val loc = ErrorMsg.dummySpan
adamc@201 1021 in
adamc@834 1022 if !anyErrors then
adamc@834 1023 ErrorMsg.error "Parse failure"
adamc@834 1024 else
adamc@834 1025 ();
adamc@834 1026
adamc@201 1027 let
adamc@1126 1028 val final = List.last fnames
adamc@1126 1029 val final = case List.find (fn (root, name) =>
adamc@1126 1030 String.isPrefix (root ^ "/") final) mrs of
adamc@1126 1031 NONE => (Source.StrVar (nameOf final), loc)
adamc@1126 1032 | SOME (root, name) =>
adamc@1126 1033 let
adamc@1126 1034 val m = (Source.StrVar name, loc)
adamc@1126 1035 val final = String.extract (final, size root + 1, NONE)
adamc@1264 1036 val fields = String.fields (fn ch => ch = #"/") final
adamc@1264 1037 val fields = List.filter (fn s => size s = 0
adamc@1264 1038 orelse not (Char.isDigit (String.sub (s, 0))))
adamc@1264 1039 fields
adamc@1126 1040 in
adamc@1126 1041 foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc))
adamc@1264 1042 m fields
adamc@1126 1043 end
adamc@271 1044
adamc@764 1045 val ds = dsFfi @ ds
adamc@1126 1046 @ [(Source.DExport final, loc)]
adamc@1090 1047
adamc@1090 1048 val ds = case database of
adamc@1090 1049 NONE => ds
adamc@1090 1050 | SOME s => (Source.DDatabase s, loc) :: ds
adam@1294 1051
adam@1294 1052 val ds = case onError of
adam@1294 1053 NONE => ds
adam@1294 1054 | SOME v => ds @ [(Source.DOnError v, loc)]
adamc@201 1055 in
adamc@1090 1056 ds
adamc@201 1057 end handle Empty => ds
adamc@201 1058 end,
adamc@201 1059 print = SourcePrint.p_file
adamc@201 1060 }
adamc@56 1061
adamc@270 1062 val toParse = transform parse "parse" o toParseJob
adamc@38 1063
adamc@378 1064 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
adamc@378 1065 file = s}
adamc@378 1066 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@378 1067 file = s}
adamc@378 1068
adamc@201 1069 val elaborate = {
adamc@201 1070 func = fn file => let
adamc@378 1071 val basis = #func parseUrs (libFile "basis.urs")
adamc@378 1072 val topSgn = #func parseUrs (libFile "top.urs")
adamc@378 1073 val topStr = #func parseUr (libFile "top.ur")
adamc@201 1074 in
adamc@325 1075 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
adamc@201 1076 end,
adamc@201 1077 print = ElabPrint.p_file ElabEnv.empty
adamc@201 1078 }
adamc@5 1079
adamc@270 1080 val toElaborate = transform elaborate "elaborate" o toParse
adamc@201 1081
adamc@448 1082 val unnest = {
adamc@448 1083 func = Unnest.unnest,
adamc@448 1084 print = ElabPrint.p_file ElabEnv.empty
adamc@448 1085 }
adamc@448 1086
adamc@448 1087 val toUnnest = transform unnest "unnest" o toElaborate
adamc@448 1088
adamc@313 1089 val termination = {
adamc@313 1090 func = (fn file => (Termination.check file; file)),
adamc@313 1091 print = ElabPrint.p_file ElabEnv.empty
adamc@313 1092 }
adamc@313 1093
adamc@448 1094 val toTermination = transform termination "termination" o toUnnest
adamc@313 1095
adamc@201 1096 val explify = {
adamc@201 1097 func = Explify.explify,
adamc@201 1098 print = ExplPrint.p_file ExplEnv.empty
adamc@201 1099 }
adamc@201 1100
adamc@625 1101 val toExplify = transform explify "explify" o toUnnest
adamc@201 1102
adamc@201 1103 val corify = {
adamc@201 1104 func = Corify.corify,
adamc@201 1105 print = CorePrint.p_file CoreEnv.empty
adamc@201 1106 }
adamc@201 1107
adamc@270 1108 val toCorify = transform corify "corify" o toExplify
adamc@201 1109
adamc@482 1110 (*val reduce_local = {
adamc@482 1111 func = ReduceLocal.reduce,
adamc@482 1112 print = CorePrint.p_file CoreEnv.empty
adamc@482 1113 }
adamc@482 1114
adamc@482 1115 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
adamc@482 1116
adamc@443 1117 val especialize = {
adamc@443 1118 func = ESpecialize.specialize,
adamc@443 1119 print = CorePrint.p_file CoreEnv.empty
adamc@443 1120 }
adamc@443 1121
adamc@454 1122 val core_untangle = {
adamc@454 1123 func = CoreUntangle.untangle,
adamc@454 1124 print = CorePrint.p_file CoreEnv.empty
adamc@454 1125 }
adamc@454 1126
adamc@794 1127 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
adamc@454 1128
adamc@202 1129 val shake = {
adamc@202 1130 func = Shake.shake,
adamc@202 1131 print = CorePrint.p_file CoreEnv.empty
adamc@202 1132 }
adamc@39 1133
adamc@454 1134 val toShake1 = transform shake "shake1" o toCore_untangle
adamc@110 1135
adam@1362 1136 val toEspecialize1' = transform especialize "especialize1'" o toShake1
adam@1362 1137 val toShake1' = transform shake "shake1'" o toEspecialize1'
adam@1362 1138
adamc@607 1139 val rpcify = {
adamc@607 1140 func = Rpcify.frob,
adamc@607 1141 print = CorePrint.p_file CoreEnv.empty
adamc@607 1142 }
adamc@607 1143
adam@1362 1144 val toRpcify = transform rpcify "rpcify" o toShake1'
adamc@607 1145
adamc@642 1146 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
adamc@642 1147 val toShake2 = transform shake "shake2" o toCore_untangle2
adamc@1181 1148
adamc@1186 1149 val toEspecialize1 = transform especialize "especialize1" o toShake2
adamc@1181 1150
adamc@1062 1151 val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
adamc@1062 1152 val toShake3 = transform shake "shake3" o toCore_untangle3
adamc@642 1153
adamc@202 1154 val tag = {
adamc@202 1155 func = Tag.tag,
adamc@202 1156 print = CorePrint.p_file CoreEnv.empty
adamc@202 1157 }
adamc@193 1158
adamc@1062 1159 val toTag = transform tag "tag" o toShake3
adamc@20 1160
adamc@202 1161 val reduce = {
adamc@202 1162 func = Reduce.reduce,
adamc@202 1163 print = CorePrint.p_file CoreEnv.empty
adamc@202 1164 }
adamc@25 1165
adamc@692 1166 val toReduce = transform reduce "reduce" o toTag
adamc@23 1167
adamc@1186 1168 val toShakey = transform shake "shakey" o toReduce
adamc@1186 1169
adamc@1186 1170 val unpoly = {
adamc@1186 1171 func = Unpoly.unpoly,
adamc@1186 1172 print = CorePrint.p_file CoreEnv.empty
adamc@1186 1173 }
adamc@1186 1174
adamc@1186 1175 val toUnpoly = transform unpoly "unpoly" o toShakey
adamc@315 1176
adamc@202 1177 val specialize = {
adamc@202 1178 func = Specialize.specialize,
adamc@202 1179 print = CorePrint.p_file CoreEnv.empty
adamc@202 1180 }
adamc@132 1181
adamc@1186 1182 val toSpecialize = transform specialize "specialize" o toUnpoly
adamc@131 1183
adamc@1062 1184 val toShake4 = transform shake "shake4" o toSpecialize
adamc@133 1185
adamc@1062 1186 val toEspecialize2 = transform especialize "especialize2" o toShake4
adamc@1272 1187 val toShake4' = transform shake "shake4'" o toEspecialize2
adamc@1272 1188 val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
adamc@1276 1189 val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
adamc@1276 1190 val toShake4'' = transform shake "shake4'" o toSpecialize2
adamc@1272 1191 val toEspecialize3 = transform especialize "especialize3" o toShake4''
adamc@794 1192
adamc@1272 1193 val toReduce2 = transform reduce "reduce2" o toEspecialize3
adamc@898 1194
adamc@1062 1195 val toShake5 = transform shake "shake5" o toReduce2
adamc@794 1196
adamc@692 1197 val marshalcheck = {
adamc@692 1198 func = (fn file => (MarshalCheck.check file; file)),
adamc@692 1199 print = CorePrint.p_file CoreEnv.empty
adamc@692 1200 }
adamc@692 1201
adamc@1062 1202 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5
adamc@692 1203
adamc@732 1204 val effectize = {
adamc@732 1205 func = Effective.effectize,
adamc@732 1206 print = CorePrint.p_file CoreEnv.empty
adamc@732 1207 }
adamc@732 1208
adamc@732 1209 val toEffectize = transform effectize "effectize" o toMarshalcheck
adamc@732 1210
adamc@1170 1211 val css = {
adamc@1170 1212 func = Css.summarize,
adamc@1170 1213 print = fn _ => Print.box []
adamc@1170 1214 }
adamc@1170 1215
adamc@1170 1216 val toCss = transform css "css" o toShake5
adamc@1170 1217
adamc@202 1218 val monoize = {
adamc@202 1219 func = Monoize.monoize CoreEnv.empty,
adamc@202 1220 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1221 }
adamc@134 1222
adamc@732 1223 val toMonoize = transform monoize "monoize" o toEffectize
adamc@96 1224
adamc@202 1225 val mono_opt = {
adamc@910 1226 func = MonoOpt.optimize,
adamc@202 1227 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1228 }
adamc@29 1229
adamc@270 1230 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
adamc@5 1231
adamc@202 1232 val untangle = {
adamc@202 1233 func = Untangle.untangle,
adamc@202 1234 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1235 }
adamc@1 1236
adamc@270 1237 val toUntangle = transform untangle "untangle" o toMono_opt1
adamc@38 1238
adamc@202 1239 val mono_reduce = {
adamc@202 1240 func = MonoReduce.reduce,
adamc@202 1241 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1242 }
adamc@16 1243
adamc@270 1244 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
adamc@39 1245
adamc@202 1246 val mono_shake = {
adamc@202 1247 func = MonoShake.shake,
adamc@202 1248 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1249 }
adamc@110 1250
adamc@270 1251 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
adamc@193 1252
adamc@572 1253 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
adamc@572 1254
adamc@1200 1255 val iflow = {
adamc@1235 1256 func = (fn file => (if !doIflow then Iflow.check file else (); file)),
adamc@1200 1257 print = MonoPrint.p_file MonoEnv.empty
adamc@1200 1258 }
adamc@1200 1259
adamc@1200 1260 val toIflow = transform iflow "iflow" o toMono_opt2
adamc@1200 1261
adamc@567 1262 val jscomp = {
adamc@567 1263 func = JsComp.process,
adamc@567 1264 print = MonoPrint.p_file MonoEnv.empty
adamc@567 1265 }
adamc@567 1266
adamc@1200 1267 val toJscomp = transform jscomp "jscomp" o toIflow
adamc@567 1268
adamc@910 1269 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
adamc@20 1270
adamc@506 1271 val fuse = {
adamc@506 1272 func = Fuse.fuse,
adamc@506 1273 print = MonoPrint.p_file MonoEnv.empty
adamc@506 1274 }
adamc@506 1275
adamc@572 1276 val toFuse = transform fuse "fuse" o toMono_opt3
adamc@506 1277
adamc@506 1278 val toUntangle2 = transform untangle "untangle2" o toFuse
adamc@506 1279
adamc@601 1280 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
adamc@601 1281 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
adamc@916 1282 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
adamc@1017 1283 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
adamc@1185 1284 val toFuse2 = transform fuse "fuse2" o toMono_reduce3
adamc@916 1285 val toUntangle3 = transform untangle "untangle3" o toFuse2
adamc@916 1286 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
adamc@506 1287
adamc@377 1288 val pathcheck = {
adamc@377 1289 func = (fn file => (PathCheck.check file; file)),
adamc@377 1290 print = MonoPrint.p_file MonoEnv.empty
adamc@377 1291 }
adamc@377 1292
adamc@916 1293 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3
adamc@377 1294
adam@1595 1295 val sidecheck = {
adam@1595 1296 func = SideCheck.check,
adam@1595 1297 print = MonoPrint.p_file MonoEnv.empty
adam@1595 1298 }
adam@1595 1299
adam@1595 1300 val toSidecheck = transform sidecheck "sidecheck" o toPathcheck
adam@1595 1301
adamc@202 1302 val cjrize = {
adamc@202 1303 func = Cjrize.cjrize,
adamc@202 1304 print = CjrPrint.p_file CjrEnv.empty
adamc@202 1305 }
adamc@23 1306
adam@1595 1307 val toCjrize = transform cjrize "cjrize" o toSidecheck
adamc@29 1308
adamc@643 1309 val scriptcheck = {
adamc@643 1310 func = ScriptCheck.classify,
adamc@643 1311 print = CjrPrint.p_file CjrEnv.empty
adamc@643 1312 }
adamc@643 1313
adamc@643 1314 val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
adamc@643 1315
adamc@282 1316 val prepare = {
adamc@282 1317 func = Prepare.prepare,
adamc@282 1318 print = CjrPrint.p_file CjrEnv.empty
adamc@282 1319 }
adamc@282 1320
adamc@643 1321 val toPrepare = transform prepare "prepare" o toScriptcheck
adamc@282 1322
adamc@879 1323 val checknest = {
adamc@879 1324 func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
adamc@879 1325 print = CjrPrint.p_file CjrEnv.empty
adamc@879 1326 }
adamc@879 1327
adamc@879 1328 val toChecknest = transform checknest "checknest" o toPrepare
adamc@879 1329
adamc@274 1330 val sqlify = {
adamc@274 1331 func = Cjrize.cjrize,
adamc@274 1332 print = CjrPrint.p_sql CjrEnv.empty
adamc@274 1333 }
adamc@274 1334
adamc@274 1335 val toSqlify = transform sqlify "sqlify" o toMono_opt2
adamc@274 1336
adam@1473 1337 val escapeFilename = String.translate (fn #" " => "\\ " | #"\"" => "\\\"" | #"'" => "\\'" | ch => str ch)
adam@1473 1338
adam@1540 1339 val beforeC = ref (fn () => ())
adam@1540 1340
adamc@764 1341 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
adamc@183 1342 let
adamc@855 1343 val proto = Settings.currentProtocol ()
adamc@1095 1344
adam@1368 1345 val lib = if Settings.getStaticLinking () then
adam@1368 1346 #linkStatic proto ^ " " ^ Config.lib ^ "/../liburweb.a"
adam@1368 1347 else
adam@1368 1348 "-L" ^ Config.lib ^ "/.. -lurweb " ^ #linkDynamic proto
adamc@378 1349
adam@1558 1350 val opt = if debug then
adam@1558 1351 ""
adam@1558 1352 else
adam@1558 1353 " -O3"
adam@1558 1354
adam@1558 1355 val compile = Config.ccompiler ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value"
adam@1558 1356 ^ opt ^ " -I " ^ Config.includ
adamc@1096 1357 ^ " " ^ #compile proto
adam@1473 1358 ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname
adamc@1096 1359
adam@1558 1360 val link = Config.ccompiler ^ " -Werror" ^ opt ^ " -lm " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs
adam@1528 1361 ^ " " ^ lib ^ " " ^ Config.openssl ^ " " ^ escapeFilename oname ^ " -o " ^ escapeFilename ename ^ " " ^ libs
adamc@502 1362
adamc@502 1363 val (compile, link) =
adamc@502 1364 if profile then
adamc@502 1365 (compile ^ " -pg", link ^ " -pg")
adamc@502 1366 else
adamc@502 1367 (compile, link)
adamc@742 1368
adamc@742 1369 val (compile, link) =
adamc@742 1370 if debug then
adamc@742 1371 (compile ^ " -g", link ^ " -g")
adamc@742 1372 else
adamc@742 1373 (compile, link)
adamc@764 1374
adamc@764 1375 val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
adam@1394 1376
adam@1394 1377 fun system s =
adam@1394 1378 (if debug then
adam@1394 1379 print (s ^ "\n")
adam@1394 1380 else
adam@1394 1381 ();
adam@1394 1382 OS.Process.isSuccess (OS.Process.system s))
adamc@183 1383 in
adam@1540 1384 !beforeC ();
adam@1394 1385 system compile andalso system link
adamc@183 1386 end
adamc@183 1387
adamc@202 1388 fun compile job =
adamc@879 1389 case run toChecknest job of
adamc@1045 1390 NONE => false
adamc@29 1391 | SOME file =>
adamc@202 1392 let
adamc@274 1393 val job = valOf (run (transform parseUrp "parseUrp") job)
adamc@102 1394
adamc@274 1395 val (cname, oname, cleanup) =
adamc@274 1396 if #debug job then
adamc@457 1397 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
adamc@274 1398 else
adamc@274 1399 let
adamc@274 1400 val dir = OS.FileSys.tmpName ()
adamc@403 1401 val () = if OS.FileSys.access (dir, []) then
adamc@403 1402 OS.FileSys.remove dir
adamc@403 1403 else
adamc@403 1404 ()
adamc@457 1405 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
adamc@457 1406 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
adamc@274 1407 in
adamc@274 1408 OS.FileSys.mkDir dir;
adamc@274 1409 (cname, oname,
adam@1381 1410 fn () => (OS.FileSys.remove cname;
adam@1381 1411 OS.FileSys.remove oname;
adam@1381 1412 OS.FileSys.rmDir dir)
adam@1381 1413 handle OS.SysErr _ => OS.FileSys.rmDir dir)
adamc@274 1414 end
adamc@274 1415 val ename = #exe job
adamc@202 1416 in
adamc@274 1417 let
adamc@274 1418 val outf = TextIO.openOut cname
adamc@274 1419 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@432 1420
adamc@432 1421 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
adamc@432 1422 val libs =
adamc@432 1423 if hasDb then
adamc@866 1424 #link (Settings.currentDbms ())
adamc@432 1425 else
adamc@432 1426 ""
adamc@274 1427 in
adamc@274 1428 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
adamc@415 1429 TextIO.output1 (outf, #"\n");
adamc@274 1430 TextIO.closeOut outf;
adamc@102 1431
adam@1381 1432 if ErrorMsg.anyErrors () then
adam@1381 1433 false
adam@1381 1434 else
adam@1381 1435 (case #sql job of
adam@1381 1436 NONE => ()
adam@1381 1437 | SOME sql =>
adam@1381 1438 let
adam@1381 1439 val outf = TextIO.openOut sql
adam@1381 1440 val s = TextIOPP.openOut {dst = outf, wid = 80}
adam@1381 1441 in
adam@1381 1442 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
adam@1381 1443 TextIO.closeOut outf
adam@1381 1444 end;
adamc@274 1445
adam@1381 1446 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
adam@1381 1447 profile = #profile job, debug = #debug job, link = #link job}
adam@1381 1448
adam@1381 1449 before cleanup ())
adamc@274 1450 end
adamc@274 1451 handle ex => (((cleanup ()) handle _ => ()); raise ex)
adamc@202 1452 end
adamc@29 1453
adamc@1045 1454 fun compiler job =
adamc@1045 1455 if compile job then
adamc@1045 1456 ()
adamc@1045 1457 else
adamc@1045 1458 OS.Process.exit OS.Process.failure
adamc@1045 1459
adamc@1266 1460 fun moduleOf fname =
adamc@1266 1461 let
adamc@1266 1462 val mrs = !moduleRoots
adamc@1266 1463 val fname = OS.Path.mkCanonical fname
adamc@1266 1464 in
adamc@1266 1465 case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
adamc@1266 1466 NONE => capitalize (OS.Path.base (OS.Path.file fname))
adamc@1266 1467 | SOME (root, name) =>
adamc@1266 1468 let
adamc@1266 1469 val fname = OS.Path.base fname
adamc@1266 1470 val fname = String.extract (fname, size root + 1, NONE)
adamc@1266 1471 val fs = String.fields (fn ch => ch = #"/") fname
adamc@1266 1472 val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
adamc@1266 1473 val fs = map capitalize fs
adamc@1266 1474 in
adamc@1266 1475 String.concatWith "." (name :: fs)
adamc@1266 1476 end
adamc@1266 1477 end
adamc@1266 1478
adamc@1 1479 end