[MLton-devel] cvs commit: another aproach to benchmark command line parsing

Stephen Weeks sweeks@users.sourceforge.net
Wed, 06 Nov 2002 17:36:56 -0800


sweeks      02/11/06 17:36:56

  Modified:    .        Makefile
               benchmark benchmark-stubs.cm benchmark.cm main.sml
               benchmark/tests vector-rev.sml
               bin      mlton
               lib/mlton sources.cm
               lib/mlton/basic process.sig process.sml sources.cm
                        string.sig string.sml string1.sml
               mlprof   main.sml
               mlton    mlton-stubs.cm mlton.cm
               mlton/main main.sml
  Added:       lib/mlton/basic choice-pattern.sig choice-pattern.sml
  Log:
  This approach differs from Matthew's in that there is a generic
  ChoicePattern.expand function that only knows about brace-delimited
  comma separated lists (e.g. {foo,bar,baz}) and it expands on a purely
  textual level with no notion of tokenization.  Hopefully that makes it
  more generally useful.  Now, the benchmark script doesn't attempt to
  do any tokenization/parsing of the -mlton arg.  It simply does the
  choice expansion and calls sh -c.
  
  The approach supports nested {}, but not # since it has no notion of
  tokenization.  But # isn't needed.  Matthew's earlier example can be
  handled with
  
  -mlton "mlton -v3 -native {true,false -cc gcc{, -ccopt -fno-strict-aliasing}{ -DDEBUG,}}"
  
  I also changed -cc so that you can only specify the gcc executable and
  no command line switches and so that -cc always resets the switch
  list.  There was really no need to allow switches with -cc since we
  can do them with -ccopt.

Revision  Changes    Path
1.76      +1 -0      mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- Makefile	2 Nov 2002 23:51:46 -0000	1.75
+++ Makefile	7 Nov 2002 01:36:51 -0000	1.76
@@ -47,6 +47,7 @@
 	$(MAKE) -C $(LEX) mllex_cm
 	$(MAKE) -C $(PROF) mlprof_cm
 	$(MAKE) -C $(YACC) mlyacc_cm
+	$(MAKE) -C benchmark benchmark_cm
 
 .PHONY: compiler
 compiler:



1.2       +9 -3      mlton/benchmark/benchmark-stubs.cm

Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- benchmark-stubs.cm	16 Apr 2002 13:17:40 -0000	1.1
+++ benchmark-stubs.cm	7 Nov 2002 01:36:52 -0000	1.2
@@ -1,21 +1,24 @@
 Group is
 ../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/random.sig
+../lib/mlton-stubs/random.sml
 ../lib/mlton-stubs/world.sig
 ../lib/mlton-stubs/word.sig
 ../lib/mlton-stubs/vector.sig
 ../lib/mlton-stubs/thread.sig
+../lib/mlton-stubs/io.sig
 ../lib/mlton-stubs/text-io.sig
 ../lib/mlton-stubs/syslog.sig
 ../lib/mlton-stubs/socket.sig
 ../lib/mlton-stubs/signal.sig
 ../lib/mlton-stubs/rusage.sig
 ../lib/mlton-stubs/rlimit.sig
-../lib/mlton-stubs/random.sig
 ../lib/mlton-stubs/ptrace.sig
 ../lib/mlton-stubs/profile.sig
 ../lib/mlton-stubs/process.sig
 ../lib/mlton-stubs/proc-env.sig
 ../lib/mlton-stubs/array.sig
+../lib/mlton-stubs/bin-io.sig
 ../lib/mlton-stubs/cont.sig
 ../lib/mlton-stubs/exn.sig
 ../lib/mlton-stubs/gc.sig
@@ -23,6 +26,7 @@
 ../lib/mlton-stubs/itimer.sig
 ../lib/mlton-stubs/mlton.sig
 ../lib/mlton-stubs/mlton.sml
+../lib/mlton-stubs/real.sml
 ../lib/mlton/pervasive/pervasive.sml
 ../lib/mlton/basic/dynamic-wind.sig
 ../lib/mlton/basic/dynamic-wind.sml
@@ -92,6 +96,8 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -147,8 +153,6 @@
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/dir.sig
@@ -161,5 +165,7 @@
 ../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/escape.sig
 ../lib/mlton/basic/escape.sml
+../lib/mlton/basic/choice-pattern.sig
+../lib/mlton/basic/choice-pattern.sml
 main.sml
 call-main.sml



1.7       +4 -2      mlton/benchmark/benchmark.cm

Index: benchmark.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- benchmark.cm	16 Apr 2002 13:17:40 -0000	1.6
+++ benchmark.cm	7 Nov 2002 01:36:52 -0000	1.7
@@ -68,6 +68,8 @@
 ../lib/mlton/basic/euclidean-ring.fun
 ../lib/mlton/basic/integer.fun
 ../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/ordered-field.sig
 ../lib/mlton/basic/field.sig
 ../lib/mlton/basic/field.fun
@@ -123,8 +125,6 @@
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
 ../lib/mlton/basic/function.sig
 ../lib/mlton/basic/function.sml
 ../lib/mlton/basic/dir.sig
@@ -137,5 +137,7 @@
 ../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/escape.sig
 ../lib/mlton/basic/escape.sml
+../lib/mlton/basic/choice-pattern.sig
+../lib/mlton/basic/choice-pattern.sml
 main.sml
 call-main.sml



1.24      +51 -115   mlton/benchmark/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/main.sml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- main.sml	6 Nov 2002 22:01:01 -0000	1.23
+++ main.sml	7 Nov 2002 01:36:52 -0000	1.24
@@ -12,6 +12,10 @@
 
 val fail = Process.fail
 
+fun usage msg =
+   Process.usage {usage = "[-mlkit] [-mosml] [-smlnj] bench1 bench2 ...",
+		  msg = msg}
+
 val doHtml = ref false
 val doOnce = ref false
 val runArgs : string list ref = ref []
@@ -47,11 +51,19 @@
        fn () => close nullFd)
    end
 
-fun timeIt (com, args) =
-   Process.time (fn () =>
-		 Process.wait
-		 (Process.spawnp {file = com, args = com :: args}))
-
+datatype command =
+   Explicit of {args: string list,
+		com: string}
+  | Shell of string
+
+fun timeIt ca =
+   Process.time
+   (fn () =>
+    case ca of
+       Explicit {args, com} =>
+	  Process.wait (Process.spawnp {file = com, args = com :: args})
+     | Shell s => Process.system s)
+   
 local
    val trialTime = Time.seconds (IntInf.fromInt 60)
 in
@@ -59,7 +71,7 @@
       let 
 	 fun doit ac =
 	    let
-	       val {user, system} = timeIt (com, args)
+	       val {user, system} = timeIt (Explicit {args = args, com = com})
 	       val op + = Time.+
 	    in ac + user + system
 	    end
@@ -73,13 +85,13 @@
 	 else loop (0, Time.zero)
       end
 end
-
-fun compileSizeRun {args, compiler, exe, doTextPlusData: bool} =
+   
+fun compileSizeRun {command, exe, doTextPlusData: bool} =
    Escape.new
    (fn e =>
     let
        val exe = "./" ^ exe
-       val {system, user} = timeIt (compiler, args)
+       val {system, user} = timeIt command
 	  handle _ => Escape.escape (e, {compile = NONE,
 					 run = NONE,
 					 size = NONE})
@@ -105,113 +117,37 @@
 fun batch bench = concat [bench, ".batch.sml"]
 
 local
-  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
+   val n = Counter.new 0
+   val exe = "a.out"
 in
-  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
+   fun makeMLton commandPattern =
+      case ChoicePattern.expand commandPattern of
+	 Result.No m => usage m
+       | Result.Yes coms => 
+	    List.map
+	    (coms, fn com =>
+	     {name = com,
+	      abbrv = "MLton" ^ (Int.toString (Counter.next n)),
+	      test = (fn {bench} =>
+		      compileSizeRun
+		      {command = Shell (concat [com, " -o ", exe, " ", batch bench]),
+		       exe = exe,
+		       doTextPlusData = true})})
 end
 
 fun kitCompile {bench} =
-   compileSizeRun {args = [batch bench],
-		   compiler = "mlkit",
+   compileSizeRun {command = Explicit {args = [batch bench],
+				       com = "mlkit"},
 		   exe = "run",
 		   doTextPlusData = true}
    
 fun mosmlCompile {bench} =
-   compileSizeRun {args = ["-orthodox", "-standalone", "-toplevel", batch bench],
-		   compiler = "mosmlc",
-		   exe = "a.out",
-		   doTextPlusData = false}
+   compileSizeRun
+   {command = Explicit {args = ["-orthodox", "-standalone", "-toplevel",
+				batch bench],
+			com = "mosmlc"},
+    exe = "a.out",
+    doTextPlusData = false}
 
 fun njCompile {bench} =
    Escape.new
@@ -231,7 +167,8 @@
 		["in val _ = SMLofNJ.exportFn (\"", bench,
 		 "\", fn _ =>\n (Main.doit () ; OS.Process.success))\nend\n"]
 		 ))),
-           fn input => withInput (input, fn () => timeIt (sml, [])))
+           fn input => withInput (input, fn () => timeIt (Explicit {args = [],
+								    com = sml})))
          handle _ => Escape.escape (e, {compile = NONE,
 					run = NONE,
 					size = NONE})
@@ -276,7 +213,11 @@
 		concat ["use \"", bench, ".sml\" handle _ => PolyML.quit ();\n",
 			"if PolyML.commit() then () else (Main.doit(); ());\n",
 			"PolyML.quit();\n"]),
-	       fn input => withInput (input, fn () => timeIt ("poly", [dbase])))
+	       fn input =>
+	       withInput
+	       (input, fn () =>
+		timeIt (Explicit {args = [dbase],
+				  com = "poly"})))
 	   val after = File.size dbase
 	in
 	   if original = after
@@ -300,14 +241,9 @@
 	end)
     end)
 
-fun usage msg =
-   Process.usage {usage = "[-mlkit] [-mosml] [-smlnj] bench1 bench2 ...",
-		  msg = msg}
-
 type 'a data = {bench: string,
 		compiler: string,
 		value: 'a} list
-
 
 fun main args =
    let



1.3       +1 -1      mlton/benchmark/tests/vector-rev.sml

Index: vector-rev.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/tests/vector-rev.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- vector-rev.sml	27 Sep 2002 23:46:29 -0000	1.2
+++ vector-rev.sml	7 Nov 2002 01:36:52 -0000	1.3
@@ -21,6 +21,6 @@
 		  if 0 = sub (rev (rev v), 0)
 		     then loop (n - 1)
 		  else raise Fail "bug"
-	 in loop 10000
+	 in loop 1
 	 end
    end



1.17      +4 -3      mlton/bin/mlton

Index: mlton
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/mlton,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton	5 Nov 2002 20:27:06 -0000	1.16
+++ mlton	7 Nov 2002 01:36:52 -0000	1.17
@@ -39,14 +39,15 @@
 # can find the gmp.
 
 doit "$lib" \
-	-cc "$gcc -w 
-		-falign-functions=5
+	-cc "$gcc" \
+	-ccopt '-falign-functions=5
 		-falign-jumps=2 
 		-fno-strength-reduce
 		-fomit-frame-pointer
 		-fschedule-insns 
 		-fschedule-insns2
 		-malign-loops=2
-		-mcpu=pentiumpro" \
+		-mcpu=pentiumpro
+		-w' \
 	-lm \
 	"$@"



1.14      +1 -0      mlton/lib/mlton/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/sources.cm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- sources.cm	2 Nov 2002 03:37:36 -0000	1.13
+++ sources.cm	7 Nov 2002 01:36:53 -0000	1.14
@@ -53,6 +53,7 @@
 structure CharArray
 structure CharBuffer
 structure CharVector
+structure ChoicePattern
 structure ClearablePromise
 structure CommandLine
 structure Computation



1.6       +1 -0      mlton/lib/mlton/basic/process.sig

Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/process.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- process.sig	2 Nov 2002 23:49:31 -0000	1.5
+++ process.sig	7 Nov 2002 01:36:54 -0000	1.6
@@ -71,6 +71,7 @@
       val spawnp: {file: string, args: string list} -> Pid.t
       val su: string -> unit (* string is userid *)
       val succeed: unit -> 'a
+      val system: string -> unit
       val time: (unit -> unit) -> {system: Time.t, user: Time.t}
       (* try (f, m) tries f with exponentially backed off times, stopping after
        * a minute of trying, in which case is fails with m.



1.9       +11 -0     mlton/lib/mlton/basic/process.sml

Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/process.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- process.sml	2 Nov 2002 23:49:31 -0000	1.8
+++ process.sml	7 Nov 2002 01:36:54 -0000	1.9
@@ -14,6 +14,17 @@
    val messageStr = messageStr
 end
 
+fun system s =
+   let
+      val status = OS.Process.system s
+   in
+      if status = OS.Process.success
+	 then ()
+      else if status = OS.Process.failure
+	      then raise Fail (concat ["command failed: ", s])
+	   else raise Fail "strange return"
+   end
+
 structure Command =
    struct
       type t = In.t * Out.t -> unit



1.15      +3 -0      mlton/lib/mlton/basic/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/sources.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- sources.cm	2 Nov 2002 03:37:36 -0000	1.14
+++ sources.cm	7 Nov 2002 01:36:54 -0000	1.15
@@ -30,6 +30,7 @@
 structure CharArray
 structure CharBuffer
 structure CharVector
+structure ChoicePattern
 structure ClearablePromise
 structure CommandLine
 structure Computation
@@ -167,6 +168,8 @@
 char.sig
 char.sml
 char0.sml
+choice-pattern.sig
+choice-pattern.sml
 circular-list.fun
 circular-list.sig
 clearable-promise.sig



1.5       +2 -0      mlton/lib/mlton/basic/string.sig

Index: string.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- string.sig	6 Nov 2002 22:01:02 -0000	1.4
+++ string.sig	7 Nov 2002 01:36:54 -0000	1.5
@@ -52,6 +52,7 @@
       val fromCString: t -> t option
       val fromChar: char -> t
       val fromCharArray: CharArray.array -> t
+      val fromListRev: char list -> t
       val fromString: t -> t option
       val hash: t -> Word.t
       val implode: char list -> t
@@ -76,6 +77,7 @@
       val posToLineCol: t -> int -> {line: int, col: int}
       val prefix: t * int -> t
       val removeTrailing: t * (char -> bool) -> t
+      val rev: t -> t
       val rparen: t (* ) *)
       val size: t -> int
       (* splits the string into substrings broken at char,



1.3       +6 -5      mlton/lib/mlton/basic/string.sml

Index: string.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- string.sml	10 Apr 2002 07:50:31 -0000	1.2
+++ string.sml	7 Nov 2002 01:36:54 -0000	1.3
@@ -11,7 +11,8 @@
       open String1
 
       fun keepAll (s: t, f: char -> bool): t =
-	 implode (rev (fold (s, [], fn (c, ac) => if f c then c :: ac else ac)))
+	 implode (List.rev
+		  (fold (s, [], fn (c, ac) => if f c then c :: ac else ac)))
 	 
       fun memoizeList (init: string -> 'a, l: (t * 'a) list): t -> 'a =
 	 let
@@ -38,10 +39,10 @@
 	    open Int
 	    val lineStarts =
 	       Array.fromList
-	       (rev (foldi (s, [0], fn (i, c, is) =>
-			    if c = #"\n"
-			       then (i + 1) :: is
-			    else is)))
+	       (List.rev (foldi (s, [0], fn (i, c, is) =>
+				 if c = #"\n"
+				    then (i + 1) :: is
+				 else is)))
 	    fun find (pos: int) =
 	       let
 		  val line =



1.4       +56 -44    mlton/lib/mlton/basic/string1.sml

Index: string1.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/string1.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- string1.sml	10 Apr 2002 07:50:31 -0000	1.3
+++ string1.sml	7 Nov 2002 01:36:54 -0000	1.4
@@ -5,55 +5,67 @@
  * Please see the file MLton-LICENSE for license information.
  *)
 structure String1 =
-   struct
-      open String0
+struct
+
+open String0
 	 
-      structure F = Fold (type 'a t = string
-			  type 'a elt = char
-			  val fold = fold)
-      open F
-      type t = string
+structure F = Fold (type 'a t = string
+		    type 'a elt = char
+		    val fold = fold)
+open F
+type t = string
 	 
-      val last = String0.last
-
-      val layout = Layout.str o escapeSML
+val last = String0.last
+	 
+val layout = Layout.str o escapeSML
 
-      (* This hash function is taken from pages 56-57 of
-       * The Practice of Programming by Kernighan and Pike.
-       *)
-      fun hash (s: t): Word.t =
-	 fold (s, 0w0, fn (c, h) => Word.fromChar c + Word.* (h, 0w31))
+(* This hash function is taken from pages 56-57 of
+ * The Practice of Programming by Kernighan and Pike.
+ *)
+fun hash (s: t): Word.t =
+   fold (s, 0w0, fn (c, h) => Word.fromChar c + Word.* (h, 0w31))
 	 
-      fun dropl (s, p) =
-	 case peeki (s, fn (_, c) => not (p c)) of
-	    NONE => ""
-	  | SOME (i, _) => extract (s, i, NONE)
-
-      fun deleteSurroundingWhitespace (s: t): t =
-	 let
-	    val n = size s
-	    fun loop (i: int) =
-	       if i = n
-		  then s
-	       else
-		  if Char.isSpace (sub (s, i))
-		     then loop (i + 1)
-		  else
+fun dropl (s, p) =
+   case peeki (s, fn (_, c) => not (p c)) of
+      NONE => ""
+    | SOME (i, _) => extract (s, i, NONE)
+
+fun deleteSurroundingWhitespace (s: t): t =
+   let
+      val n = size s
+      fun loop (i: int) =
+	 if i = n
+	    then s
+	 else
+	    if Char.isSpace (sub (s, i))
+	       then loop (i + 1)
+	    else
+	       let
+		  fun loop (j: int) =
 		     let
-			fun loop (j: int) =
-			   let
-			      val c = sub (s, j)
-			   in
-			      if j = i
-				 then fromChar c
-			      else
-				 if Char.isSpace c
-				    then loop (j - 1)
-				 else extract (s, i, SOME (j - i + 1))
-			   end
+			val c = sub (s, j)
 		     in
-			loop (n - 1)
+			if j = i
+			   then fromChar c
+			else
+			   if Char.isSpace c
+			      then loop (j - 1)
+			   else extract (s, i, SOME (j - i + 1))
 		     end
-	 in loop 0
-	 end
+	       in
+		  loop (n - 1)
+	       end
+   in loop 0
    end
+
+fun rev (s: t): t =
+   let
+      val n = size s
+      val n1 = n - 1
+   in
+      CharVector.tabulate (n, fn i => sub (s, n1 - i))
+   end
+
+val fromListRev = rev o implode
+
+end



1.1                  mlton/lib/mlton/basic/choice-pattern.sig

Index: choice-pattern.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature CHOICE_PATTERN =
   sig
      (* expand "ab{c{d,e},f{gh}}{i,j}" =
       * ["abcdi", "abcdj", "abcei", "abcej", "abfghi", "abfghj"]
       *)
      val expand: string -> string list Result.t
   end



1.1                  mlton/lib/mlton/basic/choice-pattern.sml

Index: choice-pattern.sml
===================================================================
structure ChoicePattern: CHOICE_PATTERN =
struct

datatype t =
   Concat of t vector
 | Choice of t vector
 | String of string

fun layout t =
   let
      open Layout
   in
      case t of
	 Concat v => seq [str "Concat ", Vector.layout layout v]
       | Choice v => seq [str "Choice ", Vector.layout layout v]
       | String s => seq [str "\"", String.layout s, str "\""]
   end

fun fromString (s: string): t Result.t =
   let
      val n = String.size s
      exception Error of string
      fun error ss = raise Error (concat ss)
      datatype state =
	 Nest of {start: int}
	| Normal
      fun loop (cur: int,
		ac: char list,
		prev: t list,
		prevChoices: t list,
		state: state): int * t =
	 let
	    fun accum () = String (String.fromListRev ac) :: prev
	    fun finishChoice () =
	       Concat (Vector.fromListRev (accum ())) :: prevChoices
	    fun keepChar cur =
	       loop (cur + 1, String.sub (s, cur) :: ac,
		     prev, prevChoices, state)
	 in
	    if cur = n
	       then
		  (case state of
		      Nest {start} =>
			 error ["unmatched { at position ",
				Int.toString start]
		    | Normal =>
			 (cur, Concat (Vector.fromListRev (accum ()))))
	    else
	       let
		  val c = String.sub (s, cur)
	       in
		  case c of
		     #"{" => let
				val (cur, t) =
				   loop (cur + 1, [], [], [], Nest {start = cur})
			     in
				loop (cur, [], t :: accum (), prevChoices, state)
			     end
		   | #"}" =>
			(case state of
			    Nest _ =>
			       (cur + 1,
				Choice (Vector.fromList (finishChoice ())))
			  | Normal =>
			       error ["unmatched } at position ",
				      Int.toString cur])
		   | #"," =>
			(case state of
			    Nest _ => loop (cur + 1, [], [], finishChoice (),
					      state)
			  | Normal => keepChar cur)
		   | #"\\" =>
			let
			   val cur = cur + 1
			in
			   if cur = n
			      then error ["terminating backslash"]
			   else keepChar cur
			end
		   | _ => keepChar cur
	       end
	 end
   in
      Result.Yes (#2 (loop (0, [], [], [], Normal)))
      handle Error s => Result.No s
   end

val fromString =
   Trace.trace ("ChoicePattern.fromString", String.layout, Result.layout layout)
   fromString

fun foldDown (v, a, f) =
   let
      fun loop (i, a) =
	 if i < 0
	    then a
	 else loop (i - 1, f (Vector.sub (v, i), a))
   in
      loop (Vector.length v - 1, a)
   end

fun expandTree (t: t): string list =
   case t of
      Choice v =>
	 Vector.fold (v, [], fn (t, ac) =>
		      expandTree t @ ac)
    | Concat v =>
	 foldDown (v, [""], fn (t, ac) =>
		   List.fold
		   (expandTree t, [], fn (s, all) =>
		    List.fold
		    (ac, all, fn (s', all) =>
		     concat [s, s'] :: all)))
    | String s => [s]

fun expand (s: string): string list Result.t =
   Result.map (fromString s, expandTree)

val _ = let open Trace.Immediate
	in
	   debug := Out Out.error
	   ; flagged ()
	   ; on ["ChoicePattern.fromString"]
	end
end      



1.15      +1 -1      mlton/mlprof/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- main.sml	3 Nov 2002 00:28:13 -0000	1.14
+++ main.sml	7 Nov 2002 01:36:55 -0000	1.15
@@ -19,7 +19,7 @@
 val thresh: int ref = ref 0
 
 val die = Process.fail
-
+   
 structure Regexp =
 struct
   open Regexp



1.6       +6 -6      mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mlton-stubs.cm	2 Nov 2002 03:37:38 -0000	1.5
+++ mlton-stubs.cm	7 Nov 2002 01:36:55 -0000	1.6
@@ -60,8 +60,6 @@
 ../lib/mlton/basic/substring.sml
 ../lib/mlton/basic/outstream.sig
 ../lib/mlton/basic/outstream.sml
-../lib/mlton/basic/exn.sig
-../lib/mlton/basic/exn.sml
 ../lib/mlton/basic/promise.sig
 ../lib/mlton/basic/promise.sml
 ../lib/mlton/basic/instream0.sml
@@ -90,6 +88,8 @@
 ../lib/mlton/basic/pid.sml
 ../lib/mlton/basic/date.sig
 ../lib/mlton/basic/date.sml
+../lib/mlton/basic/exn.sig
+../lib/mlton/basic/exn.sml
 ../lib/mlton/basic/t.sig
 ../lib/mlton/basic/unit.sig
 ../lib/mlton/basic/unit.sml
@@ -157,10 +157,6 @@
 ../lib/mlton/basic/result.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
-../lib/mlton/basic/justify.sig
-../lib/mlton/basic/justify.sml
-../lib/mlton/basic/popt.sig
-../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/function.sig
@@ -168,6 +164,10 @@
 ../lib/mlton/basic/signal.sml
 ../lib/mlton/basic/process.sig
 ../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
+../lib/mlton/basic/popt.sig
+../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/control.sig
 ../lib/mlton/basic/control.fun
 control/source-pos.sig



1.55      +6 -6      mlton/mlton/mlton.cm

Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- mlton.cm	2 Nov 2002 03:37:38 -0000	1.54
+++ mlton.cm	7 Nov 2002 01:36:55 -0000	1.55
@@ -32,8 +32,6 @@
 ../lib/mlton/basic/substring.sml
 ../lib/mlton/basic/outstream.sig
 ../lib/mlton/basic/outstream.sml
-../lib/mlton/basic/exn.sig
-../lib/mlton/basic/exn.sml
 ../lib/mlton/basic/promise.sig
 ../lib/mlton/basic/promise.sml
 ../lib/mlton/basic/instream0.sml
@@ -62,6 +60,8 @@
 ../lib/mlton/basic/pid.sml
 ../lib/mlton/basic/date.sig
 ../lib/mlton/basic/date.sml
+../lib/mlton/basic/exn.sig
+../lib/mlton/basic/exn.sml
 ../lib/mlton/basic/t.sig
 ../lib/mlton/basic/unit.sig
 ../lib/mlton/basic/unit.sml
@@ -129,10 +129,6 @@
 ../lib/mlton/basic/result.sml
 ../lib/mlton/basic/dir.sig
 ../lib/mlton/basic/dir.sml
-../lib/mlton/basic/justify.sig
-../lib/mlton/basic/justify.sml
-../lib/mlton/basic/popt.sig
-../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/file-desc.sig
 ../lib/mlton/basic/file-desc.sml
 ../lib/mlton/basic/function.sig
@@ -140,6 +136,10 @@
 ../lib/mlton/basic/signal.sml
 ../lib/mlton/basic/process.sig
 ../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
+../lib/mlton/basic/popt.sig
+../lib/mlton/basic/popt.sml
 ../lib/mlton/basic/control.sig
 ../lib/mlton/basic/control.fun
 control/source-pos.sig



1.92      +6 -12     mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -r1.91 -r1.92
--- main.sml	5 Nov 2002 20:44:29 -0000	1.91
+++ main.sml	7 Nov 2002 01:36:55 -0000	1.92
@@ -37,8 +37,8 @@
 
 val buildConstants: bool ref = ref false
 val coalesce: int option ref = ref NONE
-val gcc: string ref = ref "gcc"
-val gccSwitches : string list ref = ref []
+val gcc: string ref = ref "<unset>"
+val gccSwitches : string ref = ref ""
 val includeDirs: string list ref = ref []
 val keepGenerated = ref false
 val keepO = ref false
@@ -80,14 +80,8 @@
        (Expert, "card-size-log2", " n",
 	"log (base 2) of card size used by GC",
 	intRef cardSizeLog2),
-       (Expert, "cc", " gcc", "gcc command line",
-	SpaceString (fn s =>
-		     case String.tokens (s, Char.isSpace) of
-			x :: xs => (gcc := x
-				    ; (case xs of
-					  [] => ()
-					| _ => gccSwitches := xs))
-		      | _ => usage "-cc must specify gcc")),
+       (Expert, "cc", " gcc", "path to gcc executable",
+	SpaceString (fn s => (gcc := s; gccSwitches := ""))),
        (Expert, "coalesce", " n", "coalesce chunk size for C codegen",
 	Int (fn n => coalesce := SOME n)),
        (Expert, "ccopt", " opt", "pass option to C compiler",
@@ -97,7 +91,7 @@
 			then (optimization
 			      := Char.toInt (String.sub (s, 2))
 			         - Char.toInt #"0")
-		     else List.push (gccSwitches, s))),
+		     else gccSwitches := concat [!gccSwitches, " ", s])),
        (Expert, "debug", " {false|true}", "produce executable with debug info",
 	boolRef debug),
        (Normal, "detect-overflow", " {true|false}",
@@ -569,7 +563,7 @@
 			    [concat ["-O", Int.toString (!optimization)]],
 			    if !Native.native
 			       then []
-			    else !gccSwitches]
+			    else String.tokens (!gccSwitches, Char.isSpace)]
 			val switches =
 			   case host of
 			      Cross s => "-b" :: s :: switches





-------------------------------------------------------
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