Mercurial > urweb

annotate src/compiler.sml @ 1183:9d3ccb8b39ac

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