[MLton-devel] cvs commit: benchmark program command line parsing
Matthew Fluet
fluet@users.sourceforge.net
Wed, 06 Nov 2002 14:01:03 -0800
fluet 02/11/06 14:01:03
Modified: benchmark Makefile main.sml
lib/mlton/basic string.sig string0.sml
Log:
Complete rewrite of the parsing of -mlton arguments. Forget regexps,
the syntax I want to accept is just a little too complicated. Now,
supports '...' delimited tokens, arbitrary nesting of {...} splits,
arbitrary flag combinations within {...}, special # symbol to cancel
previous token, and empty elements within {...}. In short, the
following:
-mlton "mlton -v3 -native {true, false -cc 'gcc -UFOO' -ccopt {#,-fno-strict-aliasing} {-DDEBUG,}}"
yields
MLton0 -- mlton -v3 -native true
MLton1 -- mlton -v3 -native false -cc 'gcc -UFOO' -DDEBUG
MLton2 -- mlton -v3 -native false -cc 'gcc -UFOO' -ccopt -fno-strict-aliasing -DDEBUG
MLton3 -- mlton -v3 -native false -cc 'gcc -UFOO'
MLton4 -- mlton -v3 -native false -cc 'gcc -UFOO' -ccopt -fno-strict-aliasing
Note the use of # to cancel the -ccopt flag, whereas the empty element
in {-DEBUG,} is used to turn on/off a unary flag. The 'gcc -UFOO' is
parsed as a single token (although the ''s are dropped in the string
that is used in the flags of the compiler invocation). The outermost
{...}s use true in one branch and the expansion of the "false ..."
argument for the other.
Revision Changes Path
1.37 +1 -1 mlton/benchmark/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/Makefile,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- Makefile 27 Sep 2002 23:50:43 -0000 1.36
+++ Makefile 6 Nov 2002 22:00:59 -0000 1.37
@@ -57,7 +57,7 @@
QBENCH = $(BENCH)
-QBFLAGS = -mlton "mlton-stable -native-shuffle {true,false}"
+QBFLAGS = -mlton "mlton"
.PHONY: qtest
qtest: $(NAME)
1.23 +92 -142 mlton/benchmark/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/main.sml,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- main.sml 3 Nov 2002 00:28:13 -0000 1.22
+++ main.sml 6 Nov 2002 22:01:01 -0000 1.23
@@ -108,147 +108,97 @@
val n = Counter.new 0
fun make (compiler, args) =
let val exe = "a.out"
+ val args = List.keepAll (args, not o String.isEmpty)
in fn {bench} => compileSizeRun {args = args @ ["-o", exe, batch bench],
compiler = compiler,
exe = exe,
doTextPlusData = true}
end
in
- val makeMLton
- = fn arg => let
- open Regexp
-
- val compilerSave = Save.new ()
- val compiler = save (star (isChar (fn #"-" => true
- | #"/" => true
- | c => Char.isAlphaNum c)),
- compilerSave)
- val comilerC = compileDFA compiler
-
- val flagSave = Save.new ()
- val flag = seq [oneOrMore (char #" "),
- save (seq [char #"-",
- star (isChar (fn #"-" => true
- | c => Char.isAlphaNum c))],
- flagSave)]
- val flagC = compileDFA flag
-
- val optionSave = Save.new ()
- val option = save (star (isChar (fn c => Char.isAlphaNum c)),
- optionSave)
- val optionC = compileDFA option
-
- val optionsSave = Save.new ()
- val options = save (or [option,
- seq [char #"{",
- star (char #" "),
- option,
- star (seq [star (char #" "),
- char #",",
- star (char #" "),
- option]),
- star (char #" "),
- char #"}"]],
- optionsSave)
- val optionsC = compileDFA options
-
- val flagAndOptionsSave = Save.new ()
- val flagAndOptions
- = save (seq [flag,
- or [null,
- seq [oneOrMore (char #" "),
- options]]],
- flagAndOptionsSave)
- val flagAndOptionsC = compileDFA flagAndOptions
-
- val flagsAndOptionsSave = Save.new ()
- val flagsAndOptions
- = save (star flagAndOptions,
- flagsAndOptionsSave)
- val flagsAndOptionsC = compileDFA flagsAndOptions
-
- val compilerAndFlagsAndOptions
- = seq [compiler,
- flagsAndOptions]
- val compilerAndFlagsAndOptionsC
- = compileDFA compilerAndFlagsAndOptions
-
- val (compiler, flags)
- = case Compiled.matchAll(compilerAndFlagsAndOptionsC,
- arg)
- of NONE => ("mlton", [])
- | SOME m
- => let
- val {exists, lookup, peek}
- = Match.stringFuns m
-
- val compiler = lookup compilerSave
- val flagsAndOptions = lookup flagsAndOptionsSave
-
- fun doit_flags (flags, flagsAndOptions)
- = case Compiled.matchLong(flagAndOptionsC,
- flagsAndOptions,
- 0)
- of NONE => flags
- | SOME m
- => let
- val {exists, lookup, peek}
- = Match.stringFuns m
-
- val flag = lookup flagSave
-
- val {start, length} = Match.startLength m
- val flagsAndOptions
- = String.extract(flagsAndOptions,
- start + length,
- NONE)
- in
- case peek optionsSave
- of NONE => doit_flags
- ([[flag,""]]::flags,
- flagsAndOptions)
- | SOME options
- => let
- val options
- = String.fields
- (options,
- fn #"{" => true
- | #" " => true
- | #"," => true
- | #"}" => true
- | _ => false)
- val options
- = List.removeAll
- (options, String.isEmpty)
- in
- doit_flags
- ((List.map
- (options,
- fn option => [flag, option]))
- ::flags,
- flagsAndOptions)
- end
- end
- in
- (compiler,
- doit_flags ([], flagsAndOptions))
- end
- val (compiler, flags)
- = (compiler,
- List.cross (List.rev flags))
- val flags = List.map(flags, List.concat)
- fun map(nil, f) = nil
- | map(h::t, f) = (f h)::(map(t, f))
- in
- map
- (flags,
- fn flags
- => {name = concat (compiler::
- " "::
- (List.separate(flags, " "))),
- abbrv = "MLton" ^ (Int.toString (Counter.next n)),
- test = make (compiler, flags)})
- end
+ val makeMLton =
+ fn arg =>
+ let
+ fun splitLeading (s, p) =
+ case String.peeki (s, fn (i, c) => not (p c)) of
+ NONE => (s, "")
+ | SOME (i, c) => (String.extract (s, 0, SOME i),
+ String.extract (s, i, NONE))
+ fun dropLeadingSpace s = #2 (splitLeading (s, Char.isSpace))
+
+ val arg = dropLeadingSpace arg
+ val (compiler, arg) = splitLeading (arg, not o Char.isSpace)
+ val arg = dropLeadingSpace arg
+
+ fun doit (arg, flagss) =
+ if String.isEmpty arg
+ then (arg, flagss)
+ else case String.sub (arg, 0) of
+ #"'" => let
+ val arg = String.dropFirst arg
+ val (flag, arg) = splitLeading (arg, fn c => c <> #"'")
+ val arg = String.dropFirst arg
+ val arg = dropLeadingSpace arg
+ val flagss = List.map (flagss, fn flags => flag::flags)
+ in
+ doit (arg, flagss)
+ end
+ | #"{" => let
+ val arg = String.dropFirst arg
+ val arg = dropLeadingSpace arg
+
+ fun doit' (arg, flagss') =
+ let
+ val (arg, flagss) = doit (arg, flagss)
+ val flagss' = flagss @ flagss'
+ in
+ case String.sub (arg, 0) of
+ #"," => let
+ val arg = String.dropFirst arg
+ val arg = dropLeadingSpace arg
+ in
+ doit' (arg, flagss')
+ end
+ | #"}" => let
+ val arg = String.dropFirst arg
+ val arg = dropLeadingSpace arg
+ in
+ (arg, flagss')
+ end
+ | _ => raise (Fail "parsing -mlton arg")
+ end
+
+ val (arg, flagss') = doit' (arg, [])
+ in
+ doit (arg, flagss')
+ end
+ | #"," => (arg, flagss)
+ | #"}" => (arg, flagss)
+ | _ => let
+ val (flag, arg) = splitLeading
+ (arg, fn #"," => false
+ | #"}" => false
+ | c => not (Char.isSpace c))
+ val arg = dropLeadingSpace arg
+ val flagss = if flag = "#"
+ then List.map (flagss, fn flags => tl flags)
+ else List.map (flagss, fn flags => flag::flags)
+ in
+ doit (arg, flagss)
+ end
+ val (arg, flagss) = doit (arg, [[]])
+ val flagss = List.revMap (flagss, List.rev)
+ in
+ List.map
+ (flagss,
+ fn flags =>
+ {name = concat (compiler::" "::
+ (List.separate(List.map(flags, fn flag =>
+ if String.contains (flag, #" ")
+ then "'" ^ flag ^ "'"
+ else flag), " "))),
+ abbrv = "MLton" ^ (Int.toString (Counter.next n)),
+ test = make (compiler, flags)})
+ end
end
fun kitCompile {bench} =
@@ -474,7 +424,7 @@
let open Signal
in ignore pipe
end
- fun r2s r = Real.format (r, Real.Format.fix (SOME 1))
+ fun r2s r = Real.format (r, Real.Format.fix (SOME 2))
val i2s = Int.toCommaString
val s2s = fn s => s
val failures = ref []
@@ -619,8 +569,8 @@
File.temp
{prefix = "tmp", suffix = "err"}
val {compile, run, size} =
- ignoreOutput
- (fn () => test {bench = bench})
+ ignoreOutput
+ (fn () => test {bench = bench})
val _ =
if name = base
andalso Option.isNone run
@@ -633,8 +583,8 @@
File.foldLines
(outTmpFile, NONE, fn (s, v) =>
let val s = String.removeTrailing
- (s, fn c =>
- Char.equals (c, Char.newline))
+ (s, fn c =>
+ Char.equals (c, Char.newline))
in
case doit s of
NONE => v
@@ -647,8 +597,8 @@
File.foldLines
(errTmpFile, NONE, fn (s, v) =>
let val s = String.removeTrailing
- (s, fn c =>
- Char.equals (c, Char.newline))
+ (s, fn c =>
+ Char.equals (c, Char.newline))
in
case doit s of
NONE => v
1.4 +1 -0 mlton/lib/mlton/basic/string.sig
Index: string.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- string.sig 12 Sep 2002 03:14:55 -0000 1.3
+++ string.sig 6 Nov 2002 22:01:02 -0000 1.4
@@ -29,6 +29,7 @@
val deleteSurroundingWhitespace: t -> t
val dquote: t (* " *)
val dropl: t * (char -> bool) -> t
+ val dropFirst: t -> t
val dropLast: t -> t
val dropPrefix: t * int -> t
val dropSuffix: t * int -> t
1.4 +3 -0 mlton/lib/mlton/basic/string0.sml
Index: string0.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string0.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- string0.sml 12 Sep 2002 03:14:55 -0000 1.3
+++ string0.sml 6 Nov 2002 22:01:02 -0000 1.4
@@ -81,9 +81,12 @@
substring1 (s, {start = length s - len,
length = len})
+fun dropPrefix (s,n) =
+ substring1 (s, {start=n, length = length s - n})
fun dropSuffix (s,n) =
substring1 (s, {start=0, length = length s - n})
+fun dropFirst s = dropPrefix (s, 1)
fun dropLast s = dropSuffix (s, 1)
fun dropPrefix (s, n) =
-------------------------------------------------------
This sf.net email is sponsored by: See the NEW Palm
Tungsten T handheld. Power & Color in a compact size!
http://ads.sourceforge.net/cgi-bin/redirect.pl?palm0001en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel