diff --git a/quicktest/gene/Makefile b/quicktest/gene/Makefile index ff68b90236cc7f4153f71d719c5515708366a096..682219cf712456689f4d1a65977f3f714c9ae15a 100644 --- a/quicktest/gene/Makefile +++ b/quicktest/gene/Makefile @@ -1,6 +1,12 @@ .PHONY: all clean -OCAMLBUILD := ocamlbuild -use-ocamlfind +# Build an absolute path for Menhir. +# This is useful because ocamlbuild descends into _build. +ifndef MENHIR + READLINK := $(shell if which -s greadlink ; then echo greadlink ; else echo readlink ; fi) + MENHIR := $(shell $(READLINK) -f ../../src/_stage1/menhir.native) +endif +OCAMLBUILD := ocamlbuild -use-ocamlfind -menhir "$(MENHIR) --table" all: $(OCAMLBUILD) gene.native diff --git a/quicktest/gene/Stream.ml b/quicktest/gene/Stream.ml index ceaca83c233c81e4e20003f1543d28412a3236d7..5eb3399ff2e6da8f6c6286b058fd17eb0a643e67 100644 --- a/quicktest/gene/Stream.ml +++ b/quicktest/gene/Stream.ml @@ -41,12 +41,13 @@ let rec map f xs () = | More (x, xs) -> More (f x, map f xs) -(* An infinite, imperative stream. *) +(* A finite or infinite imperative stream. By convention, end-of-stream is + signaled via an exception. *) -type 'a infinite_imperative_stream = +type 'a imperative_stream = unit -> 'a -let fresh (xs : 'a stream) : 'a infinite_imperative_stream = +let fresh (xs : 'a stream) : 'a imperative_stream = let r = ref xs in fun () -> match !r() with @@ -56,3 +57,18 @@ let fresh (xs : 'a stream) : 'a infinite_imperative_stream = r := xs; x +(* Beware that [find] will diverge if the stream is infinite. *) + +let find (p : 'a -> bool) (xs : 'a imperative_stream) : 'a option = + try + let rec loop() = + let x = xs() in + if p x then + Some x + else + loop() + in + loop() + with End_of_file -> + None + diff --git a/quicktest/gene/gene.ml b/quicktest/gene/gene.ml index 408e6cd187228a78e154a3b9d792da0129e8f0a7..36a31ae1ba23c56b78a2f7d1ef93aaf4810f05d6 100644 --- a/quicktest/gene/gene.ml +++ b/quicktest/gene/gene.ml @@ -3,6 +3,8 @@ open Parser open Stream open Generator +(* ---------------------------------------------------------------------------- *) + (* A token printer, for debugging. *) let print_token = function @@ -26,13 +28,42 @@ let print_token = function let print_token_stream = iter print_token -(* Hooking the stream to the parser. *) +(* ---------------------------------------------------------------------------- *) + +(* Parse the command line. *) + +(* [--dry-run] offers a choice between running just the generator, or both the + generator and the parser. *) + +let dry_run = + ref false + +let options = Arg.align [ + "--dry-run", Arg.Set dry_run, "Run only the generator, not the parser"; +] + +let usage = + sprintf "Usage: %s <options>" Sys.argv.(0) + +let () = + Arg.parse options (fun _ -> ()) usage + +(* ---------------------------------------------------------------------------- *) + +(* Run. *) -let parse xs = - MenhirLib.Convert.Simplified.traditional2revised Parser.main - (fresh (map (fun token -> (token, Lexing.dummy_pos, Lexing.dummy_pos)) xs)) +let wrap token = + (token, Lexing.dummy_pos, Lexing.dummy_pos) let () = - let i : int = parse (produce 10000000) in - printf "%d\n%!" i + let tks : token stream = produce 10000000 in + let tks = fresh (map wrap tks) in + if !dry_run then begin + let _ = find (fun _ -> false) tks in + printf "Done.\n" + end + else begin + let i : int = MenhirLib.Convert.Simplified.traditional2revised Parser.main tks in + printf "%d\n%!" i + end