Ur/Web: src/compiler.sml comparison

comparison src/compiler.sml @ 764:7f653298dd66

C FFI compiler options

author	Adam Chlipala <adamc@hcoop.net>
date	Thu, 30 Apr 2009 17:15:14 -0400
parents	43553c93dd8c
children	a28982de5645

comparison

equal deleted inserted replaced

-:af41ec2f302a
+:7f653298dd66
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)
-(* Ur/Web language parser *)
 structure Compiler :> COMPILER = struct
 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
 sources : string list,
 exe : string,
 sql : string option,
 debug : bool,
 profile : bool,
-timeout : int
+timeout : int,
+ffi : string list,
+link : string list,
+headers : string list
 }
 type ('src, 'dst) phase = {
 func : 'src -> 'dst,
 print : 'dst -> Print.PD.pp_desc
 | _ => absyn
 end
 handle LrParser.ParseError => [],
 print = SourcePrint.p_file}
-fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout} =
+fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers} =
 let
 open Print.PD
 open Print
 in
 box [if debug then
 | SOME sql => string ("SQL fle: " ^ sql),
 newline,
 string "Timeout: ",
 string (Int.toString timeout),
 newline,
+p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
+p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
+p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
 string "Sources:",
 p_list string sources,
 newline]
 end
 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
 fun relify fname =
 OS.Path.concat (dir, fname)
 handle OS.Path.Path => fname
+val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
+fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
 fun readSources acc =
 case TextIO.inputLine inf of
 NONE => rev acc
 | SOME line =>
 end
 in
 readSources acc
 end
-fun finish (prefix, database, exe, sql, debug, profile, timeout, sources) =
+val prefix = ref NONE
-{prefix = Option.getOpt (prefix, "/"),
+val database = ref NONE
-database = database,
+val exe = ref NONE
-exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
+val sql = ref NONE
-ext = SOME "exe"}),
+val debug = ref false
-sql = sql,
+val profile = ref false
-debug = debug,
+val timeout = ref NONE
-profile = profile,
+val ffi = ref []
-timeout = Option.getOpt (timeout, 60),
+val link = ref []
+val headers = ref []
+fun finish sources =
+{prefix = Option.getOpt (!prefix, "/"),
+database = !database,
+exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
+ext = SOME "exe"}),
+sql = !sql,
+debug = !debug,
+profile = !profile,
+timeout = Option.getOpt (!timeout, 60),
+ffi = !ffi,
+link = !link,
+headers = !headers,
 sources = sources}
-fun read (prefix, database, exe, sql, debug, profile, timeout) =
+fun read () =
 case TextIO.inputLine inf of
-NONE => finish (prefix, database, exe, sql, debug, profile, timeout, [])
+NONE => finish []
-| SOME "\n" => finish (prefix, database, exe, sql, debug, profile, timeout, readSources [])
+| SOME "\n" => finish (readSources [])
 | SOME line =>
 let
 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
 val cmd = Substring.string (trim cmd)
 val arg = Substring.string (trim arg)
 in
 case cmd of
 "prefix" =>
-(case prefix of
+(case !prefix of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
-read (SOME arg, database, exe, sql, debug, profile, timeout))
+prefix := SOME arg)
 | "database" =>
-(case database of
+(case !database of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
-read (prefix, SOME arg, exe, sql, debug, profile, timeout))
+database := SOME arg)
 | "exe" =>
-(case exe of
+(case !exe of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
-read (prefix, database, SOME (relify arg), sql, debug, profile, timeout))
+exe := SOME (relify arg))
 | "sql" =>
-(case sql of
+(case !sql of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
-read (prefix, database, exe, SOME (relify arg), debug, profile, timeout))
+sql := SOME (relify arg))
-| "debug" => read (prefix, database, exe, sql, true, profile, timeout)
+| "debug" => debug := true
-| "profile" => read (prefix, database, exe, sql, debug, true, timeout)
+| "profile" => profile := true
 | "timeout" =>
-(case timeout of
+(case !timeout of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
-read (prefix, database, exe, sql, debug, profile, SOME (valOf (Int.fromString arg))))
+timeout := SOME (valOf (Int.fromString arg)))
-| _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
+| "ffi" => ffi := relify arg :: !ffi
-read (prefix, database, exe, sql, debug, profile, timeout))
+| "link" => link := relifyA arg :: !link
+| "include" => headers := relifyA arg :: !headers
+| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
+read ()
 end
-val job = read (NONE, NONE, NONE, NONE, false, false, NONE)
+val job = read ()
 in
 TextIO.closeIn inf;
-Monoize.urlPrefix := #prefix job;
+Settings.setUrlPrefix (#prefix job);
-CjrPrint.timeout := #timeout job;
+Settings.setTimeout (#timeout job);
+Settings.setHeaders (#headers job);
 job
 end,
 print = p_job
 }
 fun capitalize "" = ""
 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
 val parse = {
-func = fn {database, sources = fnames, ...} : job =>
+func = fn {database, sources = fnames, ffi, ...} : job =>
 let
 fun nameOf fname = capitalize (OS.Path.file fname)
+fun parseFfi fname =
+let
+val mname = nameOf fname
+val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
+val loc = {file = urs,
+first = ErrorMsg.dummyPos,
+last = ErrorMsg.dummyPos}
+val sgn = (Source.SgnConst (#func parseUrs urs), loc)
+in
+(Source.DFfiStr (mname, sgn), loc)
+end
 fun parseOne fname =
 let
 val mname = nameOf fname
 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
 val ds = #func parseUr ur
 in
 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
 end
+val dsFfi = map parseFfi ffi
 val ds = map parseOne fnames
 in
 let
 val final = nameOf (List.last fnames)
-val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
+val ds = dsFfi @ ds
+@ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
 in
 case database of
 NONE => ds
 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
 end handle Empty => ds
 print = CjrPrint.p_sql CjrEnv.empty
 }
 val toSqlify = transform sqlify "sqlify" o toMono_opt2
-fun compileC {cname, oname, ename, libs, profile, debug} =
+fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
 let
 val urweb_o = clibFile "urweb.o"
 val driver_o = clibFile "driver.o"
 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname
 val (compile, link) =
 if debug then
 (compile ^ " -g", link ^ " -g")
 else
 (compile, link)
+val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
 in
 if not (OS.Process.isSuccess (OS.Process.system compile)) then
 print "C compilation failed\n"
 else if not (OS.Process.isSuccess (OS.Process.system link)) then
 print "C linking failed\n"
 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
 TextIO.closeOut outf
 end;
 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
-profile = #profile job, debug = #debug job};
+profile = #profile job, debug = #debug job, link = #link job};
 cleanup ()
 end
 handle ex => (((cleanup ()) handle _ => ()); raise ex)
 end

Mercurial > urweb

comparison src/compiler.sml @ 764:7f653298dd66