adam@1677: (* Copyright (c) 2008-2012, Adam Chlipala adamc@1: * All rights reserved. adamc@1: * adamc@1: * Redistribution and use in source and binary forms, with or without adamc@1: * modification, are permitted provided that the following conditions are met: adamc@1: * adamc@1: * - Redistributions of source code must retain the above copyright notice, adamc@1: * this list of conditions and the following disclaimer. adamc@1: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1: * this list of conditions and the following disclaimer in the documentation adamc@1: * and/or other materials provided with the distribution. adamc@1: * - The names of contributors may not be used to endorse or promote products adamc@1: * derived from this software without specific prior written permission. adamc@1: * adamc@1: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1: * POSSIBILITY OF SUCH DAMAGE. adamc@1: *) adamc@1: adamc@1: structure Compiler :> COMPILER = struct adamc@1: adamc@244: structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) adamc@244: structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) adamc@244: structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData adamc@1: structure Lex = Lex adamc@1: structure LrParser = LrParser) adamc@1: adamc@270: type job = { adamc@385: prefix : string, adamc@270: database : string option, adamc@274: sources : string list, adamc@274: exe : string, adamc@274: sql : string option, adamc@502: debug : bool, adamc@673: profile : bool, adamc@764: timeout : int, adamc@764: ffi : string list, adamc@764: link : string list, adam@1725: linker : string option, adamc@765: headers : string list, adamc@766: scripts : string list, adamc@765: clientToServer : Settings.ffi list, adamc@765: effectful : Settings.ffi list, adamc@1171: benignEffectful : Settings.ffi list, adamc@765: clientOnly : Settings.ffi list, adamc@765: serverOnly : Settings.ffi list, adamc@768: jsFuncs : (Settings.ffi * string) list, adamc@769: rewrites : Settings.rewrite list, adamc@769: filterUrl : Settings.rule list, adamc@866: filterMime : Settings.rule list, adam@1465: filterRequest : Settings.rule list, adam@1465: filterResponse : Settings.rule list, adam@1799: filterEnv : Settings.rule list, adamc@866: protocol : string option, adamc@1164: dbms : string option, adamc@1183: sigFile : string option, adam@1294: safeGets : string list, adam@1332: onError : (string * string list * string) option, adam@1332: minHeap : int adamc@270: } adamc@201: adamc@201: type ('src, 'dst) phase = { adamc@201: func : 'src -> 'dst, adamc@201: print : 'dst -> Print.PD.pp_desc adamc@201: } adamc@201: adamc@201: type pmap = (string * Time.time) list adamc@201: adamc@201: type ('src, 'dst) transform = { adamc@201: func : 'src -> 'dst option, adamc@201: print : 'dst -> Print.PD.pp_desc, adamc@201: time : 'src * pmap -> 'dst option * pmap adamc@201: } adamc@201: adamc@1079: val debug = ref false adam@1677: val dumpSource = ref false adamc@1240: val doIflow = ref false adamc@1079: adam@1677: val doDumpSource = ref (fn () => ()) adam@1677: adam@1961: val stop = ref (NONE : string option) adam@1961: fun setStop s = stop := SOME s adam@1961: adamc@201: fun transform (ph : ('src, 'dst) phase) name = { adamc@201: func = fn input => let adamc@1079: val () = if !debug then adamc@1079: print ("Starting " ^ name ^ "....\n") adamc@1079: else adamc@1079: () adamc@201: val v = #func ph input adamc@201: in adamc@1079: if !debug then adamc@1079: print ("Finished " ^ name ^ ".\n") adamc@1079: else adamc@1079: (); adamc@201: if ErrorMsg.anyErrors () then adam@1677: (!doDumpSource (); adam@1677: doDumpSource := (fn () => ()); adam@1677: NONE) adam@1961: else if !stop = SOME name then adam@1961: (Print.eprint (#print ph v); adam@1961: ErrorMsg.error ("Stopped compilation after phase " ^ name); adam@1961: NONE) adamc@201: else adam@1677: (if !dumpSource then adam@1677: doDumpSource := (fn () => Print.eprint (#print ph v)) adam@1677: else adam@1677: (); adam@1677: SOME v) adamc@201: end, adamc@201: print = #print ph, adamc@201: time = fn (input, pmap) => let adamc@1186: val () = if !debug then adamc@1186: print ("Starting " ^ name ^ "....\n") adamc@1186: else adamc@1186: () adamc@201: val befor = Time.now () adamc@201: val v = #func ph input adamc@201: val elapsed = Time.- (Time.now (), befor) adamc@201: in adamc@1186: if !debug then adamc@1186: print ("Finished " ^ name ^ ".\n") adamc@1186: else adamc@1186: (); adamc@201: (if ErrorMsg.anyErrors () then adamc@201: NONE adamc@201: else adamc@201: SOME v, adamc@201: (name, elapsed) :: pmap) adamc@201: end adamc@201: } adamc@201: adamc@346: fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); adamc@346: ignore (#func tr x)) adamc@346: adamc@280: fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); adamc@280: #func tr x) adamc@201: adamc@201: fun runPrint (tr : ('src, 'dst) transform) input = adamc@280: (ErrorMsg.resetErrors (); adamc@280: case #func tr input of adamc@280: NONE => print "Failure\n" adamc@280: | SOME v => adamc@280: (print "Success\n"; adamc@280: Print.print (#print tr v); adamc@280: print "\n")) adamc@201: adam@1362: fun runPrintToFile (tr : ('src, 'dst) transform) input fname = adam@1362: (ErrorMsg.resetErrors (); adam@1362: case #func tr input of adam@1362: NONE => print "Failure\n" adam@1362: | SOME v => adam@1362: let adam@1362: val outf = TextIO.openOut fname adam@1362: val str = Print.openOut {dst = outf, wid = 80} adam@1362: in adam@1362: print "Success\n"; adam@1362: Print.fprint str (#print tr v); adam@1362: Print.PD.PPS.closeStream str; adam@1362: TextIO.closeOut outf adam@1362: end) adam@1362: adamc@201: fun time (tr : ('src, 'dst) transform) input = adamc@55: let adamc@201: val (_, pmap) = #time tr (input, []) adamc@201: in adamc@201: app (fn (name, time) => adamc@201: print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); adamc@201: print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); adamc@201: print "\n" adamc@201: end adamc@55: adamc@201: fun timePrint (tr : ('src, 'dst) transform) input = adamc@201: let adamc@201: val (ro, pmap) = #time tr (input, []) adamc@55: in adamc@201: app (fn (name, time) => adamc@201: print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); adamc@201: print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); adamc@201: print "\n"; adamc@201: case ro of adamc@201: NONE => print "Failure\n" adamc@201: | SOME v => adamc@201: (print "Success\n"; adamc@201: Print.print (#print tr v); adamc@201: print "\n") adamc@55: end adamc@55: adam@1362: fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input = adam@1362: (ErrorMsg.resetErrors (); adam@1362: case #func tr input of adam@1362: NONE => print "Failure\n" adam@1362: | SOME file => adam@1362: (print "Success\n"; adam@1362: app (fn (d, _) => adam@1362: case d of adam@1362: Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t) adam@1362: | Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts adam@1362: | _ => ()) file)) adam@1362: adamc@244: val parseUrs = adamc@201: {func = fn filename => let adamc@201: val fname = OS.FileSys.tmpName () adamc@201: val outf = TextIO.openOut fname adamc@201: val () = TextIO.output (outf, "sig\n") adamc@201: val inf = TextIO.openIn filename adamc@201: fun loop () = adamc@201: case TextIO.inputLine inf of adamc@201: NONE => () adamc@201: | SOME line => (TextIO.output (outf, line); adamc@201: loop ()) adamc@201: val () = loop () adamc@201: val () = TextIO.closeIn inf adamc@201: val () = TextIO.closeOut outf adamc@201: adamc@201: val () = (ErrorMsg.resetErrors (); adamc@201: ErrorMsg.resetPositioning filename; adamc@201: Lex.UserDeclarations.initialize ()) adamc@201: val file = TextIO.openIn fname adamc@201: fun get _ = TextIO.input file adamc@201: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@201: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@244: val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) adamc@201: in adamc@201: TextIO.closeIn file; adamc@201: case absyn of adamc@201: [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis adamc@201: | _ => (ErrorMsg.errorAt {file = filename, adamc@201: first = {line = 0, adamc@201: char = 0}, adamc@201: last = {line = 0, adamc@201: char = 0}} "Not a signature"; adamc@201: []) adamc@201: end adamc@201: handle LrParser.ParseError => [], adamc@201: print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item} adamc@55: adamc@1: (* The main parsing routine *) adamc@244: val parseUr = { adamc@201: func = fn filename => adamc@201: let adamc@201: val () = (ErrorMsg.resetErrors (); adamc@201: ErrorMsg.resetPositioning filename; adamc@201: Lex.UserDeclarations.initialize ()) adamc@201: val file = TextIO.openIn filename adamc@201: fun get _ = TextIO.input file adamc@201: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@201: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@244: val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) adamc@201: in adamc@201: TextIO.closeIn file; adamc@201: case absyn of adamc@201: [(Source.DSgn ("?", _), _)] => adamc@201: (ErrorMsg.errorAt {file = filename, adamc@201: first = {line = 0, adamc@201: char = 0}, adamc@201: last = {line = 0, adamc@201: char = 0}} "File starts with 'sig'"; adamc@201: []) adamc@201: | _ => absyn adamc@201: end adamc@201: handle LrParser.ParseError => [], adamc@201: print = SourcePrint.p_file} adamc@56: adamc@768: fun p_job ({prefix, database, exe, sql, sources, debug, profile, adamc@768: timeout, ffi, link, headers, scripts, adamc@1171: clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) = adamc@270: let adamc@270: open Print.PD adamc@270: open Print adamc@765: adamc@765: fun p_ffi name = p_list_sep (box []) (fn (m, s) => adamc@765: box [string name, space, string m, string ".", string s, newline]) adamc@270: in adamc@274: box [if debug then adamc@274: box [string "DEBUG", newline] adamc@274: else adamc@274: box [], adamc@502: if profile then adamc@502: box [string "PROFILE", newline] adamc@502: else adamc@502: box [], adamc@274: case database of adamc@270: NONE => string "No database." adamc@270: | SOME db => string ("Database: " ^ db), adamc@270: newline, adamc@274: string "Exe: ", adamc@274: string exe, adamc@274: newline, adamc@274: case sql of adamc@274: NONE => string "No SQL file." adamc@274: | SOME sql => string ("SQL fle: " ^ sql), adamc@673: newline, adamc@673: string "Timeout: ", adamc@673: string (Int.toString timeout), adamc@673: newline, adamc@764: p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi, adamc@764: p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers, adamc@766: p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts, adamc@764: p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link, adamc@765: p_ffi "ClientToServer" clientToServer, adamc@765: p_ffi "Effectful" effectful, adamc@1171: p_ffi "BenignEffectful" benignEffectful, adamc@765: p_ffi "ClientOnly" clientOnly, adamc@765: p_ffi "ServerOnly" serverOnly, adamc@765: p_list_sep (box []) (fn ((m, s), s') => adamc@765: box [string "JsFunc", space, string m, string ".", string s, adamc@765: space, string "=", space, string s', newline]) jsFuncs, adamc@270: string "Sources:", adamc@270: p_list string sources, adamc@270: newline] adamc@270: end adamc@270: adamc@270: fun trim s = adamc@270: let adamc@270: val (_, s) = Substring.splitl Char.isSpace s adamc@270: val (s, _) = Substring.splitr Char.isSpace s adamc@270: in adamc@270: s adamc@270: end adamc@270: adam@1433: val trimS = Substring.string o trim o Substring.full adam@1433: adamc@794: structure M = BinaryMapFn(struct adamc@794: type ord_key = string adamc@794: val compare = String.compare adamc@794: end) adamc@794: ezyang@1739: (* XXX ezyang: pathmap gets initialized /really early/, before ezyang@1739: * we do any options parsing. So libUr will always point to the ezyang@1739: * default. We override it explicitly in enableBoot *) ezyang@1739: val pathmap = ref (M.insert (M.empty, "", Settings.libUr ())) adamc@1089: adamc@1089: fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v) adamc@1089: ezyang@1739: (* XXX ezyang: this is not right; it probably doesn't work in ezyang@1739: * the case of separate build and src trees *) ezyang@1739: fun enableBoot () = ezyang@1739: (Settings.configBin := OS.Path.joinDirFile {dir = Config.builddir, file = "bin"}; ezyang@1739: Settings.configSrcLib := OS.Path.joinDirFile {dir = Config.builddir, file = "lib"}; ezyang@1739: (* joinDirFile is annoying... (ArcError; it doesn't like ezyang@1739: * slashes in file) *) ezyang@1739: Settings.configLib := Config.builddir ^ "/src/c/.libs"; ezyang@1739: Settings.configInclude := OS.Path.joinDirFile {dir = Config.builddir ^ "/include", file = "urweb"}; ezyang@1739: Settings.configSitelisp := Config.builddir ^ "/src/elisp"; ezyang@1739: addPath ("", Settings.libUr ())) ezyang@1739: adam@1296: fun capitalize "" = "" adam@1296: | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adam@1296: adam@1296: fun institutionalizeJob (job : job) = adam@1483: (Settings.setDebug (#debug job); adam@1483: Settings.setUrlPrefix (#prefix job); adam@1296: Settings.setTimeout (#timeout job); adam@1296: Settings.setHeaders (#headers job); adam@1296: Settings.setScripts (#scripts job); adam@1296: Settings.setClientToServer (#clientToServer job); adam@1296: Settings.setEffectful (#effectful job); adam@1296: Settings.setBenignEffectful (#benignEffectful job); adam@1296: Settings.setClientOnly (#clientOnly job); adam@1296: Settings.setServerOnly (#serverOnly job); adam@1296: Settings.setJsFuncs (#jsFuncs job); adam@1296: Settings.setRewriteRules (#rewrites job); adam@1296: Settings.setUrlRules (#filterUrl job); adam@1296: Settings.setMimeRules (#filterMime job); adam@1465: Settings.setRequestHeaderRules (#filterRequest job); adam@1465: Settings.setResponseHeaderRules (#filterResponse job); adam@1799: Settings.setEnvVarRules (#filterEnv job); adam@1296: Option.app Settings.setProtocol (#protocol job); adam@1296: Option.app Settings.setDbms (#dbms job); adam@1296: Settings.setSafeGets (#safeGets job); adam@1332: Settings.setOnError (#onError job); adam@1408: Settings.setMinHeap (#minHeap job); adam@1408: Settings.setSigFile (#sigFile job)) adam@1296: adam@1603: datatype commentableLine = adam@1603: EndOfFile adam@1603: | OnlyComment adam@1603: | Content of string adam@1603: adam@1331: fun inputCommentableLine inf = adam@1603: case TextIO.inputLine inf of adam@1603: NONE => EndOfFile adam@1603: | SOME s => adam@1603: let adam@1603: val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s) adam@1603: in adam@1603: if not (Substring.isEmpty after) adam@1603: andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then adam@1603: OnlyComment adam@1603: else adam@1603: let adam@1603: val s = #1 (Substring.splitr (not o Char.isSpace) befor) adam@1603: in adam@1603: Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then adam@1603: if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then adam@1603: Substring.trimr 2 s adam@1603: else adam@1603: Substring.trimr 1 s adam@1603: else adam@1603: s)) adam@1603: end adam@1603: end adam@1331: adam@1780: val lastUrp = ref "" adam@1780: adamc@1082: fun parseUrp' accLibs fname = adam@1780: (if !lastUrp = fname then adam@1780: () adam@1780: else adam@1780: ModDb.reset (); adam@1780: lastUrp := fname; adam@1780: if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) adam@1780: andalso Posix.FileSys.access (fname ^ ".ur", []) then adam@1780: let adam@1780: val job = {prefix = "/", adam@1780: database = NONE, adam@1780: sources = [fname], adam@1780: exe = fname ^ ".exe", adam@1780: sql = NONE, adam@1780: debug = Settings.getDebug (), adam@1780: profile = false, adam@1780: timeout = 60, adam@1780: ffi = [], adam@1780: link = [], adam@1780: linker = NONE, adam@1780: headers = [], adam@1780: scripts = [], adam@1780: clientToServer = [], adam@1780: effectful = [], adam@1780: benignEffectful = [], adam@1780: clientOnly = [], adam@1780: serverOnly = [], adam@1780: jsFuncs = [], adam@1780: rewrites = [{pkind = Settings.Any, adam@1780: kind = Settings.Prefix, adam@1780: from = capitalize (OS.Path.file fname) ^ "/", to = "", adam@1780: hyphenate = false}], adam@1780: filterUrl = [], adam@1780: filterMime = [], adam@1780: filterRequest = [], adam@1780: filterResponse = [], adam@1799: filterEnv = [], adam@1780: protocol = NONE, adam@1780: dbms = NONE, adam@1780: sigFile = NONE, adam@1780: safeGets = [], adam@1780: onError = NONE, adam@1780: minHeap = 0} adam@1780: in adam@1780: institutionalizeJob job; adam@1780: {Job = job, Libs = []} adam@1780: end adam@1780: else adam@1780: let adam@1780: val pathmap = ref (!pathmap) adam@1780: val bigLibs = ref [] adamc@767: adam@1780: fun pu filename = adam@1780: let adam@1780: val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()} adam@1338: adam@1780: val dir = OS.Path.dir filename adam@1780: fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) adamc@1151: adam@1780: val inf = opener () adamc@1151: adam@1780: fun hasSpaceLine () = adam@1780: case inputCommentableLine inf of adam@1780: Content s => s = "debug" orelse s = "profile" adam@1780: orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine () adam@1780: | EndOfFile => false adam@1780: | OnlyComment => hasSpaceLine () adamc@1151: adam@1780: val hasBlankLine = hasSpaceLine () adamc@1151: adam@1780: val inf = (TextIO.closeIn inf; opener ()) adamc@767: adam@1780: fun pathify fname = adam@1780: if size fname > 0 andalso String.sub (fname, 0) = #"$" then adam@1780: let adam@1780: val fname' = Substring.extract (fname, 1, NONE) adam@1780: val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' adam@1780: in adam@1780: case M.find (!pathmap, Substring.string befor) of adam@1780: NONE => fname adam@1780: | SOME rep => rep ^ Substring.string after adam@1780: end adam@1780: else adam@1780: fname adam@1296: adam@1780: fun relify fname = adam@1780: let adam@1780: val fname = pathify fname adam@1780: in adam@1780: OS.Path.concat (dir, fname) adam@1780: handle OS.Path.Path => fname adam@1780: end adamc@767: adam@1780: fun libify path = adam@1780: (if Posix.FileSys.access (path ^ ".urp", []) then adam@1780: path adam@1780: else adam@1780: path ^ "/lib") adam@1780: handle SysErr => path adam@1780: adam@1780: fun libify' path = adam@1780: (if Posix.FileSys.access (relify path ^ ".urp", []) then adam@1780: path adam@1780: else adam@1780: path ^ "/lib") adam@1780: handle SysErr => path adam@1780: adam@1780: val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} adam@1780: adam@1780: fun relifyA fname = adam@1780: OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} adam@1780: adam@1780: fun readSources acc = adam@1780: case inputCommentableLine inf of adam@1780: Content line => adam@1780: let adam@1780: val acc = if CharVector.all Char.isSpace line then adam@1780: acc adam@1780: else adam@1780: let adam@1780: val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) adam@1780: (String.explode line)) adam@1780: val fname = relifyA fname adam@1780: in adam@1780: fname :: acc adam@1780: end adam@1780: in adam@1780: readSources acc adam@1780: end adam@1780: | OnlyComment => readSources acc adam@1780: | EndOfFile => rev acc adam@1780: adam@1780: val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s) adam@1780: val database = ref (Settings.getDbstring ()) adam@1780: val exe = ref (Settings.getExe ()) adam@1780: val sql = ref (Settings.getSql ()) adam@1780: val debug = ref (Settings.getDebug ()) adam@1780: val profile = ref false adam@1780: val timeout = ref NONE adam@1780: val ffi = ref [] adam@1780: val link = ref [] adam@1780: val linker = ref NONE adam@1780: val headers = ref [] adam@1780: val scripts = ref [] adam@1780: val clientToServer = ref [] adam@1780: val effectful = ref [] adam@1780: val benignEffectful = ref [] adam@1780: val clientOnly = ref [] adam@1780: val serverOnly = ref [] adam@1780: val jsFuncs = ref [] adam@1780: val rewrites = ref [] adam@1780: val url = ref [] adam@1780: val mime = ref [] adam@1780: val request = ref [] adam@1780: val response = ref [] adam@1799: val env = ref [] adam@1780: val libs = ref [] adam@1780: val protocol = ref NONE adam@1780: val dbms = ref NONE adam@1780: val sigFile = ref (Settings.getSigFile ()) adam@1780: val safeGets = ref [] adam@1780: val onError = ref NONE adam@1780: val minHeap = ref 0 adam@1780: adam@1780: fun finish sources = adam@1780: let adam@1780: val job = { adam@1780: prefix = Option.getOpt (!prefix, "/"), adam@1780: database = !database, adam@1780: exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, adam@1780: ext = SOME "exe"}), adam@1780: sql = !sql, adam@1780: debug = !debug, adam@1780: profile = !profile, adam@1780: timeout = Option.getOpt (!timeout, 60), adam@1780: ffi = rev (!ffi), adam@1780: link = rev (!link), adam@1780: linker = !linker, adam@1780: headers = rev (!headers), adam@1780: scripts = rev (!scripts), adam@1780: clientToServer = rev (!clientToServer), adam@1780: effectful = rev (!effectful), adam@1780: benignEffectful = rev (!benignEffectful), adam@1780: clientOnly = rev (!clientOnly), adam@1780: serverOnly = rev (!serverOnly), adam@1780: jsFuncs = rev (!jsFuncs), adam@1780: rewrites = rev (!rewrites), adam@1780: filterUrl = rev (!url), adam@1780: filterMime = rev (!mime), adam@1780: filterRequest = rev (!request), adam@1780: filterResponse = rev (!response), adam@1799: filterEnv = rev (!env), adam@1780: sources = sources, adam@1780: protocol = !protocol, adam@1780: dbms = !dbms, adam@1780: sigFile = !sigFile, adam@1780: safeGets = rev (!safeGets), adam@1780: onError = !onError, adam@1780: minHeap = !minHeap adam@1780: } adam@1780: adam@1780: fun mergeO f (old, new) = adam@1780: case (old, new) of adam@1780: (NONE, _) => new adam@1780: | (_, NONE) => old adam@1780: | (SOME v1, SOME v2) => SOME (f (v1, v2)) adam@1780: adam@1780: fun same desc = mergeO (fn (x : string, y) => adam@1780: (if x = y then adam@1780: () adam@1780: else adam@1780: ErrorMsg.error ("Multiple " adam@1780: ^ desc ^ " values that don't agree"); adam@1780: x)) adam@1780: adam@1780: fun merge (old : job, new : job) = { adam@1780: prefix = case #prefix old of adam@1780: "/" => #prefix new adam@1780: | pold => case #prefix new of adam@1780: "/" => pold adam@1780: | pnew => (if pold = pnew then adam@1780: () adam@1780: else adam@1780: ErrorMsg.error ("Multiple prefix values that don't agree: " adam@1780: ^ pold ^ ", " ^ pnew); adam@1780: pold), adam@1780: database = mergeO (fn (old, _) => old) (#database old, #database new), adam@1780: exe = #exe old, adam@1780: sql = #sql old, adam@1780: debug = #debug old orelse #debug new, adam@1780: profile = #profile old orelse #profile new, adam@1780: timeout = #timeout old, adam@1780: ffi = #ffi old @ #ffi new, adam@1780: link = #link old @ #link new, adam@1780: linker = mergeO (fn (_, new) => new) (#linker old, #linker new), adam@1780: headers = #headers old @ #headers new, adam@1780: scripts = #scripts old @ #scripts new, adam@1780: clientToServer = #clientToServer old @ #clientToServer new, adam@1780: effectful = #effectful old @ #effectful new, adam@1780: benignEffectful = #benignEffectful old @ #benignEffectful new, adam@1780: clientOnly = #clientOnly old @ #clientOnly new, adam@1780: serverOnly = #serverOnly old @ #serverOnly new, adam@1780: jsFuncs = #jsFuncs old @ #jsFuncs new, adam@1780: rewrites = #rewrites old @ #rewrites new, adam@1780: filterUrl = #filterUrl old @ #filterUrl new, adam@1780: filterMime = #filterMime old @ #filterMime new, adam@1780: filterRequest = #filterRequest old @ #filterRequest new, adam@1780: filterResponse = #filterResponse old @ #filterResponse new, adam@1799: filterEnv = #filterEnv old @ #filterEnv new, adam@1780: sources = #sources new adam@1780: @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new)) adam@1780: (#sources old), adam@1780: protocol = mergeO #2 (#protocol old, #protocol new), adam@1780: dbms = mergeO #2 (#dbms old, #dbms new), adam@1780: sigFile = mergeO #2 (#sigFile old, #sigFile new), adam@1780: safeGets = #safeGets old @ #safeGets new, adam@1780: onError = mergeO #2 (#onError old, #onError new), adam@1780: minHeap = Int.max (#minHeap old, #minHeap new) adam@1780: } adam@1780: in adam@1780: if accLibs then adam@1780: foldr (fn (job', job) => merge (job, job')) job (!libs) adam@1780: else adam@1780: job adam@1780: end adam@1780: adam@1780: fun parsePkind s = adam@1780: case s of adam@1780: "all" => Settings.Any adam@1780: | "url" => Settings.Url adam@1780: | "table" => Settings.Table adam@1780: | "sequence" => Settings.Sequence adam@1780: | "view" => Settings.View adam@1780: | "relation" => Settings.Relation adam@1780: | "cookie" => Settings.Cookie adam@1780: | "style" => Settings.Style adam@1780: | _ => (ErrorMsg.error "Bad path kind spec"; adam@1780: Settings.Any) adam@1780: adam@1780: fun parseFrom s = adam@1780: if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then adam@1780: (Settings.Prefix, String.substring (s, 0, size s - 1)) adam@1296: else adam@1780: (Settings.Exact, s) adamc@767: adam@1780: fun parseFkind s = adam@1780: case s of adam@1780: "url" => url adam@1780: | "mime" => mime adam@1780: | "requestHeader" => request adam@1780: | "responseHeader" => response adam@1799: | "env" => env adam@1780: | _ => (ErrorMsg.error "Bad filter kind"; adam@1780: url) adam@1780: adam@1780: fun parsePattern s = adam@1780: if size s > 0 andalso String.sub (s, size s - 1) = #"*" then adam@1780: (Settings.Prefix, String.substring (s, 0, size s - 1)) adam@1296: else adam@1780: (Settings.Exact, s) adamc@767: adam@1780: fun read () = adam@1780: case inputCommentableLine inf of adam@1780: EndOfFile => finish [] adam@1780: | OnlyComment => read () adam@1780: | Content "" => finish (readSources []) adam@1780: | Content line => adam@1780: let adam@1780: val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) adam@1780: val cmd = Substring.string (trim cmd) adam@1780: val arg = Substring.string (trim arg) adamc@794: adam@1780: fun ffiS () = adam@1780: case String.fields (fn ch => ch = #".") arg of adam@1780: [m, x] => (m, x) adam@1780: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); adam@1780: ("", "")) adamc@794: adam@1780: fun ffiM () = adam@1780: case String.fields (fn ch => ch = #"=") arg of adam@1780: [f, s] => adam@1780: let adam@1780: val f = trimS f adam@1780: val s = trimS s adam@1780: in adam@1780: case String.fields (fn ch => ch = #".") f of adam@1780: [m, x] => ((m, x), s) adam@1780: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); adam@1780: (("", ""), "")) adam@1780: end adam@1780: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); adam@1780: (("", ""), "")) adam@1780: in adam@1780: case cmd of adam@1780: "prefix" => prefix := SOME arg adam@1780: | "database" => adam@1780: (case !database of adam@1780: NONE => database := SOME arg adam@1780: | SOME _ => ()) adam@1780: | "dbms" => adam@1780: (case !dbms of adam@1780: NONE => dbms := SOME arg adam@1780: | SOME _ => ()) adam@1780: | "sigfile" => adam@1780: (case !sigFile of adam@1780: NONE => sigFile := SOME arg adam@1780: | SOME _ => ()) adam@1780: | "exe" => adam@1780: (case !exe of adam@1780: NONE => exe := SOME (relify arg) adam@1780: | SOME _ => ()) adam@1780: | "sql" => adam@1780: (case !sql of adam@1780: NONE => sql := SOME (relify arg) adam@1780: | SOME _ => ()) adam@1780: | "debug" => debug := true adam@1780: | "profile" => profile := true adam@1780: | "timeout" => adam@1780: (case !timeout of adam@1780: NONE => () adam@1780: | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; adam@1780: timeout := SOME (valOf (Int.fromString arg))) adam@1780: | "ffi" => ffi := relify arg :: !ffi adam@1780: | "link" => let adam@1780: val arg = if size arg >= 1 adam@1780: andalso String.sub (arg, 0) = #"-" then adam@1780: arg adam@1780: else adam@1780: relifyA arg adam@1780: in adam@1780: link := arg :: !link adam@1780: end adam@1780: | "linker" => linker := SOME arg adam@1780: | "include" => headers := relifyA arg :: !headers adam@1780: | "script" => scripts := arg :: !scripts adam@1780: | "clientToServer" => clientToServer := ffiS () :: !clientToServer adam@1780: | "safeGet" => safeGets := arg :: !safeGets adam@1780: | "effectful" => effectful := ffiS () :: !effectful adam@1780: | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful adam@1780: | "clientOnly" => clientOnly := ffiS () :: !clientOnly adam@1780: | "serverOnly" => serverOnly := ffiS () :: !serverOnly adam@1780: | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs adam@1780: | "rewrite" => adam@1780: let adam@1780: fun doit (pkind, from, to, hyph) = adam@1780: let adam@1780: val pkind = parsePkind pkind adam@1780: val (kind, from) = parseFrom from adam@1780: in adam@1780: rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites adam@1780: end adam@1780: in adam@1780: case String.tokens Char.isSpace arg of adam@1780: [pkind, from, to, "[-]"] => doit (pkind, from, to, true) adam@1780: | [pkind, from, "[-]"] => doit (pkind, from, "", true) adam@1780: | [pkind, from, to] => doit (pkind, from, to, false) adam@1780: | [pkind, from] => doit (pkind, from, "", false) adam@1780: | _ => ErrorMsg.error "Bad 'rewrite' syntax" adam@1780: end adam@1780: | "allow" => adam@1780: (case String.tokens Char.isSpace arg of adam@1780: [fkind, pattern] => adam@1780: let adam@1780: val fkind = parseFkind fkind adam@1780: val (kind, pattern) = parsePattern pattern adam@1780: in adam@1780: fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind adam@1780: end adam@1780: | _ => ErrorMsg.error "Bad 'allow' syntax") adam@1780: | "deny" => adam@1780: (case String.tokens Char.isSpace arg of adam@1780: [fkind, pattern] => adam@1780: let adam@1780: val fkind = parseFkind fkind adam@1780: val (kind, pattern) = parsePattern pattern adam@1780: in adam@1780: fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind adam@1780: end adam@1780: | _ => ErrorMsg.error "Bad 'deny' syntax") adam@1780: | "library" => if accLibs then adam@1780: libs := pu (libify (relify arg)) :: !libs adam@1780: else adam@1780: bigLibs := libify' arg :: !bigLibs adam@1780: | "path" => adam@1780: (case String.fields (fn ch => ch = #"=") arg of adam@1780: [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir})) adam@1780: handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument") adam@1780: | _ => ErrorMsg.error "path argument not of the form name=value'") adam@1780: | "onError" => adam@1780: (case String.fields (fn ch => ch = #".") arg of adam@1780: m1 :: (fs as _ :: _) => adam@1780: onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) adam@1780: | _ => ErrorMsg.error "invalid 'onError' argument") adam@1780: | "limit" => adam@1780: (case String.fields Char.isSpace arg of adam@1780: [class, num] => adam@1780: (case Int.fromString num of adam@1780: NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'") adam@1780: | SOME n => adam@1780: if n < 0 then adam@1780: ErrorMsg.error ("invalid limit number '" ^ num ^ "'") adam@1780: else adam@1780: Settings.addLimit (class, n)) adam@1780: | _ => ErrorMsg.error "invalid 'limit' arguments") adam@1780: | "minHeap" => adam@1780: (case Int.fromString arg of adam@1780: NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'") adam@1780: | SOME n => minHeap := n) vshabanoff@1815: | "coreInline" => vshabanoff@1815: (case Int.fromString arg of vshabanoff@1815: NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'") vshabanoff@1815: | SOME n => Settings.setCoreInline n) vshabanoff@1815: | "monoInline" => vshabanoff@1815: (case Int.fromString arg of vshabanoff@1815: NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'") vshabanoff@1815: | SOME n => Settings.setMonoInline n) adam@1780: | "alwaysInline" => Settings.addAlwaysInline arg adam@1966: | "neverInline" => Settings.addNeverInline arg adam@1780: | "noXsrfProtection" => Settings.addNoXsrfProtection arg adam@1780: | "timeFormat" => Settings.setTimeFormat arg adam@1953: | "noMangleSql" => Settings.setMangleSql false adam@1956: | "html5" => Settings.setIsHtml5 true adam@2010: | "lessSafeFfi" => Settings.setLessSafeFfi true adamc@794: adam@1780: | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); adam@1780: read () adam@1780: end adamc@794: adam@1780: val job = if hasBlankLine then adam@1780: read () adam@1780: else adam@1780: finish (readSources []) adam@1780: in adam@1780: TextIO.closeIn inf; adam@1780: institutionalizeJob job; adam@1780: job adam@1780: end adam@1780: in adam@1780: {Job = pu fname, Libs = !bigLibs} adam@1780: end) adamc@767: adamc@1082: fun p_job' {Job = j, Libs = _ : string list} = p_job j adamc@1082: adamc@270: val parseUrp = { adamc@1083: func = #Job o parseUrp' true, adamc@270: print = p_job adamc@270: } adamc@270: adamc@1082: val parseUrp' = { adamc@1083: func = parseUrp' false, adamc@1082: print = p_job' adamc@1082: } adamc@1082: adamc@270: val toParseJob = transform parseUrp "parseJob" adamc@1082: val toParseJob' = transform parseUrp' "parseJob'" adamc@1082: adamc@1082: fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = { adamc@1082: func = fn input => case #func tr1 input of adamc@1082: NONE => NONE adamc@1082: | SOME v => #func tr2 v, adamc@1082: print = #print tr2, adamc@1082: time = fn (input, pmap) => let adamc@1082: val (ro, pmap) = #time tr1 (input, pmap) adamc@1082: in adamc@1082: case ro of adamc@1082: NONE => (NONE, pmap) adamc@1082: | SOME v => #time tr2 (v, pmap) adamc@1082: end adamc@1082: } adamc@270: adamc@1090: structure SM = BinaryMapFn(struct adamc@1090: type ord_key = string adamc@1090: val compare = String.compare adamc@1090: end) adamc@1090: adamc@1090: val moduleRoots = ref ([] : (string * string) list) adam@1868: fun addModuleRoot (k, v) = moduleRoots := adam@1868: (OS.Path.mkAbsolute {path = k, adam@1868: relativeTo = OS.FileSys.getDir ()}, adam@1868: v) :: !moduleRoots adamc@1090: adam@1743: structure SK = struct adam@1743: type ord_key = string adam@1743: val compare = String.compare adam@1743: end adam@1743: adam@1743: structure SS = BinarySetFn(SK) adam@1743: structure SM = BinaryMapFn(SK) adamc@1090: adam@1773: exception MissingFile of string adam@1773: adamc@201: val parse = { adam@1294: func = fn {database, sources = fnames, ffi, onError, ...} : job => adamc@201: let adamc@1090: val mrs = !moduleRoots adamc@1090: adamc@834: val anyErrors = ref false adamc@834: fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ()) adam@1343: fun nameOf fname = adam@1343: let adam@1343: val fname = OS.Path.file fname adam@1343: val fst = if size fname = 0 then #"!" else String.sub (fname, 0) adam@1343: in adam@1343: if not (Char.isAlpha fst) then adam@1343: ErrorMsg.error ("Filename doesn't start with letter: " ^ fname) adam@1343: else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then adam@1343: ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname) adam@1343: else adam@1343: (); adam@1343: capitalize fname adam@1343: end adamc@109: adamc@764: fun parseFfi fname = adamc@764: let adamc@764: val mname = nameOf fname adamc@764: val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} adamc@764: adamc@764: val loc = {file = urs, adamc@764: first = ErrorMsg.dummyPos, adamc@764: last = ErrorMsg.dummyPos} adamc@764: adamc@764: val sgn = (Source.SgnConst (#func parseUrs urs), loc) adamc@764: in adamc@834: checkErrors (); adam@1733: (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc) adamc@764: end adamc@764: adamc@1090: val defed = ref SS.empty adamc@1092: val fulls = ref SS.empty adamc@1090: adamc@201: fun parseOne fname = adamc@201: let adamc@201: val mname = nameOf fname adamc@244: val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"} adamc@244: val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} adamc@56: adam@1773: val () = if Posix.FileSys.access (ur, []) then adam@1773: () adam@1773: else adam@1773: raise MissingFile ur adam@1773: adamc@201: val sgnO = adamc@244: if Posix.FileSys.access (urs, []) then adamc@244: SOME (Source.SgnConst (#func parseUrs urs), adamc@244: {file = urs, adamc@201: first = ErrorMsg.dummyPos, adamc@201: last = ErrorMsg.dummyPos}) adamc@834: before checkErrors () adamc@201: else adamc@201: NONE adamc@56: adamc@244: val loc = {file = ur, adamc@201: first = ErrorMsg.dummyPos, adamc@201: last = ErrorMsg.dummyPos} adamc@56: adam@1738: val urt = OS.FileSys.modTime ur adam@1738: val urst = (OS.FileSys.modTime urs) handle _ => urt adam@1738: adamc@244: val ds = #func parseUr ur adam@1738: val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE, adam@1868: (Source.StrConst ds, loc), false), loc) adamc@1090: adamc@1126: val fname = OS.Path.mkCanonical fname adamc@1090: val d = case List.find (fn (root, name) => adamc@1090: String.isPrefix (root ^ "/") fname) mrs of adamc@1090: NONE => d adamc@1090: | SOME (root, name) => adamc@1090: let adamc@1090: val fname = String.extract (fname, size root + 1, NONE) adamc@1090: val pieces = name :: String.tokens (fn ch => ch = #"/") fname adamc@1090: val pieces = List.filter (fn s => size s > 0 adamc@1090: andalso Char.isAlpha (String.sub (s, 0))) adamc@1090: pieces adamc@1090: val pieces = map capitalize pieces adamc@1092: val full = String.concatWith "." pieces adamc@1090: adam@1868: fun makeD first prefix pieces = adamc@1090: case pieces of adamc@1090: [] => (ErrorMsg.error "Empty module path"; adamc@1090: (Source.DStyle "Boo", loc)) adamc@1090: | [_] => d adamc@1090: | piece :: pieces => adamc@1090: let adamc@1146: val this = case prefix of adamc@1146: "" => piece adamc@1146: | _ => prefix ^ "." ^ piece adamc@1090: val old = SS.member (!defed, this) adamc@1146: adamc@1146: fun notThere (ch, s) = adamc@1146: Substring.isEmpty (#2 (Substring.splitl adamc@1146: (fn ch' => ch' <> ch) s)) adamc@1146: adamc@1146: fun simOpen () = adamc@1146: SS.foldl (fn (full, ds) => adamc@1146: if String.isPrefix (this ^ ".") full adamc@1146: andalso notThere (#".", adamc@1146: Substring.extract (full, adamc@1146: size adamc@1146: this + 1, adamc@1146: NONE)) then adamc@1146: let adamc@1146: val parts = String.tokens adamc@1146: (fn ch => ch = #".") full adamc@1146: adamc@1146: val part = List.last parts adamc@1146: adamc@1146: val imp = if length parts >= 2 then adamc@1146: (Source.StrProj adamc@1146: ((Source.StrVar adamc@1146: (List.nth (parts, adamc@1146: length adamc@1146: parts adamc@1146: - 2)), adamc@1146: loc), adamc@1146: part), loc) adamc@1146: else adamc@1146: (Source.StrVar part, loc) adamc@1146: in adam@1868: (Source.DStr (part, NONE, NONE, imp, false), adamc@1146: loc) :: ds adamc@1146: end adamc@1146: else adamc@1146: ds) [] (!fulls) adamc@1090: in adamc@1090: defed := SS.add (!defed, this); adam@1732: (Source.DStr (piece, NONE, NONE, adamc@1090: (Source.StrConst (if old then adamc@1146: simOpen () adam@1868: @ [makeD false this pieces] adamc@1090: else adam@1868: [makeD false this pieces]), adam@1868: loc), first andalso old), adamc@1090: loc) adamc@1090: end adamc@1090: in adamc@1092: if SS.member (!fulls, full) then adamc@1092: ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") adamc@1092: else adamc@1092: (); adamc@1146: adam@1868: makeD true "" pieces adamc@1146: before ignore (foldl (fn (new, path) => adamc@1146: let adamc@1146: val new' = case path of adamc@1146: "" => new adamc@1146: | _ => path ^ "." ^ new adamc@1146: in adamc@1146: fulls := SS.add (!fulls, new'); adamc@1146: new' adamc@1146: end) "" pieces) adamc@1090: end adamc@201: in adamc@834: checkErrors (); adamc@1090: d adam@1773: end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname); adam@1773: (Source.DSequence "", ErrorMsg.dummySpan)) adamc@56: adamc@764: val dsFfi = map parseFfi ffi adamc@201: val ds = map parseOne fnames adamc@1090: val loc = ErrorMsg.dummySpan adamc@201: in adamc@834: if !anyErrors then adamc@834: ErrorMsg.error "Parse failure" adamc@834: else adamc@834: (); adamc@834: adamc@201: let adamc@1126: val final = List.last fnames adamc@1126: val final = case List.find (fn (root, name) => adamc@1126: String.isPrefix (root ^ "/") final) mrs of adamc@1126: NONE => (Source.StrVar (nameOf final), loc) adamc@1126: | SOME (root, name) => adamc@1126: let adamc@1126: val m = (Source.StrVar name, loc) adamc@1126: val final = String.extract (final, size root + 1, NONE) adamc@1264: val fields = String.fields (fn ch => ch = #"/") final adamc@1264: val fields = List.filter (fn s => size s = 0 adamc@1264: orelse not (Char.isDigit (String.sub (s, 0)))) adamc@1264: fields adamc@1126: in adamc@1126: foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc)) adamc@1264: m fields adamc@1126: end adamc@271: adamc@764: val ds = dsFfi @ ds adamc@1126: @ [(Source.DExport final, loc)] adamc@1090: adamc@1090: val ds = case database of adamc@1090: NONE => ds adamc@1090: | SOME s => (Source.DDatabase s, loc) :: ds adam@1294: adam@1294: val ds = case onError of adam@1294: NONE => ds adam@1294: | SOME v => ds @ [(Source.DOnError v, loc)] adam@1868: adam@1868: fun dummy fname = {file = Settings.libFile fname, adam@1868: first = ErrorMsg.dummyPos, adam@1868: last = ErrorMsg.dummyPos} adam@1868: adam@1868: val used = SM.insert (SM.empty, "Basis", dummy "basis.urs") adam@1868: val used = SM.insert (used, "Top", dummy "top.urs") adamc@201: in adam@1738: ignore (List.foldl (fn (d, used) => adam@1738: case #1 d of adam@1868: Source.DStr (x, _, _, _, false) => adam@1743: (case SM.find (used, x) of adam@1743: SOME loc => adam@1743: (ErrorMsg.error ("Duplicate top-level module name " ^ x); adam@1743: Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)), adam@1743: ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))]; adam@1743: used) adam@1743: | NONE => adam@1743: SM.insert (used, x, #2 d)) adam@1868: | _ => used) used ds); adamc@1090: ds adamc@201: end handle Empty => ds adamc@201: end, adamc@201: print = SourcePrint.p_file adamc@201: } adamc@56: adamc@270: val toParse = transform parse "parse" o toParseJob adamc@38: adamc@201: val elaborate = { adamc@201: func = fn file => let ezyang@1739: val basisF = Settings.libFile "basis.urs" ezyang@1739: val topF = Settings.libFile "top.urs" ezyang@1739: val topF' = Settings.libFile "top.ur" adam@1732: adam@1732: val basis = #func parseUrs basisF adam@1732: val topSgn = #func parseUrs topF adam@1732: val topStr = #func parseUr topF' adam@1732: adam@1732: val tm1 = OS.FileSys.modTime topF adam@1732: val tm2 = OS.FileSys.modTime topF' adamc@201: in adam@1732: Elaborate.elabFile basis (OS.FileSys.modTime basisF) adam@1732: topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) adam@1732: ElabEnv.empty file adamc@201: end, adamc@201: print = ElabPrint.p_file ElabEnv.empty adamc@201: } adamc@5: adamc@270: val toElaborate = transform elaborate "elaborate" o toParse adamc@201: adamc@448: val unnest = { adamc@448: func = Unnest.unnest, adamc@448: print = ElabPrint.p_file ElabEnv.empty adamc@448: } adamc@448: adamc@448: val toUnnest = transform unnest "unnest" o toElaborate adamc@448: adamc@313: val termination = { adamc@313: func = (fn file => (Termination.check file; file)), adamc@313: print = ElabPrint.p_file ElabEnv.empty adamc@313: } adamc@313: adamc@448: val toTermination = transform termination "termination" o toUnnest adamc@313: adamc@201: val explify = { adamc@201: func = Explify.explify, adamc@201: print = ExplPrint.p_file ExplEnv.empty adamc@201: } adamc@201: adamc@625: val toExplify = transform explify "explify" o toUnnest adamc@201: adamc@201: val corify = { adamc@201: func = Corify.corify, adamc@201: print = CorePrint.p_file CoreEnv.empty adamc@201: } adamc@201: adamc@270: val toCorify = transform corify "corify" o toExplify adamc@201: adamc@482: (*val reduce_local = { adamc@482: func = ReduceLocal.reduce, adamc@482: print = CorePrint.p_file CoreEnv.empty adamc@482: } adamc@482: adamc@482: val toReduce_local = transform reduce_local "reduce_local" o toCorify*) adamc@482: adamc@443: val especialize = { adamc@443: func = ESpecialize.specialize, adamc@443: print = CorePrint.p_file CoreEnv.empty adamc@443: } adamc@443: adamc@454: val core_untangle = { adamc@454: func = CoreUntangle.untangle, adamc@454: print = CorePrint.p_file CoreEnv.empty adamc@454: } adamc@454: adamc@794: val toCore_untangle = transform core_untangle "core_untangle" o toCorify adamc@454: adamc@202: val shake = { adamc@202: func = Shake.shake, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@39: adamc@454: val toShake1 = transform shake "shake1" o toCore_untangle adamc@110: adam@1362: val toEspecialize1' = transform especialize "especialize1'" o toShake1 adam@1362: val toShake1' = transform shake "shake1'" o toEspecialize1' adam@1362: adamc@607: val rpcify = { adamc@607: func = Rpcify.frob, adamc@607: print = CorePrint.p_file CoreEnv.empty adamc@607: } adamc@607: adam@1362: val toRpcify = transform rpcify "rpcify" o toShake1' adamc@607: adamc@642: val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify adamc@642: val toShake2 = transform shake "shake2" o toCore_untangle2 adamc@1181: adamc@1186: val toEspecialize1 = transform especialize "especialize1" o toShake2 adamc@1181: adamc@1062: val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1 adamc@1062: val toShake3 = transform shake "shake3" o toCore_untangle3 adamc@642: adamc@202: val tag = { adamc@202: func = Tag.tag, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@193: adamc@1062: val toTag = transform tag "tag" o toShake3 adamc@20: adamc@202: val reduce = { adamc@202: func = Reduce.reduce, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@25: adamc@692: val toReduce = transform reduce "reduce" o toTag adamc@23: adamc@1186: val toShakey = transform shake "shakey" o toReduce adamc@1186: adamc@1186: val unpoly = { adamc@1186: func = Unpoly.unpoly, adamc@1186: print = CorePrint.p_file CoreEnv.empty adamc@1186: } adamc@1186: adamc@1186: val toUnpoly = transform unpoly "unpoly" o toShakey adamc@315: adamc@202: val specialize = { adamc@202: func = Specialize.specialize, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@132: adamc@1186: val toSpecialize = transform specialize "specialize" o toUnpoly adamc@131: adamc@1062: val toShake4 = transform shake "shake4" o toSpecialize adamc@133: adamc@1062: val toEspecialize2 = transform especialize "especialize2" o toShake4 adamc@1272: val toShake4' = transform shake "shake4'" o toEspecialize2 adamc@1272: val toUnpoly2 = transform unpoly "unpoly2" o toShake4' adamc@1276: val toSpecialize2 = transform specialize "specialize2" o toUnpoly2 adamc@1276: val toShake4'' = transform shake "shake4'" o toSpecialize2 adamc@1272: val toEspecialize3 = transform especialize "especialize3" o toShake4'' adamc@794: adamc@1272: val toReduce2 = transform reduce "reduce2" o toEspecialize3 adamc@898: adamc@1062: val toShake5 = transform shake "shake5" o toReduce2 adamc@794: adamc@692: val marshalcheck = { adamc@692: func = (fn file => (MarshalCheck.check file; file)), adamc@692: print = CorePrint.p_file CoreEnv.empty adamc@692: } adamc@692: adamc@1062: val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5 adamc@692: adamc@732: val effectize = { adamc@732: func = Effective.effectize, adamc@732: print = CorePrint.p_file CoreEnv.empty adamc@732: } adamc@732: adamc@732: val toEffectize = transform effectize "effectize" o toMarshalcheck adamc@732: adamc@1170: val css = { adamc@1170: func = Css.summarize, adamc@1170: print = fn _ => Print.box [] adamc@1170: } adamc@1170: adamc@1170: val toCss = transform css "css" o toShake5 adamc@1170: adamc@202: val monoize = { adamc@202: func = Monoize.monoize CoreEnv.empty, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@134: adamc@732: val toMonoize = transform monoize "monoize" o toEffectize adamc@96: adamc@202: val mono_opt = { adamc@910: func = MonoOpt.optimize, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@29: adamc@270: val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize adamc@5: adamc@202: val untangle = { adamc@202: func = Untangle.untangle, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@1: adamc@270: val toUntangle = transform untangle "untangle" o toMono_opt1 adamc@38: adamc@202: val mono_reduce = { adamc@202: func = MonoReduce.reduce, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@16: adamc@270: val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle adamc@39: adamc@202: val mono_shake = { adamc@202: func = MonoShake.shake, adamc@202: print = MonoPrint.p_file MonoEnv.empty adamc@202: } adamc@110: adamc@270: val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce adamc@193: adamc@572: val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake adamc@572: adamc@1200: val iflow = { adamc@1235: func = (fn file => (if !doIflow then Iflow.check file else (); file)), adamc@1200: print = MonoPrint.p_file MonoEnv.empty adamc@1200: } adamc@1200: adamc@1200: val toIflow = transform iflow "iflow" o toMono_opt2 adamc@1200: adam@1800: val namejs = { adam@1800: func = NameJS.rewrite, adam@1800: print = MonoPrint.p_file MonoEnv.empty adam@1800: } adam@1800: adam@1800: val toNamejs = transform namejs "namejs" o toIflow adam@1800: adam@1800: val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs adam@1800: adam@1845: val scriptcheck = { adam@1845: func = ScriptCheck.classify, adam@1845: print = MonoPrint.p_file MonoEnv.empty adam@1845: } adam@1845: adam@1845: val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle adam@1845: adamc@567: val jscomp = { adamc@567: func = JsComp.process, adamc@567: print = MonoPrint.p_file MonoEnv.empty adamc@567: } adamc@567: adam@1845: val toJscomp = transform jscomp "jscomp" o toScriptcheck adamc@567: adamc@910: val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp adamc@20: adamc@506: val fuse = { adamc@506: func = Fuse.fuse, adamc@506: print = MonoPrint.p_file MonoEnv.empty adamc@506: } adamc@506: adamc@572: val toFuse = transform fuse "fuse" o toMono_opt3 adamc@506: adamc@506: val toUntangle2 = transform untangle "untangle2" o toFuse adamc@506: adamc@601: val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 adamc@601: val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 adamc@916: val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2 adamc@1017: val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4 adamc@1185: val toFuse2 = transform fuse "fuse2" o toMono_reduce3 adamc@916: val toUntangle3 = transform untangle "untangle3" o toFuse2 adamc@916: val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3 adamc@506: adamc@377: val pathcheck = { adamc@377: func = (fn file => (PathCheck.check file; file)), adamc@377: print = MonoPrint.p_file MonoEnv.empty adamc@377: } adamc@377: adamc@916: val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3 adamc@377: adam@1595: val sidecheck = { adam@1595: func = SideCheck.check, adam@1595: print = MonoPrint.p_file MonoEnv.empty adam@1595: } adam@1595: adam@1595: val toSidecheck = transform sidecheck "sidecheck" o toPathcheck adam@1595: adam@1856: val sigcheck = { adam@1856: func = SigCheck.check, adam@1856: print = MonoPrint.p_file MonoEnv.empty adam@1856: } adam@1856: adam@1856: val toSigcheck = transform sigcheck "sigcheck" o toSidecheck adam@1856: adamc@202: val cjrize = { adamc@202: func = Cjrize.cjrize, adamc@202: print = CjrPrint.p_file CjrEnv.empty adamc@202: } adamc@23: adam@1856: val toCjrize = transform cjrize "cjrize" o toSigcheck adamc@29: adamc@282: val prepare = { adamc@282: func = Prepare.prepare, adamc@282: print = CjrPrint.p_file CjrEnv.empty adamc@282: } adamc@282: adam@1845: val toPrepare = transform prepare "prepare" o toCjrize adamc@282: adamc@879: val checknest = { adamc@879: func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f, adamc@879: print = CjrPrint.p_file CjrEnv.empty adamc@879: } adamc@879: adamc@879: val toChecknest = transform checknest "checknest" o toPrepare adamc@879: adamc@274: val sqlify = { adamc@274: func = Cjrize.cjrize, adamc@274: print = CjrPrint.p_sql CjrEnv.empty adamc@274: } adamc@274: adamc@274: val toSqlify = transform sqlify "sqlify" o toMono_opt2 adamc@274: adam@1473: val escapeFilename = String.translate (fn #" " => "\\ " | #"\"" => "\\\"" | #"'" => "\\'" | ch => str ch) adam@1473: adam@1540: val beforeC = ref (fn () => ()) adam@1540: adam@1822: structure StringSet = BinarySetFn(struct adam@1822: type ord_key = string adam@1822: val compare = String.compare adam@1822: end) adam@1822: adam@1725: fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = adamc@183: let adamc@855: val proto = Settings.currentProtocol () adamc@1095: adam@1368: val lib = if Settings.getStaticLinking () then adam@1846: " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" adam@1368: else ezyang@1739: "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" adamc@378: adam@1558: val opt = if debug then adam@1558: "" adam@1558: else adam@1558: " -O3" adam@1558: grrwlf@1871: val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value" ezyang@1739: ^ opt ^ " -I " ^ !Settings.configInclude adamc@1096: ^ " " ^ #compile proto adam@1473: ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname adamc@1096: grrwlf@1871: val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs) adam@1725: adam@1846: val ssl = if Settings.getStaticLinking () then adam@1846: Config.openssl ^ " -ldl -lz" adam@1846: else adam@1846: Config.openssl adam@1846: adam@1725: val link = linker andersk@1893: ^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename adamc@502: adamc@502: val (compile, link) = adamc@502: if profile then adamc@502: (compile ^ " -pg", link ^ " -pg") adamc@502: else adamc@502: (compile, link) adamc@742: adamc@742: val (compile, link) = adamc@742: if debug then adamc@742: (compile ^ " -g", link ^ " -g") adamc@742: else adamc@742: (compile, link) adamc@764: adam@1822: val link = #1 (foldl adam@1822: (fn (s, (link, set)) => adam@1822: if StringSet.member (set, s) then adam@1822: (link, set) adam@1822: else adam@1822: ((link ^ " " ^ s), StringSet.add (set, s))) adam@1822: (link, StringSet.empty) adam@1822: link') adam@1394: adam@1394: fun system s = adam@1394: (if debug then adam@1394: print (s ^ "\n") adam@1394: else adam@1394: (); adam@1394: OS.Process.isSuccess (OS.Process.system s)) adamc@183: in adam@1540: !beforeC (); adam@1394: system compile andalso system link adamc@183: end adamc@183: adamc@202: fun compile job = adamc@879: case run toChecknest job of adamc@1045: NONE => false adamc@29: | SOME file => adamc@202: let adamc@274: val job = valOf (run (transform parseUrp "parseUrp") job) adamc@102: adamc@274: val (cname, oname, cleanup) = adamc@274: if #debug job then adamc@457: ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ()) adamc@274: else adamc@274: let adamc@274: val dir = OS.FileSys.tmpName () adamc@403: val () = if OS.FileSys.access (dir, []) then adamc@403: OS.FileSys.remove dir adamc@403: else adamc@403: () adamc@457: val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"} adamc@457: val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"} adamc@274: in adamc@274: OS.FileSys.mkDir dir; adamc@274: (cname, oname, adam@1700: fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then adam@1700: () adam@1700: else adam@1700: raise Fail ("Unable to delete temporary directory " ^ dir))) adamc@274: end adamc@274: val ename = #exe job adamc@202: in adamc@274: let adamc@274: val outf = TextIO.openOut cname adamc@274: val s = TextIOPP.openOut {dst = outf, wid = 80} adamc@432: adamc@432: val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file) adamc@432: val libs = adamc@432: if hasDb then adamc@866: #link (Settings.currentDbms ()) adamc@432: else adamc@432: "" adamc@274: in adamc@274: Print.fprint s (CjrPrint.p_file CjrEnv.empty file); adamc@415: TextIO.output1 (outf, #"\n"); adamc@274: TextIO.closeOut outf; adamc@102: adam@1381: if ErrorMsg.anyErrors () then adam@1381: false adam@1381: else adam@1381: (case #sql job of adam@1381: NONE => () adam@1381: | SOME sql => adam@1381: let adam@1381: val outf = TextIO.openOut sql adam@1381: val s = TextIOPP.openOut {dst = outf, wid = 80} adam@1381: in adam@1381: Print.fprint s (CjrPrint.p_sql CjrEnv.empty file); adam@1381: TextIO.closeOut outf adam@1381: end; adamc@274: adam@1381: compileC {cname = cname, oname = oname, ename = ename, libs = libs, adam@1725: profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} adam@1381: adam@1381: before cleanup ()) adamc@274: end adamc@274: handle ex => (((cleanup ()) handle _ => ()); raise ex) adamc@202: end adamc@29: adamc@1045: fun compiler job = adamc@1045: if compile job then adamc@1045: () adamc@1045: else adamc@1045: OS.Process.exit OS.Process.failure adamc@1045: adamc@1266: fun moduleOf fname = adamc@1266: let adamc@1266: val mrs = !moduleRoots adamc@1266: val fname = OS.Path.mkCanonical fname adamc@1266: in adamc@1266: case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of adamc@1266: NONE => capitalize (OS.Path.base (OS.Path.file fname)) adamc@1266: | SOME (root, name) => adamc@1266: let adamc@1266: val fname = OS.Path.base fname adamc@1266: val fname = String.extract (fname, size root + 1, NONE) adamc@1266: val fs = String.fields (fn ch => ch = #"/") fname adamc@1266: val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs adamc@1266: val fs = map capitalize fs adamc@1266: in adamc@1266: String.concatWith "." (name :: fs) adamc@1266: end adamc@1266: end adamc@1266: adamc@1: end