[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