Mercurial > urweb

annotate src/compiler.sml @ 1726:4df4521fbd3b

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