Mercurial > urweb

annotate src/compiler.sml @ 1380:ede95ecb4000

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