[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