Mercurial > urweb

annotate src/compiler.sml @ 1657:2b7d3d99dc42

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