Mercurial > urweb

annotate src/compiler.sml @ 1866:9fc086e3c95a

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