Mercurial > urweb

annotate src/compiler.sml @ 1739:c414850f206f

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