adamc@764: (* Copyright (c) 2008-2009, 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, adamc@765: headers : string list, adamc@766: scripts : string list, adamc@765: clientToServer : Settings.ffi list, adamc@765: effectful : 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, adamc@866: protocol : string option, adamc@866: dbms : string option 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@201: fun transform (ph : ('src, 'dst) phase) name = { adamc@201: func = fn input => let adamc@201: val v = #func ph input adamc@201: in adamc@201: if ErrorMsg.anyErrors () then adamc@201: NONE adamc@201: else adamc@201: SOME v adamc@201: end, adamc@201: print = #print ph, adamc@201: time = fn (input, pmap) => let 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@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@270: fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = { adamc@201: func = fn input => case #func tr1 input of adamc@201: NONE => NONE adamc@201: | SOME v => #func tr2 v, adamc@201: print = #print tr2, adamc@201: time = fn (input, pmap) => let adamc@201: val (ro, pmap) = #time tr1 (input, pmap) adamc@201: in adamc@201: case ro of adamc@201: NONE => (NONE, pmap) adamc@201: | SOME v => #time tr2 (v, 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: 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: 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@768: clientToServer, effectful, 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@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: adamc@794: structure M = BinaryMapFn(struct adamc@794: type ord_key = string adamc@794: val compare = String.compare adamc@794: end) adamc@794: adamc@794: fun parseUrp' fname = adamc@767: let adamc@794: val pathmap = ref (M.insert (M.empty, "", Config.libUr)) adamc@767: adamc@794: fun pu filename = adamc@794: let adamc@794: val dir = OS.Path.dir filename adamc@794: val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) adamc@767: adamc@794: fun pathify fname = adamc@794: if size fname > 0 andalso String.sub (fname, 0) = #"$" then adamc@794: let adamc@794: val fname' = Substring.extract (fname, 1, NONE) adamc@794: val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' adamc@794: in adamc@794: if Substring.isEmpty after then adamc@794: fname adamc@794: else adamc@794: case M.find (!pathmap, Substring.string befor) of adamc@794: NONE => fname adamc@794: | SOME rep => rep ^ Substring.string after adamc@794: end adamc@794: else adamc@794: fname adamc@767: adamc@794: fun relify fname = adamc@794: let adamc@794: val fname = pathify fname adamc@794: in adamc@794: OS.Path.concat (dir, fname) adamc@794: handle OS.Path.Path => fname adamc@794: end adamc@767: adamc@794: val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} adamc@767: adamc@794: fun relifyA fname = adamc@794: OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} adamc@767: adamc@794: fun readSources acc = adamc@794: case TextIO.inputLine inf of adamc@794: NONE => rev acc adamc@794: | SOME line => adamc@794: let adamc@794: val acc = if CharVector.all Char.isSpace line then adamc@794: acc adamc@794: else adamc@794: let adamc@794: val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) adamc@794: (String.explode line)) adamc@794: val fname = relify fname adamc@794: in adamc@794: fname :: acc adamc@794: end adamc@794: in adamc@794: readSources acc adamc@794: end adamc@767: adamc@794: val prefix = ref NONE adamc@794: val database = ref NONE adamc@794: val exe = ref NONE adamc@794: val sql = ref NONE adamc@857: val debug = ref (Settings.getDebug ()) adamc@794: val profile = ref false adamc@794: val timeout = ref NONE adamc@794: val ffi = ref [] adamc@794: val link = ref [] adamc@794: val headers = ref [] adamc@794: val scripts = ref [] adamc@794: val clientToServer = ref [] adamc@794: val effectful = ref [] adamc@794: val clientOnly = ref [] adamc@794: val serverOnly = ref [] adamc@794: val jsFuncs = ref [] adamc@794: val rewrites = ref [] adamc@794: val url = ref [] adamc@794: val mime = ref [] adamc@794: val libs = ref [] adamc@866: val protocol = ref NONE adamc@866: val dbms = ref NONE adamc@767: adamc@794: fun finish sources = adamc@794: let adamc@794: val job = { adamc@794: prefix = Option.getOpt (!prefix, "/"), adamc@794: database = !database, adamc@794: exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, adamc@794: ext = SOME "exe"}), adamc@794: sql = !sql, adamc@794: debug = !debug, adamc@794: profile = !profile, adamc@794: timeout = Option.getOpt (!timeout, 60), adamc@794: ffi = rev (!ffi), adamc@794: link = rev (!link), adamc@794: headers = rev (!headers), adamc@794: scripts = rev (!scripts), adamc@794: clientToServer = rev (!clientToServer), adamc@794: effectful = rev (!effectful), adamc@794: clientOnly = rev (!clientOnly), adamc@794: serverOnly = rev (!serverOnly), adamc@794: jsFuncs = rev (!jsFuncs), adamc@794: rewrites = rev (!rewrites), adamc@794: filterUrl = rev (!url), adamc@794: filterMime = rev (!mime), adamc@866: sources = sources, adamc@866: protocol = !protocol, adamc@866: dbms = !dbms adamc@794: } adamc@767: adamc@794: fun mergeO f (old, new) = adamc@794: case (old, new) of adamc@794: (NONE, _) => new adamc@794: | (_, NONE) => old adamc@794: | (SOME v1, SOME v2) => SOME (f (v1, v2)) adamc@794: adamc@794: fun same desc = mergeO (fn (x : string, y) => adamc@794: (if x = y then adamc@794: () adamc@794: else adamc@794: ErrorMsg.error ("Multiple " adamc@794: ^ desc ^ " values that don't agree"); adamc@794: x)) adamc@794: adamc@794: fun merge (old : job, new : job) = { adamc@794: prefix = #prefix old, adamc@794: database = #database old, adamc@794: exe = #exe old, adamc@794: sql = #sql old, adamc@794: debug = #debug old orelse #debug new, adamc@794: profile = #profile old orelse #profile new, adamc@794: timeout = #timeout old, adamc@794: ffi = #ffi old @ #ffi new, adamc@794: link = #link old @ #link new, adamc@794: headers = #headers old @ #headers new, adamc@794: scripts = #scripts old @ #scripts new, adamc@794: clientToServer = #clientToServer old @ #clientToServer new, adamc@794: effectful = #effectful old @ #effectful new, adamc@794: clientOnly = #clientOnly old @ #clientOnly new, adamc@794: serverOnly = #serverOnly old @ #serverOnly new, adamc@794: jsFuncs = #jsFuncs old @ #jsFuncs new, adamc@794: rewrites = #rewrites old @ #rewrites new, adamc@794: filterUrl = #filterUrl old @ #filterUrl new, adamc@794: filterMime = #filterMime old @ #filterMime new, adamc@866: sources = #sources new @ #sources old, adamc@866: protocol = mergeO #2 (#protocol old, #protocol new), adamc@866: dbms = mergeO #2 (#dbms old, #dbms new) adamc@794: } adamc@794: in adamc@832: foldr (fn (fname, job) => merge (job, pu fname)) job (!libs) adamc@794: end adamc@794: adamc@794: fun parsePkind s = adamc@794: case s of adamc@794: "all" => Settings.Any adamc@794: | "url" => Settings.Url adamc@794: | "table" => Settings.Table adamc@794: | "sequence" => Settings.Sequence adamc@794: | "view" => Settings.View adamc@794: | "relation" => Settings.Relation adamc@794: | "cookie" => Settings.Cookie adamc@794: | "style" => Settings.Style adamc@794: | _ => (ErrorMsg.error "Bad path kind spec"; adamc@794: Settings.Any) adamc@794: adamc@794: fun parseFrom s = adamc@794: if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then adamc@794: (Settings.Prefix, String.substring (s, 0, size s - 1)) adamc@794: else adamc@794: (Settings.Exact, s) adamc@794: adamc@794: fun parseFkind s = adamc@794: case s of adamc@794: "url" => url adamc@794: | "mime" => mime adamc@794: | _ => (ErrorMsg.error "Bad filter kind"; adamc@794: url) adamc@794: adamc@794: fun parsePattern s = adamc@794: if size s > 0 andalso String.sub (s, size s - 1) = #"*" then adamc@794: (Settings.Prefix, String.substring (s, 0, size s - 1)) adamc@794: else adamc@794: (Settings.Exact, s) adamc@794: adamc@794: fun read () = adamc@794: case TextIO.inputLine inf of adamc@794: NONE => finish [] adamc@794: | SOME "\n" => finish (readSources []) adamc@794: | SOME line => adamc@794: let adamc@794: val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) adamc@794: val cmd = Substring.string (trim cmd) adamc@794: val arg = Substring.string (trim arg) adamc@794: adamc@794: fun ffiS () = adamc@794: case String.fields (fn ch => ch = #".") arg of adamc@794: [m, x] => (m, x) adamc@794: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); adamc@794: ("", "")) adamc@794: adamc@794: fun ffiM () = adamc@794: case String.fields (fn ch => ch = #"=") arg of adamc@794: [f, s] => adamc@794: (case String.fields (fn ch => ch = #".") f of adamc@794: [m, x] => ((m, x), s) adamc@794: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); adamc@794: (("", ""), ""))) adamc@794: | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); adamc@794: (("", ""), "")) adamc@794: in adamc@794: case cmd of adamc@794: "prefix" => adamc@794: (case !prefix of adamc@794: NONE => () adamc@794: | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; adamc@794: prefix := SOME arg) adamc@794: | "database" => adamc@794: (case !database of adamc@794: NONE => () adamc@794: | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; adamc@794: database := SOME arg) adamc@794: | "exe" => adamc@794: (case !exe of adamc@794: NONE => () adamc@794: | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; adamc@794: exe := SOME (relify arg)) adamc@794: | "sql" => adamc@794: (case !sql of adamc@794: NONE => () adamc@794: | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; adamc@794: sql := SOME (relify arg)) adamc@794: | "debug" => debug := true adamc@794: | "profile" => profile := true adamc@794: | "timeout" => adamc@794: (case !timeout of adamc@794: NONE => () adamc@794: | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; adamc@794: timeout := SOME (valOf (Int.fromString arg))) adamc@794: | "ffi" => ffi := relify arg :: !ffi adamc@794: | "link" => link := relifyA arg :: !link adamc@794: | "include" => headers := relifyA arg :: !headers adamc@794: | "script" => scripts := arg :: !scripts adamc@794: | "clientToServer" => clientToServer := ffiS () :: !clientToServer adamc@794: | "effectful" => effectful := ffiS () :: !effectful adamc@794: | "clientOnly" => clientOnly := ffiS () :: !clientOnly adamc@794: | "serverOnly" => serverOnly := ffiS () :: !serverOnly adamc@794: | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs adamc@794: | "rewrite" => adamc@794: let adamc@794: fun doit (pkind, from, to) = adamc@794: let adamc@794: val pkind = parsePkind pkind adamc@794: val (kind, from) = parseFrom from adamc@794: in adamc@794: rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites adamc@794: end adamc@794: in adamc@794: case String.tokens Char.isSpace arg of adamc@794: [pkind, from, to] => doit (pkind, from, to) adamc@794: | [pkind, from] => doit (pkind, from, "") adamc@794: | _ => ErrorMsg.error "Bad 'rewrite' syntax" adamc@794: end adamc@794: | "allow" => adamc@794: (case String.tokens Char.isSpace arg of adamc@794: [fkind, pattern] => adamc@794: let adamc@794: val fkind = parseFkind fkind adamc@794: val (kind, pattern) = parsePattern pattern adamc@794: in adamc@794: fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind adamc@794: end adamc@794: | _ => ErrorMsg.error "Bad 'allow' syntax") adamc@794: | "deny" => adamc@794: (case String.tokens Char.isSpace arg of adamc@794: [fkind, pattern] => adamc@794: let adamc@794: val fkind = parseFkind fkind adamc@794: val (kind, pattern) = parsePattern pattern adamc@794: in adamc@794: fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind adamc@794: end adamc@794: | _ => ErrorMsg.error "Bad 'deny' syntax") adamc@794: | "library" => libs := relify arg :: !libs adamc@794: | "path" => adamc@794: (case String.fields (fn ch => ch = #"=") arg of adamc@794: [n, v] => pathmap := M.insert (!pathmap, n, v) adamc@794: | _ => ErrorMsg.error "path argument not of the form name=value'") adamc@794: | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); adamc@794: read () adamc@794: end adamc@794: adamc@794: val job = read () adamc@767: in adamc@794: TextIO.closeIn inf; adamc@794: Settings.setUrlPrefix (#prefix job); adamc@794: Settings.setTimeout (#timeout job); adamc@794: Settings.setHeaders (#headers job); adamc@794: Settings.setScripts (#scripts job); adamc@794: Settings.setClientToServer (#clientToServer job); adamc@794: Settings.setEffectful (#effectful job); adamc@794: Settings.setClientOnly (#clientOnly job); adamc@794: Settings.setServerOnly (#serverOnly job); adamc@794: Settings.setJsFuncs (#jsFuncs job); adamc@794: Settings.setRewriteRules (#rewrites job); adamc@794: Settings.setUrlRules (#filterUrl job); adamc@794: Settings.setMimeRules (#filterMime job); adamc@866: Option.app Settings.setProtocol (#protocol job); adamc@866: Option.app Settings.setDbms (#dbms job); adamc@794: job adamc@767: end adamc@767: in adamc@794: pu fname adamc@767: end adamc@767: adamc@270: val parseUrp = { adamc@767: func = parseUrp', adamc@270: print = p_job adamc@270: } adamc@270: adamc@270: val toParseJob = transform parseUrp "parseJob" adamc@270: adamc@56: fun capitalize "" = "" adamc@56: | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@56: adamc@201: val parse = { adamc@764: func = fn {database, sources = fnames, ffi, ...} : job => adamc@201: let adamc@834: val anyErrors = ref false adamc@834: fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ()) adamc@201: fun nameOf fname = capitalize (OS.Path.file fname) 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 (); adamc@764: (Source.DFfiStr (mname, sgn), loc) adamc@764: end adamc@764: 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: 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: adamc@244: val ds = #func parseUr ur adamc@201: in adamc@834: checkErrors (); adamc@201: (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) adamc@201: end adamc@56: adamc@764: val dsFfi = map parseFfi ffi adamc@201: val ds = map parseOne fnames 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@201: val final = nameOf (List.last fnames) adamc@271: adamc@764: val ds = dsFfi @ ds adamc@764: @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] adamc@201: in adamc@271: case database of adamc@271: NONE => ds adamc@271: | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: 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@378: fun libFile s = OS.Path.joinDirFile {dir = Config.libUr, adamc@378: file = s} adamc@378: fun clibFile s = OS.Path.joinDirFile {dir = Config.libC, adamc@378: file = s} adamc@378: adamc@201: val elaborate = { adamc@201: func = fn file => let adamc@378: val basis = #func parseUrs (libFile "basis.urs") adamc@378: val topSgn = #func parseUrs (libFile "top.urs") adamc@378: val topStr = #func parseUr (libFile "top.ur") adamc@201: in adamc@325: Elaborate.elabFile basis topStr topSgn 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: adamc@607: val rpcify = { adamc@607: func = Rpcify.frob, adamc@607: print = CorePrint.p_file CoreEnv.empty adamc@607: } adamc@607: adamc@607: 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@642: adamc@202: val tag = { adamc@202: func = Tag.tag, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@193: adamc@642: val toTag = transform tag "tag" o toCore_untangle2 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@315: val unpoly = { adamc@315: func = Unpoly.unpoly, adamc@315: print = CorePrint.p_file CoreEnv.empty adamc@315: } adamc@315: adamc@315: val toUnpoly = transform unpoly "unpoly" o toReduce adamc@315: adamc@202: val specialize = { adamc@202: func = Specialize.specialize, adamc@202: print = CorePrint.p_file CoreEnv.empty adamc@202: } adamc@132: adamc@315: val toSpecialize = transform specialize "specialize" o toUnpoly adamc@131: adamc@642: val toShake3 = transform shake "shake3" o toSpecialize adamc@133: adamc@794: val toEspecialize = transform especialize "especialize" o toShake3 adamc@794: adamc@794: val toShake4 = transform shake "shake4" o toEspecialize 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@794: val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake4 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@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@202: 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@567: val jscomp = { adamc@567: func = JsComp.process, adamc@567: print = MonoPrint.p_file MonoEnv.empty adamc@567: } adamc@567: adamc@572: val toJscomp = transform jscomp "jscomp" o toMono_opt2 adamc@567: adamc@572: 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@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@506: val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2 adamc@377: adamc@202: val cjrize = { adamc@202: func = Cjrize.cjrize, adamc@202: print = CjrPrint.p_file CjrEnv.empty adamc@202: } adamc@23: adamc@377: val toCjrize = transform cjrize "cjrize" o toPathcheck adamc@29: adamc@643: val scriptcheck = { adamc@643: func = ScriptCheck.classify, adamc@643: print = CjrPrint.p_file CjrEnv.empty adamc@643: } adamc@643: adamc@643: val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize adamc@643: adamc@282: val prepare = { adamc@282: func = Prepare.prepare, adamc@282: print = CjrPrint.p_file CjrEnv.empty adamc@282: } adamc@282: adamc@643: val toPrepare = transform prepare "prepare" o toScriptcheck adamc@282: 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: adamc@764: fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = adamc@183: let adamc@855: val proto = Settings.currentProtocol () adamc@378: val urweb_o = clibFile "urweb.o" adamc@378: adamc@832: val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I " ^ Config.includ adamc@832: ^ " -c " ^ cname ^ " -o " ^ oname adamc@853: val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname adamc@855: ^ " " ^ #link proto ^ " -o " ^ 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: adamc@764: val link = foldl (fn (s, link) => link ^ " " ^ s) link link' adamc@183: in adamc@183: if not (OS.Process.isSuccess (OS.Process.system compile)) then adamc@183: print "C compilation failed\n" adamc@183: else if not (OS.Process.isSuccess (OS.Process.system link)) then adamc@186: print "C linking failed\n" adamc@183: else adamc@673: () adamc@183: end adamc@183: adamc@202: fun compile job = adamc@282: case run toPrepare job of adamc@244: NONE => print "Ur compilation failed\n" 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, adamc@274: fn () => (OS.FileSys.remove cname; adamc@274: OS.FileSys.remove oname; adamc@473: OS.FileSys.rmDir dir) adamc@473: handle OS.SysErr _ => OS.FileSys.rmDir 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: adamc@274: case #sql job of adamc@274: NONE => () adamc@274: | SOME sql => adamc@274: let adamc@274: val outf = TextIO.openOut sql adamc@274: val s = TextIOPP.openOut {dst = outf, wid = 80} adamc@274: in adamc@274: Print.fprint s (CjrPrint.p_sql CjrEnv.empty file); adamc@274: TextIO.closeOut outf adamc@274: end; adamc@274: adamc@742: compileC {cname = cname, oname = oname, ename = ename, libs = libs, adamc@764: profile = #profile job, debug = #debug job, link = #link job}; adamc@274: adamc@274: cleanup () adamc@274: end adamc@274: handle ex => (((cleanup ()) handle _ => ()); raise ex) adamc@202: end adamc@29: adamc@1: end