Mercurial > urweb

annotate src/compiler.sml @ 2101:32e2752390ad

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