Mercurial > urweb

annotate src/compiler.sml @ 2033:ea0ecd5fa9df

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add locking to enforce atomicity of message sends from one transaction
author Adam Chlipala <adam@chlipala.net>
date Fri, 27 Jun 2014 14:39:31 -0400
parents 403f0cc65b9c
children ced78ef1c82f c1a62ce47083
rev   line source
adam@1677 1 (* Copyright (c) 2008-2012, 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@1780 464 val pathmap = ref (!pathmap)
adam@1780 465 val bigLibs = ref []
adamc@767 466
adam@1780 467 fun pu filename =
adam@1780 468 let
adam@1780 469 val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
adam@1338 470
adam@1780 471 val dir = OS.Path.dir filename
adam@1780 472 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
adamc@1151 473
adam@1780 474 val inf = opener ()
adamc@1151 475
adam@1780 476 fun hasSpaceLine () =
adam@1780 477 case inputCommentableLine inf of
adam@1780 478 Content s => s = "debug" orelse s = "profile"
adam@1780 479 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
adam@1780 480 | EndOfFile => false
adam@1780 481 | OnlyComment => hasSpaceLine ()
adamc@1151 482
adam@1780 483 val hasBlankLine = hasSpaceLine ()
adamc@1151 484
adam@1780 485 val inf = (TextIO.closeIn inf; opener ())
adamc@767 486
adam@1780 487 fun pathify fname =
adam@1780 488 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
adam@1780 489 let
adam@1780 490 val fname' = Substring.extract (fname, 1, NONE)
adam@1780 491 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
adam@1780 492 in
adam@1780 493 case M.find (!pathmap, Substring.string befor) of
adam@1780 494 NONE => fname
adam@1780 495 | SOME rep => rep ^ Substring.string after
adam@1780 496 end
adam@1780 497 else
adam@1780 498 fname
adam@1296 499
adam@1780 500 fun relify fname =
adam@1780 501 let
adam@1780 502 val fname = pathify fname
adam@1780 503 in
adam@1780 504 OS.Path.concat (dir, fname)
adam@1780 505 handle OS.Path.Path => fname
adam@1780 506 end
adamc@767 507
adam@1780 508 fun libify path =
adam@1780 509 (if Posix.FileSys.access (path ^ ".urp", []) then
adam@1780 510 path
adam@1780 511 else
adam@1780 512 path ^ "/lib")
adam@1780 513 handle SysErr => path
adam@1780 514
adam@1780 515 fun libify' path =
adam@1780 516 (if Posix.FileSys.access (relify path ^ ".urp", []) then
adam@1780 517 path
adam@1780 518 else
adam@1780 519 path ^ "/lib")
adam@1780 520 handle SysErr => path
adam@1780 521
adam@1780 522 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
adam@1780 523
adam@1780 524 fun relifyA fname =
adam@1780 525 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
adam@1780 526
adam@1780 527 fun readSources acc =
adam@1780 528 case inputCommentableLine inf of
adam@1780 529 Content line =>
adam@1780 530 let
adam@1780 531 val acc = if CharVector.all Char.isSpace line then
adam@1780 532 acc
adam@1780 533 else
adam@1780 534 let
adam@1780 535 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
adam@1780 536 (String.explode line))
adam@1780 537 val fname = relifyA fname
adam@1780 538 in
adam@1780 539 fname :: acc
adam@1780 540 end
adam@1780 541 in
adam@1780 542 readSources acc
adam@1780 543 end
adam@1780 544 | OnlyComment => readSources acc
adam@1780 545 | EndOfFile => rev acc
adam@1780 546
adam@1780 547 val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s)
adam@1780 548 val database = ref (Settings.getDbstring ())
adam@1780 549 val exe = ref (Settings.getExe ())
adam@1780 550 val sql = ref (Settings.getSql ())
adam@1780 551 val debug = ref (Settings.getDebug ())
adam@1780 552 val profile = ref false
adam@1780 553 val timeout = ref NONE
adam@1780 554 val ffi = ref []
adam@1780 555 val link = ref []
adam@1780 556 val linker = ref NONE
adam@1780 557 val headers = ref []
adam@1780 558 val scripts = ref []
adam@1780 559 val clientToServer = ref []
adam@1780 560 val effectful = ref []
adam@1780 561 val benignEffectful = ref []
adam@1780 562 val clientOnly = ref []
adam@1780 563 val serverOnly = ref []
adam@1780 564 val jsFuncs = ref []
adam@1780 565 val rewrites = ref []
adam@1780 566 val url = ref []
adam@1780 567 val mime = ref []
adam@1780 568 val request = ref []
adam@1780 569 val response = ref []
adam@1799 570 val env = ref []
adam@1780 571 val libs = ref []
adam@1780 572 val protocol = ref NONE
adam@1780 573 val dbms = ref NONE
adam@1780 574 val sigFile = ref (Settings.getSigFile ())
adam@1780 575 val safeGets = ref []
adam@1780 576 val onError = ref NONE
adam@1780 577 val minHeap = ref 0
adam@1780 578
adam@1780 579 fun finish sources =
adam@1780 580 let
adam@1780 581 val job = {
adam@1780 582 prefix = Option.getOpt (!prefix, "/"),
adam@1780 583 database = !database,
adam@1780 584 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
adam@1780 585 ext = SOME "exe"}),
adam@1780 586 sql = !sql,
adam@1780 587 debug = !debug,
adam@1780 588 profile = !profile,
adam@1780 589 timeout = Option.getOpt (!timeout, 60),
adam@1780 590 ffi = rev (!ffi),
adam@1780 591 link = rev (!link),
adam@1780 592 linker = !linker,
adam@1780 593 headers = rev (!headers),
adam@1780 594 scripts = rev (!scripts),
adam@1780 595 clientToServer = rev (!clientToServer),
adam@1780 596 effectful = rev (!effectful),
adam@1780 597 benignEffectful = rev (!benignEffectful),
adam@1780 598 clientOnly = rev (!clientOnly),
adam@1780 599 serverOnly = rev (!serverOnly),
adam@1780 600 jsFuncs = rev (!jsFuncs),
adam@1780 601 rewrites = rev (!rewrites),
adam@1780 602 filterUrl = rev (!url),
adam@1780 603 filterMime = rev (!mime),
adam@1780 604 filterRequest = rev (!request),
adam@1780 605 filterResponse = rev (!response),
adam@1799 606 filterEnv = rev (!env),
adam@1780 607 sources = sources,
adam@1780 608 protocol = !protocol,
adam@1780 609 dbms = !dbms,
adam@1780 610 sigFile = !sigFile,
adam@1780 611 safeGets = rev (!safeGets),
adam@1780 612 onError = !onError,
adam@1780 613 minHeap = !minHeap
adam@1780 614 }
adam@1780 615
adam@1780 616 fun mergeO f (old, new) =
adam@1780 617 case (old, new) of
adam@1780 618 (NONE, _) => new
adam@1780 619 | (_, NONE) => old
adam@1780 620 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adam@1780 621
adam@1780 622 fun same desc = mergeO (fn (x : string, y) =>
adam@1780 623 (if x = y then
adam@1780 624 ()
adam@1780 625 else
adam@1780 626 ErrorMsg.error ("Multiple "
adam@1780 627 ^ desc ^ " values that don't agree");
adam@1780 628 x))
adam@1780 629
adam@1780 630 fun merge (old : job, new : job) = {
adam@1780 631 prefix = case #prefix old of
adam@1780 632 "/" => #prefix new
adam@1780 633 | pold => case #prefix new of
adam@1780 634 "/" => pold
adam@1780 635 | pnew => (if pold = pnew then
adam@1780 636 ()
adam@1780 637 else
adam@1780 638 ErrorMsg.error ("Multiple prefix values that don't agree: "
adam@1780 639 ^ pold ^ ", " ^ pnew);
adam@1780 640 pold),
adam@1780 641 database = mergeO (fn (old, _) => old) (#database old, #database new),
adam@1780 642 exe = #exe old,
adam@1780 643 sql = #sql old,
adam@1780 644 debug = #debug old orelse #debug new,
adam@1780 645 profile = #profile old orelse #profile new,
adam@1780 646 timeout = #timeout old,
adam@1780 647 ffi = #ffi old @ #ffi new,
adam@1780 648 link = #link old @ #link new,
adam@1780 649 linker = mergeO (fn (_, new) => new) (#linker old, #linker new),
adam@1780 650 headers = #headers old @ #headers new,
adam@1780 651 scripts = #scripts old @ #scripts new,
adam@1780 652 clientToServer = #clientToServer old @ #clientToServer new,
adam@1780 653 effectful = #effectful old @ #effectful new,
adam@1780 654 benignEffectful = #benignEffectful old @ #benignEffectful new,
adam@1780 655 clientOnly = #clientOnly old @ #clientOnly new,
adam@1780 656 serverOnly = #serverOnly old @ #serverOnly new,
adam@1780 657 jsFuncs = #jsFuncs old @ #jsFuncs new,
adam@1780 658 rewrites = #rewrites old @ #rewrites new,
adam@1780 659 filterUrl = #filterUrl old @ #filterUrl new,
adam@1780 660 filterMime = #filterMime old @ #filterMime new,
adam@1780 661 filterRequest = #filterRequest old @ #filterRequest new,
adam@1780 662 filterResponse = #filterResponse old @ #filterResponse new,
adam@1799 663 filterEnv = #filterEnv old @ #filterEnv new,
adam@1780 664 sources = #sources new
adam@1780 665 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
adam@1780 666 (#sources old),
adam@1780 667 protocol = mergeO #2 (#protocol old, #protocol new),
adam@1780 668 dbms = mergeO #2 (#dbms old, #dbms new),
adam@1780 669 sigFile = mergeO #2 (#sigFile old, #sigFile new),
adam@1780 670 safeGets = #safeGets old @ #safeGets new,
adam@1780 671 onError = mergeO #2 (#onError old, #onError new),
adam@1780 672 minHeap = Int.max (#minHeap old, #minHeap new)
adam@1780 673 }
adam@1780 674 in
adam@1780 675 if accLibs then
adam@1780 676 foldr (fn (job', job) => merge (job, job')) job (!libs)
adam@1780 677 else
adam@1780 678 job
adam@1780 679 end
adam@1780 680
adam@1780 681 fun parsePkind s =
adam@1780 682 case s of
adam@1780 683 "all" => Settings.Any
adam@1780 684 | "url" => Settings.Url
adam@1780 685 | "table" => Settings.Table
adam@1780 686 | "sequence" => Settings.Sequence
adam@1780 687 | "view" => Settings.View
adam@1780 688 | "relation" => Settings.Relation
adam@1780 689 | "cookie" => Settings.Cookie
adam@1780 690 | "style" => Settings.Style
adam@1780 691 | _ => (ErrorMsg.error "Bad path kind spec";
adam@1780 692 Settings.Any)
adam@1780 693
adam@1780 694 fun parseFrom s =
adam@1780 695 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
adam@1780 696 (Settings.Prefix, String.substring (s, 0, size s - 1))
adam@1296 697 else
adam@1780 698 (Settings.Exact, s)
adamc@767 699
adam@1780 700 fun parseFkind s =
adam@1780 701 case s of
adam@1780 702 "url" => url
adam@1780 703 | "mime" => mime
adam@1780 704 | "requestHeader" => request
adam@1780 705 | "responseHeader" => response
adam@1799 706 | "env" => env
adam@1780 707 | _ => (ErrorMsg.error "Bad filter kind";
adam@1780 708 url)
adam@1780 709
adam@1780 710 fun parsePattern s =
adam@1780 711 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
adam@1780 712 (Settings.Prefix, String.substring (s, 0, size s - 1))
adam@1296 713 else
adam@1780 714 (Settings.Exact, s)
adamc@767 715
adam@1780 716 fun read () =
adam@1780 717 case inputCommentableLine inf of
adam@1780 718 EndOfFile => finish []
adam@1780 719 | OnlyComment => read ()
adam@1780 720 | Content "" => finish (readSources [])
adam@1780 721 | Content line =>
adam@1780 722 let
adam@1780 723 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
adam@1780 724 val cmd = Substring.string (trim cmd)
adam@1780 725 val arg = Substring.string (trim arg)
adamc@794 726
adam@1780 727 fun ffiS () =
adam@1780 728 case String.fields (fn ch => ch = #".") arg of
adam@1780 729 [m, x] => (m, x)
adam@1780 730 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
adam@1780 731 ("", ""))
adamc@794 732
adam@1780 733 fun ffiM () =
adam@1780 734 case String.fields (fn ch => ch = #"=") arg of
adam@1780 735 [f, s] =>
adam@1780 736 let
adam@1780 737 val f = trimS f
adam@1780 738 val s = trimS s
adam@1780 739 in
adam@1780 740 case String.fields (fn ch => ch = #".") f of
adam@1780 741 [m, x] => ((m, x), s)
adam@1780 742 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adam@1780 743 (("", ""), ""))
adam@1780 744 end
adam@1780 745 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
adam@1780 746 (("", ""), ""))
adam@1780 747 in
adam@1780 748 case cmd of
adam@1780 749 "prefix" => prefix := SOME arg
adam@1780 750 | "database" =>
adam@1780 751 (case !database of
adam@1780 752 NONE => database := SOME arg
adam@1780 753 | SOME _ => ())
adam@1780 754 | "dbms" =>
adam@1780 755 (case !dbms of
adam@1780 756 NONE => dbms := SOME arg
adam@1780 757 | SOME _ => ())
adam@1780 758 | "sigfile" =>
adam@1780 759 (case !sigFile of
adam@1780 760 NONE => sigFile := SOME arg
adam@1780 761 | SOME _ => ())
adam@1780 762 | "exe" =>
adam@1780 763 (case !exe of
adam@1780 764 NONE => exe := SOME (relify arg)
adam@1780 765 | SOME _ => ())
adam@1780 766 | "sql" =>
adam@1780 767 (case !sql of
adam@1780 768 NONE => sql := SOME (relify arg)
adam@1780 769 | SOME _ => ())
adam@1780 770 | "debug" => debug := true
adam@1780 771 | "profile" => profile := true
adam@1780 772 | "timeout" =>
adam@1780 773 (case !timeout of
adam@1780 774 NONE => ()
adam@1780 775 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
adam@1780 776 timeout := SOME (valOf (Int.fromString arg)))
adam@1780 777 | "ffi" => ffi := relify arg :: !ffi
adam@1780 778 | "link" => let
adam@1780 779 val arg = if size arg >= 1
adam@1780 780 andalso String.sub (arg, 0) = #"-" then
adam@1780 781 arg
adam@1780 782 else
adam@1780 783 relifyA arg
adam@1780 784 in
adam@1780 785 link := arg :: !link
adam@1780 786 end
adam@1780 787 | "linker" => linker := SOME arg
adam@1780 788 | "include" => headers := relifyA arg :: !headers
adam@1780 789 | "script" => scripts := arg :: !scripts
adam@1780 790 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
adam@1780 791 | "safeGet" => safeGets := arg :: !safeGets
adam@1780 792 | "effectful" => effectful := ffiS () :: !effectful
adam@1780 793 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
adam@1780 794 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
adam@1780 795 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
adam@1780 796 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
adam@1780 797 | "rewrite" =>
adam@1780 798 let
adam@1780 799 fun doit (pkind, from, to, hyph) =
adam@1780 800 let
adam@1780 801 val pkind = parsePkind pkind
adam@1780 802 val (kind, from) = parseFrom from
adam@1780 803 in
adam@1780 804 rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
adam@1780 805 end
adam@1780 806 in
adam@1780 807 case String.tokens Char.isSpace arg of
adam@1780 808 [pkind, from, to, "[-]"] => doit (pkind, from, to, true)
adam@1780 809 | [pkind, from, "[-]"] => doit (pkind, from, "", true)
adam@1780 810 | [pkind, from, to] => doit (pkind, from, to, false)
adam@1780 811 | [pkind, from] => doit (pkind, from, "", false)
adam@1780 812 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
adam@1780 813 end
adam@1780 814 | "allow" =>
adam@1780 815 (case String.tokens Char.isSpace arg of
adam@1780 816 [fkind, pattern] =>
adam@1780 817 let
adam@1780 818 val fkind = parseFkind fkind
adam@1780 819 val (kind, pattern) = parsePattern pattern
adam@1780 820 in
adam@1780 821 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
adam@1780 822 end
adam@1780 823 | _ => ErrorMsg.error "Bad 'allow' syntax")
adam@1780 824 | "deny" =>
adam@1780 825 (case String.tokens Char.isSpace arg of
adam@1780 826 [fkind, pattern] =>
adam@1780 827 let
adam@1780 828 val fkind = parseFkind fkind
adam@1780 829 val (kind, pattern) = parsePattern pattern
adam@1780 830 in
adam@1780 831 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
adam@1780 832 end
adam@1780 833 | _ => ErrorMsg.error "Bad 'deny' syntax")
adam@1780 834 | "library" => if accLibs then
adam@1780 835 libs := pu (libify (relify arg)) :: !libs
adam@1780 836 else
adam@1780 837 bigLibs := libify' arg :: !bigLibs
adam@1780 838 | "path" =>
adam@1780 839 (case String.fields (fn ch => ch = #"=") arg of
adam@1780 840 [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
adam@1780 841 handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
adam@1780 842 | _ => ErrorMsg.error "path argument not of the form name=value'")
adam@1780 843 | "onError" =>
adam@1780 844 (case String.fields (fn ch => ch = #".") arg of
adam@1780 845 m1 :: (fs as _ :: _) =>
adam@1780 846 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
adam@1780 847 | _ => ErrorMsg.error "invalid 'onError' argument")
adam@1780 848 | "limit" =>
adam@1780 849 (case String.fields Char.isSpace arg of
adam@1780 850 [class, num] =>
adam@1780 851 (case Int.fromString num of
adam@1780 852 NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
adam@1780 853 | SOME n =>
adam@1780 854 if n < 0 then
adam@1780 855 ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
adam@1780 856 else
adam@1780 857 Settings.addLimit (class, n))
adam@1780 858 | _ => ErrorMsg.error "invalid 'limit' arguments")
adam@1780 859 | "minHeap" =>
adam@1780 860 (case Int.fromString arg of
adam@1780 861 NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
adam@1780 862 | SOME n => minHeap := n)
vshabanoff@1815 863 | "coreInline" =>
vshabanoff@1815 864 (case Int.fromString arg of
vshabanoff@1815 865 NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'")
vshabanoff@1815 866 | SOME n => Settings.setCoreInline n)
vshabanoff@1815 867 | "monoInline" =>
vshabanoff@1815 868 (case Int.fromString arg of
vshabanoff@1815 869 NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'")
vshabanoff@1815 870 | SOME n => Settings.setMonoInline n)
adam@1780 871 | "alwaysInline" => Settings.addAlwaysInline arg
adam@1966 872 | "neverInline" => Settings.addNeverInline arg
adam@1780 873 | "noXsrfProtection" => Settings.addNoXsrfProtection arg
adam@1780 874 | "timeFormat" => Settings.setTimeFormat arg
adam@1953 875 | "noMangleSql" => Settings.setMangleSql false
adam@1956 876 | "html5" => Settings.setIsHtml5 true
adam@2010 877 | "lessSafeFfi" => Settings.setLessSafeFfi true
adamc@794 878
adam@1780 879 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
adam@1780 880 read ()
adam@1780 881 end
adamc@794 882
adam@1780 883 val job = if hasBlankLine then
adam@1780 884 read ()
adam@1780 885 else
adam@1780 886 finish (readSources [])
adam@1780 887 in
adam@1780 888 TextIO.closeIn inf;
adam@1780 889 institutionalizeJob job;
adam@1780 890 job
adam@1780 891 end
adam@1780 892 in
adam@1780 893 {Job = pu fname, Libs = !bigLibs}
adam@1780 894 end)
adamc@767 895
adamc@1082 896 fun p_job' {Job = j, Libs = _ : string list} = p_job j
adamc@1082 897
adamc@270 898 val parseUrp = {
adamc@1083 899 func = #Job o parseUrp' true,
adamc@270 900 print = p_job
adamc@270 901 }
adamc@270 902
adamc@1082 903 val parseUrp' = {
adamc@1083 904 func = parseUrp' false,
adamc@1082 905 print = p_job'
adamc@1082 906 }
adamc@1082 907
adamc@270 908 val toParseJob = transform parseUrp "parseJob"
adamc@1082 909 val toParseJob' = transform parseUrp' "parseJob'"
adamc@1082 910
adamc@1082 911 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
adamc@1082 912 func = fn input => case #func tr1 input of
adamc@1082 913 NONE => NONE
adamc@1082 914 | SOME v => #func tr2 v,
adamc@1082 915 print = #print tr2,
adamc@1082 916 time = fn (input, pmap) => let
adamc@1082 917 val (ro, pmap) = #time tr1 (input, pmap)
adamc@1082 918 in
adamc@1082 919 case ro of
adamc@1082 920 NONE => (NONE, pmap)
adamc@1082 921 | SOME v => #time tr2 (v, pmap)
adamc@1082 922 end
adamc@1082 923 }
adamc@270 924
adamc@1090 925 structure SM = BinaryMapFn(struct
adamc@1090 926 type ord_key = string
adamc@1090 927 val compare = String.compare
adamc@1090 928 end)
adamc@1090 929
adamc@1090 930 val moduleRoots = ref ([] : (string * string) list)
adam@1868 931 fun addModuleRoot (k, v) = moduleRoots :=
adam@1868 932 (OS.Path.mkAbsolute {path = k,
adam@1868 933 relativeTo = OS.FileSys.getDir ()},
adam@1868 934 v) :: !moduleRoots
adamc@1090 935
adam@1743 936 structure SK = struct
adam@1743 937 type ord_key = string
adam@1743 938 val compare = String.compare
adam@1743 939 end
adam@1743 940
adam@1743 941 structure SS = BinarySetFn(SK)
adam@1743 942 structure SM = BinaryMapFn(SK)
adamc@1090 943
adam@1773 944 exception MissingFile of string
adam@1773 945
adamc@201 946 val parse = {
adam@1294 947 func = fn {database, sources = fnames, ffi, onError, ...} : job =>
adamc@201 948 let
adamc@1090 949 val mrs = !moduleRoots
adamc@1090 950
adamc@834 951 val anyErrors = ref false
adamc@834 952 fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
adam@1343 953 fun nameOf fname =
adam@1343 954 let
adam@1343 955 val fname = OS.Path.file fname
adam@1343 956 val fst = if size fname = 0 then #"!" else String.sub (fname, 0)
adam@1343 957 in
adam@1343 958 if not (Char.isAlpha fst) then
adam@1343 959 ErrorMsg.error ("Filename doesn't start with letter: " ^ fname)
adam@1343 960 else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then
adam@1343 961 ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname)
adam@1343 962 else
adam@1343 963 ();
adam@1343 964 capitalize fname
adam@1343 965 end
adamc@109 966
adamc@764 967 fun parseFfi fname =
adamc@764 968 let
adamc@764 969 val mname = nameOf fname
adamc@764 970 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@764 971
adamc@764 972 val loc = {file = urs,
adamc@764 973 first = ErrorMsg.dummyPos,
adamc@764 974 last = ErrorMsg.dummyPos}
adamc@764 975
adamc@764 976 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
adamc@764 977 in
adamc@834 978 checkErrors ();
adam@1733 979 (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc)
adamc@764 980 end
adamc@764 981
adamc@1090 982 val defed = ref SS.empty
adamc@1092 983 val fulls = ref SS.empty
adamc@1090 984
adamc@201 985 fun parseOne fname =
adamc@201 986 let
adamc@201 987 val mname = nameOf fname
adamc@244 988 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
adamc@244 989 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
adamc@56 990
adam@1773 991 val () = if Posix.FileSys.access (ur, []) then
adam@1773 992 ()
adam@1773 993 else
adam@1773 994 raise MissingFile ur
adam@1773 995
adamc@201 996 val sgnO =
adamc@244 997 if Posix.FileSys.access (urs, []) then
adamc@244 998 SOME (Source.SgnConst (#func parseUrs urs),
adamc@244 999 {file = urs,
adamc@201 1000 first = ErrorMsg.dummyPos,
adamc@201 1001 last = ErrorMsg.dummyPos})
adamc@834 1002 before checkErrors ()
adamc@201 1003 else
adamc@201 1004 NONE
adamc@56 1005
adamc@244 1006 val loc = {file = ur,
adamc@201 1007 first = ErrorMsg.dummyPos,
adamc@201 1008 last = ErrorMsg.dummyPos}
adamc@56 1009
adam@1738 1010 val urt = OS.FileSys.modTime ur
adam@1738 1011 val urst = (OS.FileSys.modTime urs) handle _ => urt
adam@1738 1012
adamc@244 1013 val ds = #func parseUr ur
adam@1738 1014 val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
adam@1868 1015 (Source.StrConst ds, loc), false), loc)
adamc@1090 1016
adamc@1126 1017 val fname = OS.Path.mkCanonical fname
adamc@1090 1018 val d = case List.find (fn (root, name) =>
adamc@1090 1019 String.isPrefix (root ^ "/") fname) mrs of
adamc@1090 1020 NONE => d
adamc@1090 1021 | SOME (root, name) =>
adamc@1090 1022 let
adamc@1090 1023 val fname = String.extract (fname, size root + 1, NONE)
adamc@1090 1024 val pieces = name :: String.tokens (fn ch => ch = #"/") fname
adamc@1090 1025 val pieces = List.filter (fn s => size s > 0
adamc@1090 1026 andalso Char.isAlpha (String.sub (s, 0)))
adamc@1090 1027 pieces
adamc@1090 1028 val pieces = map capitalize pieces
adamc@1092 1029 val full = String.concatWith "." pieces
adamc@1090 1030
adam@1868 1031 fun makeD first prefix pieces =
adamc@1090 1032 case pieces of
adamc@1090 1033 [] => (ErrorMsg.error "Empty module path";
adamc@1090 1034 (Source.DStyle "Boo", loc))
adamc@1090 1035 | [_] => d
adamc@1090 1036 | piece :: pieces =>
adamc@1090 1037 let
adamc@1146 1038 val this = case prefix of
adamc@1146 1039 "" => piece
adamc@1146 1040 | _ => prefix ^ "." ^ piece
adamc@1090 1041 val old = SS.member (!defed, this)
adamc@1146 1042
adamc@1146 1043 fun notThere (ch, s) =
adamc@1146 1044 Substring.isEmpty (#2 (Substring.splitl
adamc@1146 1045 (fn ch' => ch' <> ch) s))
adamc@1146 1046
adamc@1146 1047 fun simOpen () =
adamc@1146 1048 SS.foldl (fn (full, ds) =>
adamc@1146 1049 if String.isPrefix (this ^ ".") full
adamc@1146 1050 andalso notThere (#".",
adamc@1146 1051 Substring.extract (full,
adamc@1146 1052 size
adamc@1146 1053 this + 1,
adamc@1146 1054 NONE)) then
adamc@1146 1055 let
adamc@1146 1056 val parts = String.tokens
adamc@1146 1057 (fn ch => ch = #".") full
adamc@1146 1058
adamc@1146 1059 val part = List.last parts
adamc@1146 1060
adamc@1146 1061 val imp = if length parts >= 2 then
adamc@1146 1062 (Source.StrProj
adamc@1146 1063 ((Source.StrVar
adamc@1146 1064 (List.nth (parts,
adamc@1146 1065 length
adamc@1146 1066 parts
adamc@1146 1067 - 2)),
adamc@1146 1068 loc),
adamc@1146 1069 part), loc)
adamc@1146 1070 else
adamc@1146 1071 (Source.StrVar part, loc)
adamc@1146 1072 in
adam@1868 1073 (Source.DStr (part, NONE, NONE, imp, false),
adamc@1146 1074 loc) :: ds
adamc@1146 1075 end
adamc@1146 1076 else
adamc@1146 1077 ds) [] (!fulls)
adamc@1090 1078 in
adamc@1090 1079 defed := SS.add (!defed, this);
adam@1732 1080 (Source.DStr (piece, NONE, NONE,
adamc@1090 1081 (Source.StrConst (if old then
adamc@1146 1082 simOpen ()
adam@1868 1083 @ [makeD false this pieces]
adamc@1090 1084 else
adam@1868 1085 [makeD false this pieces]),
adam@1868 1086 loc), first andalso old),
adamc@1090 1087 loc)
adamc@1090 1088 end
adamc@1090 1089 in
adamc@1092 1090 if SS.member (!fulls, full) then
adamc@1092 1091 ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
adamc@1092 1092 else
adamc@1092 1093 ();
adamc@1146 1094
adam@1868 1095 makeD true "" pieces
adamc@1146 1096 before ignore (foldl (fn (new, path) =>
adamc@1146 1097 let
adamc@1146 1098 val new' = case path of
adamc@1146 1099 "" => new
adamc@1146 1100 | _ => path ^ "." ^ new
adamc@1146 1101 in
adamc@1146 1102 fulls := SS.add (!fulls, new');
adamc@1146 1103 new'
adamc@1146 1104 end) "" pieces)
adamc@1090 1105 end
adamc@201 1106 in
adamc@834 1107 checkErrors ();
adamc@1090 1108 d
adam@1773 1109 end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
adam@1773 1110 (Source.DSequence "", ErrorMsg.dummySpan))
adamc@56 1111
adamc@764 1112 val dsFfi = map parseFfi ffi
adamc@201 1113 val ds = map parseOne fnames
adamc@1090 1114 val loc = ErrorMsg.dummySpan
adamc@201 1115 in
adamc@834 1116 if !anyErrors then
adamc@834 1117 ErrorMsg.error "Parse failure"
adamc@834 1118 else
adamc@834 1119 ();
adamc@834 1120
adamc@201 1121 let
adamc@1126 1122 val final = List.last fnames
adamc@1126 1123 val final = case List.find (fn (root, name) =>
adamc@1126 1124 String.isPrefix (root ^ "/") final) mrs of
adamc@1126 1125 NONE => (Source.StrVar (nameOf final), loc)
adamc@1126 1126 | SOME (root, name) =>
adamc@1126 1127 let
adamc@1126 1128 val m = (Source.StrVar name, loc)
adamc@1126 1129 val final = String.extract (final, size root + 1, NONE)
adamc@1264 1130 val fields = String.fields (fn ch => ch = #"/") final
adamc@1264 1131 val fields = List.filter (fn s => size s = 0
adamc@1264 1132 orelse not (Char.isDigit (String.sub (s, 0))))
adamc@1264 1133 fields
adamc@1126 1134 in
adamc@1126 1135 foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc))
adamc@1264 1136 m fields
adamc@1126 1137 end
adamc@271 1138
adamc@764 1139 val ds = dsFfi @ ds
adamc@1126 1140 @ [(Source.DExport final, loc)]
adamc@1090 1141
adamc@1090 1142 val ds = case database of
adamc@1090 1143 NONE => ds
adamc@1090 1144 | SOME s => (Source.DDatabase s, loc) :: ds
adam@1294 1145
adam@1294 1146 val ds = case onError of
adam@1294 1147 NONE => ds
adam@1294 1148 | SOME v => ds @ [(Source.DOnError v, loc)]
adam@1868 1149
adam@1868 1150 fun dummy fname = {file = Settings.libFile fname,
adam@1868 1151 first = ErrorMsg.dummyPos,
adam@1868 1152 last = ErrorMsg.dummyPos}
adam@1868 1153
adam@1868 1154 val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
adam@1868 1155 val used = SM.insert (used, "Top", dummy "top.urs")
adamc@201 1156 in
adam@1738 1157 ignore (List.foldl (fn (d, used) =>
adam@1738 1158 case #1 d of
adam@1868 1159 Source.DStr (x, _, _, _, false) =>
adam@1743 1160 (case SM.find (used, x) of
adam@1743 1161 SOME loc =>
adam@1743 1162 (ErrorMsg.error ("Duplicate top-level module name " ^ x);
adam@1743 1163 Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)),
adam@1743 1164 ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))];
adam@1743 1165 used)
adam@1743 1166 | NONE =>
adam@1743 1167 SM.insert (used, x, #2 d))
adam@1868 1168 | _ => used) used ds);
adamc@1090 1169 ds
adamc@201 1170 end handle Empty => ds
adamc@201 1171 end,
adamc@201 1172 print = SourcePrint.p_file
adamc@201 1173 }
adamc@56 1174
adamc@270 1175 val toParse = transform parse "parse" o toParseJob
adamc@38 1176
adamc@201 1177 val elaborate = {
adamc@201 1178 func = fn file => let
ezyang@1739 1179 val basisF = Settings.libFile "basis.urs"
ezyang@1739 1180 val topF = Settings.libFile "top.urs"
ezyang@1739 1181 val topF' = Settings.libFile "top.ur"
adam@1732 1182
adam@1732 1183 val basis = #func parseUrs basisF
adam@1732 1184 val topSgn = #func parseUrs topF
adam@1732 1185 val topStr = #func parseUr topF'
adam@1732 1186
adam@1732 1187 val tm1 = OS.FileSys.modTime topF
adam@1732 1188 val tm2 = OS.FileSys.modTime topF'
adamc@201 1189 in
adam@1732 1190 Elaborate.elabFile basis (OS.FileSys.modTime basisF)
adam@1732 1191 topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1)
adam@1732 1192 ElabEnv.empty file
adamc@201 1193 end,
adamc@201 1194 print = ElabPrint.p_file ElabEnv.empty
adamc@201 1195 }
adamc@5 1196
adamc@270 1197 val toElaborate = transform elaborate "elaborate" o toParse
adamc@201 1198
adamc@448 1199 val unnest = {
adamc@448 1200 func = Unnest.unnest,
adamc@448 1201 print = ElabPrint.p_file ElabEnv.empty
adamc@448 1202 }
adamc@448 1203
adamc@448 1204 val toUnnest = transform unnest "unnest" o toElaborate
adamc@448 1205
adamc@313 1206 val termination = {
adamc@313 1207 func = (fn file => (Termination.check file; file)),
adamc@313 1208 print = ElabPrint.p_file ElabEnv.empty
adamc@313 1209 }
adamc@313 1210
adamc@448 1211 val toTermination = transform termination "termination" o toUnnest
adamc@313 1212
adamc@201 1213 val explify = {
adamc@201 1214 func = Explify.explify,
adamc@201 1215 print = ExplPrint.p_file ExplEnv.empty
adamc@201 1216 }
adamc@201 1217
adamc@625 1218 val toExplify = transform explify "explify" o toUnnest
adamc@201 1219
adamc@201 1220 val corify = {
adamc@201 1221 func = Corify.corify,
adamc@201 1222 print = CorePrint.p_file CoreEnv.empty
adamc@201 1223 }
adamc@201 1224
adamc@270 1225 val toCorify = transform corify "corify" o toExplify
adamc@201 1226
adamc@482 1227 (*val reduce_local = {
adamc@482 1228 func = ReduceLocal.reduce,
adamc@482 1229 print = CorePrint.p_file CoreEnv.empty
adamc@482 1230 }
adamc@482 1231
adamc@482 1232 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
adamc@482 1233
adamc@443 1234 val especialize = {
adamc@443 1235 func = ESpecialize.specialize,
adamc@443 1236 print = CorePrint.p_file CoreEnv.empty
adamc@443 1237 }
adamc@443 1238
adamc@454 1239 val core_untangle = {
adamc@454 1240 func = CoreUntangle.untangle,
adamc@454 1241 print = CorePrint.p_file CoreEnv.empty
adamc@454 1242 }
adamc@454 1243
adamc@794 1244 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
adamc@454 1245
adamc@202 1246 val shake = {
adamc@202 1247 func = Shake.shake,
adamc@202 1248 print = CorePrint.p_file CoreEnv.empty
adamc@202 1249 }
adamc@39 1250
adamc@454 1251 val toShake1 = transform shake "shake1" o toCore_untangle
adamc@110 1252
adam@1362 1253 val toEspecialize1' = transform especialize "especialize1'" o toShake1
adam@1362 1254 val toShake1' = transform shake "shake1'" o toEspecialize1'
adam@1362 1255
adamc@607 1256 val rpcify = {
adamc@607 1257 func = Rpcify.frob,
adamc@607 1258 print = CorePrint.p_file CoreEnv.empty
adamc@607 1259 }
adamc@607 1260
adam@1362 1261 val toRpcify = transform rpcify "rpcify" o toShake1'
adamc@607 1262
adamc@642 1263 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
adamc@642 1264 val toShake2 = transform shake "shake2" o toCore_untangle2
adamc@1181 1265
adamc@1186 1266 val toEspecialize1 = transform especialize "especialize1" o toShake2
adamc@1181 1267
adamc@1062 1268 val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
adamc@1062 1269 val toShake3 = transform shake "shake3" o toCore_untangle3
adamc@642 1270
adamc@202 1271 val tag = {
adamc@202 1272 func = Tag.tag,
adamc@202 1273 print = CorePrint.p_file CoreEnv.empty
adamc@202 1274 }
adamc@193 1275
adamc@1062 1276 val toTag = transform tag "tag" o toShake3
adamc@20 1277
adamc@202 1278 val reduce = {
adamc@202 1279 func = Reduce.reduce,
adamc@202 1280 print = CorePrint.p_file CoreEnv.empty
adamc@202 1281 }
adamc@25 1282
adamc@692 1283 val toReduce = transform reduce "reduce" o toTag
adamc@23 1284
adamc@1186 1285 val toShakey = transform shake "shakey" o toReduce
adamc@1186 1286
adamc@1186 1287 val unpoly = {
adamc@1186 1288 func = Unpoly.unpoly,
adamc@1186 1289 print = CorePrint.p_file CoreEnv.empty
adamc@1186 1290 }
adamc@1186 1291
adamc@1186 1292 val toUnpoly = transform unpoly "unpoly" o toShakey
adamc@315 1293
adamc@202 1294 val specialize = {
adamc@202 1295 func = Specialize.specialize,
adamc@202 1296 print = CorePrint.p_file CoreEnv.empty
adamc@202 1297 }
adamc@132 1298
adamc@1186 1299 val toSpecialize = transform specialize "specialize" o toUnpoly
adamc@131 1300
adamc@1062 1301 val toShake4 = transform shake "shake4" o toSpecialize
adamc@133 1302
adamc@1062 1303 val toEspecialize2 = transform especialize "especialize2" o toShake4
adamc@1272 1304 val toShake4' = transform shake "shake4'" o toEspecialize2
adamc@1272 1305 val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
adamc@1276 1306 val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
adamc@1276 1307 val toShake4'' = transform shake "shake4'" o toSpecialize2
adamc@1272 1308 val toEspecialize3 = transform especialize "especialize3" o toShake4''
adamc@794 1309
adamc@1272 1310 val toReduce2 = transform reduce "reduce2" o toEspecialize3
adamc@898 1311
adamc@1062 1312 val toShake5 = transform shake "shake5" o toReduce2
adamc@794 1313
adamc@692 1314 val marshalcheck = {
adamc@692 1315 func = (fn file => (MarshalCheck.check file; file)),
adamc@692 1316 print = CorePrint.p_file CoreEnv.empty
adamc@692 1317 }
adamc@692 1318
adamc@1062 1319 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5
adamc@692 1320
adamc@732 1321 val effectize = {
adamc@732 1322 func = Effective.effectize,
adamc@732 1323 print = CorePrint.p_file CoreEnv.empty
adamc@732 1324 }
adamc@732 1325
adamc@732 1326 val toEffectize = transform effectize "effectize" o toMarshalcheck
adamc@732 1327
adamc@1170 1328 val css = {
adamc@1170 1329 func = Css.summarize,
adamc@1170 1330 print = fn _ => Print.box []
adamc@1170 1331 }
adamc@1170 1332
adamc@1170 1333 val toCss = transform css "css" o toShake5
adamc@1170 1334
adamc@202 1335 val monoize = {
adamc@202 1336 func = Monoize.monoize CoreEnv.empty,
adamc@202 1337 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1338 }
adamc@134 1339
adamc@732 1340 val toMonoize = transform monoize "monoize" o toEffectize
adamc@96 1341
adamc@202 1342 val mono_opt = {
adamc@910 1343 func = MonoOpt.optimize,
adamc@202 1344 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1345 }
adamc@29 1346
adamc@270 1347 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
adamc@5 1348
adamc@202 1349 val untangle = {
adamc@202 1350 func = Untangle.untangle,
adamc@202 1351 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1352 }
adamc@1 1353
adamc@270 1354 val toUntangle = transform untangle "untangle" o toMono_opt1
adamc@38 1355
adamc@202 1356 val mono_reduce = {
adamc@202 1357 func = MonoReduce.reduce,
adamc@202 1358 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1359 }
adamc@16 1360
adamc@270 1361 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
adamc@39 1362
adamc@202 1363 val mono_shake = {
adamc@202 1364 func = MonoShake.shake,
adamc@202 1365 print = MonoPrint.p_file MonoEnv.empty
adamc@202 1366 }
adamc@110 1367
adamc@270 1368 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
adamc@193 1369
adamc@572 1370 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
adamc@572 1371
adamc@1200 1372 val iflow = {
adamc@1235 1373 func = (fn file => (if !doIflow then Iflow.check file else (); file)),
adamc@1200 1374 print = MonoPrint.p_file MonoEnv.empty
adamc@1200 1375 }
adamc@1200 1376
adamc@1200 1377 val toIflow = transform iflow "iflow" o toMono_opt2
adamc@1200 1378
adam@1800 1379 val namejs = {
adam@1800 1380 func = NameJS.rewrite,
adam@1800 1381 print = MonoPrint.p_file MonoEnv.empty
adam@1800 1382 }
adam@1800 1383
adam@1800 1384 val toNamejs = transform namejs "namejs" o toIflow
adam@1800 1385
adam@1800 1386 val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
adam@1800 1387
adam@1845 1388 val scriptcheck = {
adam@1845 1389 func = ScriptCheck.classify,
adam@1845 1390 print = MonoPrint.p_file MonoEnv.empty
adam@1845 1391 }
adam@1845 1392
adam@1845 1393 val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
adam@1845 1394
adamc@567 1395 val jscomp = {
adamc@567 1396 func = JsComp.process,
adamc@567 1397 print = MonoPrint.p_file MonoEnv.empty
adamc@567 1398 }
adamc@567 1399
adam@1845 1400 val toJscomp = transform jscomp "jscomp" o toScriptcheck
adamc@567 1401
adamc@910 1402 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
adamc@20 1403
adamc@506 1404 val fuse = {
adamc@506 1405 func = Fuse.fuse,
adamc@506 1406 print = MonoPrint.p_file MonoEnv.empty
adamc@506 1407 }
adamc@506 1408
adamc@572 1409 val toFuse = transform fuse "fuse" o toMono_opt3
adamc@506 1410
adamc@506 1411 val toUntangle2 = transform untangle "untangle2" o toFuse
adamc@506 1412
adamc@601 1413 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
adamc@601 1414 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
adamc@916 1415 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
adamc@1017 1416 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
adamc@1185 1417 val toFuse2 = transform fuse "fuse2" o toMono_reduce3
adamc@916 1418 val toUntangle3 = transform untangle "untangle3" o toFuse2
adamc@916 1419 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
adamc@506 1420
adamc@377 1421 val pathcheck = {
adamc@377 1422 func = (fn file => (PathCheck.check file; file)),
adamc@377 1423 print = MonoPrint.p_file MonoEnv.empty
adamc@377 1424 }
adamc@377 1425
adamc@916 1426 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3
adamc@377 1427
adam@1595 1428 val sidecheck = {
adam@1595 1429 func = SideCheck.check,
adam@1595 1430 print = MonoPrint.p_file MonoEnv.empty
adam@1595 1431 }
adam@1595 1432
adam@1595 1433 val toSidecheck = transform sidecheck "sidecheck" o toPathcheck
adam@1595 1434
adam@1856 1435 val sigcheck = {
adam@1856 1436 func = SigCheck.check,
adam@1856 1437 print = MonoPrint.p_file MonoEnv.empty
adam@1856 1438 }
adam@1856 1439
adam@1856 1440 val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
adam@1856 1441
adamc@202 1442 val cjrize = {
adamc@202 1443 func = Cjrize.cjrize,
adamc@202 1444 print = CjrPrint.p_file CjrEnv.empty
adamc@202 1445 }
adamc@23 1446
adam@1856 1447 val toCjrize = transform cjrize "cjrize" o toSigcheck
adamc@29 1448
adamc@282 1449 val prepare = {
adamc@282 1450 func = Prepare.prepare,
adamc@282 1451 print = CjrPrint.p_file CjrEnv.empty
adamc@282 1452 }
adamc@282 1453
adam@1845 1454 val toPrepare = transform prepare "prepare" o toCjrize
adamc@282 1455
adamc@879 1456 val checknest = {
adamc@879 1457 func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
adamc@879 1458 print = CjrPrint.p_file CjrEnv.empty
adamc@879 1459 }
adamc@879 1460
adamc@879 1461 val toChecknest = transform checknest "checknest" o toPrepare
adamc@879 1462
adamc@274 1463 val sqlify = {
adamc@274 1464 func = Cjrize.cjrize,
adamc@274 1465 print = CjrPrint.p_sql CjrEnv.empty
adamc@274 1466 }
adamc@274 1467
adamc@274 1468 val toSqlify = transform sqlify "sqlify" o toMono_opt2
adamc@274 1469
adam@1473 1470 val escapeFilename = String.translate (fn #" " => "\\ " | #"\"" => "\\\"" | #"'" => "\\'" | ch => str ch)
adam@1473 1471
adam@1540 1472 val beforeC = ref (fn () => ())
adam@1540 1473
adam@1822 1474 structure StringSet = BinarySetFn(struct
adam@1822 1475 type ord_key = string
adam@1822 1476 val compare = String.compare
adam@1822 1477 end)
adam@1822 1478
adam@1725 1479 fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} =
adamc@183 1480 let
adamc@855 1481 val proto = Settings.currentProtocol ()
adamc@1095 1482
adam@1368 1483 val lib = if Settings.getStaticLinking () then
adam@1846 1484 " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a"
adam@1368 1485 else
ezyang@1739 1486 "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb"
adamc@378 1487
adam@1558 1488 val opt = if debug then
adam@1558 1489 ""
adam@1558 1490 else
adam@1558 1491 " -O3"
adam@1558 1492
grrwlf@1871 1493 val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value"
ezyang@1739 1494 ^ opt ^ " -I " ^ !Settings.configInclude
adamc@1096 1495 ^ " " ^ #compile proto
adam@1473 1496 ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname
adamc@1096 1497
grrwlf@1871 1498 val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs)
adam@1725 1499
adam@1846 1500 val ssl = if Settings.getStaticLinking () then
adam@1846 1501 Config.openssl ^ " -ldl -lz"
adam@1846 1502 else
adam@1846 1503 Config.openssl
adam@1846 1504
adam@1725 1505 val link = linker
andersk@1893 1506 ^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename
adamc@502 1507
adamc@502 1508 val (compile, link) =
adamc@502 1509 if profile then
adamc@502 1510 (compile ^ " -pg", link ^ " -pg")
adamc@502 1511 else
adamc@502 1512 (compile, link)
adamc@742 1513
adamc@742 1514 val (compile, link) =
adamc@742 1515 if debug then
adamc@742 1516 (compile ^ " -g", link ^ " -g")
adamc@742 1517 else
adamc@742 1518 (compile, link)
adamc@764 1519
adam@1822 1520 val link = #1 (foldl
adam@1822 1521 (fn (s, (link, set)) =>
adam@1822 1522 if StringSet.member (set, s) then
adam@1822 1523 (link, set)
adam@1822 1524 else
adam@1822 1525 ((link ^ " " ^ s), StringSet.add (set, s)))
adam@1822 1526 (link, StringSet.empty)
adam@1822 1527 link')
adam@1394 1528
adam@1394 1529 fun system s =
adam@1394 1530 (if debug then
adam@1394 1531 print (s ^ "\n")
adam@1394 1532 else
adam@1394 1533 ();
adam@1394 1534 OS.Process.isSuccess (OS.Process.system s))
adamc@183 1535 in
adam@1540 1536 !beforeC ();
adam@1394 1537 system compile andalso system link
adamc@183 1538 end
adamc@183 1539
adamc@202 1540 fun compile job =
adamc@879 1541 case run toChecknest job of
adamc@1045 1542 NONE => false
adamc@29 1543 | SOME file =>
adamc@202 1544 let
adamc@274 1545 val job = valOf (run (transform parseUrp "parseUrp") job)
adamc@102 1546
adamc@274 1547 val (cname, oname, cleanup) =
adamc@274 1548 if #debug job then
adamc@457 1549 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
adamc@274 1550 else
adamc@274 1551 let
adamc@274 1552 val dir = OS.FileSys.tmpName ()
adamc@403 1553 val () = if OS.FileSys.access (dir, []) then
adamc@403 1554 OS.FileSys.remove dir
adamc@403 1555 else
adamc@403 1556 ()
adamc@457 1557 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
adamc@457 1558 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
adamc@274 1559 in
adamc@274 1560 OS.FileSys.mkDir dir;
adamc@274 1561 (cname, oname,
adam@1700 1562 fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then
adam@1700 1563 ()
adam@1700 1564 else
adam@1700 1565 raise Fail ("Unable to delete temporary directory " ^ dir)))
adamc@274 1566 end
adamc@274 1567 val ename = #exe job
adamc@202 1568 in
adamc@274 1569 let
adamc@274 1570 val outf = TextIO.openOut cname
adamc@274 1571 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@432 1572
adamc@432 1573 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
adamc@432 1574 val libs =
adamc@432 1575 if hasDb then
adamc@866 1576 #link (Settings.currentDbms ())
adamc@432 1577 else
adamc@432 1578 ""
adamc@274 1579 in
adamc@274 1580 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
adamc@415 1581 TextIO.output1 (outf, #"\n");
adamc@274 1582 TextIO.closeOut outf;
adamc@102 1583
adam@1381 1584 if ErrorMsg.anyErrors () then
adam@1381 1585 false
adam@1381 1586 else
adam@1381 1587 (case #sql job of
adam@1381 1588 NONE => ()
adam@1381 1589 | SOME sql =>
adam@1381 1590 let
adam@1381 1591 val outf = TextIO.openOut sql
adam@1381 1592 val s = TextIOPP.openOut {dst = outf, wid = 80}
adam@1381 1593 in
adam@1381 1594 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
adam@1381 1595 TextIO.closeOut outf
adam@1381 1596 end;
adamc@274 1597
adam@1381 1598 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
adam@1725 1599 profile = #profile job, debug = #debug job, linker = #linker job, link = #link job}
adam@1381 1600
adam@1381 1601 before cleanup ())
adamc@274 1602 end
adamc@274 1603 handle ex => (((cleanup ()) handle _ => ()); raise ex)
adamc@202 1604 end
adamc@29 1605
adamc@1045 1606 fun compiler job =
adamc@1045 1607 if compile job then
adamc@1045 1608 ()
adamc@1045 1609 else
adamc@1045 1610 OS.Process.exit OS.Process.failure
adamc@1045 1611
adamc@1266 1612 fun moduleOf fname =
adamc@1266 1613 let
adamc@1266 1614 val mrs = !moduleRoots
adamc@1266 1615 val fname = OS.Path.mkCanonical fname
adamc@1266 1616 in
adamc@1266 1617 case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
adamc@1266 1618 NONE => capitalize (OS.Path.base (OS.Path.file fname))
adamc@1266 1619 | SOME (root, name) =>
adamc@1266 1620 let
adamc@1266 1621 val fname = OS.Path.base fname
adamc@1266 1622 val fname = String.extract (fname, size root + 1, NONE)
adamc@1266 1623 val fs = String.fields (fn ch => ch = #"/") fname
adamc@1266 1624 val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
adamc@1266 1625 val fs = map capitalize fs
adamc@1266 1626 in
adamc@1266 1627 String.concatWith "." (name :: fs)
adamc@1266 1628 end
adamc@1266 1629 end
adamc@1266 1630
adamc@1 1631 end