diff options
Diffstat (limited to 'ocamltest')
| -rw-r--r-- | ocamltest/.depend | 20 | ||||
| -rw-r--r-- | ocamltest/Makefile | 3 | ||||
| -rw-r--r-- | ocamltest/main.ml | 32 | ||||
| -rw-r--r-- | ocamltest/ocamltest.org | 135 | ||||
| -rw-r--r-- | ocamltest/options.ml | 16 | ||||
| -rw-r--r-- | ocamltest/options.mli | 4 | ||||
| -rw-r--r-- | ocamltest/tests.ml | 7 | ||||
| -rw-r--r-- | ocamltest/tests.mli | 2 | ||||
| -rw-r--r-- | ocamltest/translate.ml | 138 | ||||
| -rw-r--r-- | ocamltest/translate.mli | 23 | ||||
| -rw-r--r-- | ocamltest/tsl_ast.ml | 2 | ||||
| -rw-r--r-- | ocamltest/tsl_ast.mli | 4 | ||||
| -rw-r--r-- | ocamltest/tsl_lexer.mli | 2 | ||||
| -rw-r--r-- | ocamltest/tsl_lexer.mll | 21 | ||||
| -rw-r--r-- | ocamltest/tsl_parser.mly | 33 | ||||
| -rw-r--r-- | ocamltest/tsl_semantics.ml | 113 | ||||
| -rw-r--r-- | ocamltest/tsl_semantics.mli | 13 |
17 files changed, 474 insertions, 94 deletions
diff --git a/ocamltest/.depend b/ocamltest/.depend index dac34bc788..81085ddc3a 100644 --- a/ocamltest/.depend +++ b/ocamltest/.depend @@ -94,6 +94,7 @@ main.cmo : \ tsl_semantics.cmi \ tsl_parser.cmi \ tsl_lexer.cmi \ + translate.cmi \ tests.cmi \ result.cmi \ options.cmi \ @@ -107,6 +108,7 @@ main.cmx : \ tsl_semantics.cmx \ tsl_parser.cmx \ tsl_lexer.cmx \ + translate.cmx \ tests.cmx \ result.cmx \ options.cmx \ @@ -364,15 +366,18 @@ ocamltest_unix.cmx : \ ocamltest_unix.cmi : options.cmo : \ variables.cmi \ + translate.cmi \ tests.cmi \ actions.cmi \ options.cmi options.cmx : \ variables.cmx \ + translate.cmx \ tests.cmx \ actions.cmx \ options.cmi -options.cmi : +options.cmi : \ + translate.cmi result.cmo : \ result.cmi result.cmx : \ @@ -405,6 +410,19 @@ tests.cmi : \ result.cmi \ environments.cmi \ actions.cmi +translate.cmo : \ + tsl_semantics.cmi \ + tsl_parser.cmi \ + tsl_lexer.cmi \ + tsl_ast.cmi \ + translate.cmi +translate.cmx : \ + tsl_semantics.cmx \ + tsl_parser.cmx \ + tsl_lexer.cmx \ + tsl_ast.cmx \ + translate.cmi +translate.cmi : tsl_ast.cmo : \ tsl_ast.cmi tsl_ast.cmx : \ diff --git a/ocamltest/Makefile b/ocamltest/Makefile index b71523f9b6..34690fd411 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -46,7 +46,8 @@ core := \ tsl_semantics.mli tsl_semantics.ml \ builtin_variables.mli builtin_variables.ml \ actions_helpers.mli actions_helpers.ml \ - builtin_actions.mli builtin_actions.ml + builtin_actions.mli builtin_actions.ml \ + translate.mli translate.ml ocaml_plugin := \ ocaml_backends.mli ocaml_backends.ml \ diff --git a/ocamltest/main.ml b/ocamltest/main.ml index ae49bacd09..f0643e56b6 100644 --- a/ocamltest/main.ml +++ b/ocamltest/main.ml @@ -29,23 +29,29 @@ let announce_test_error test_filename error = Printf.printf " ... testing '%s' => unexpected error (%s)\n%!" (Filename.basename test_filename) error -let tsl_block_of_file test_filename = +exception Syntax_error of Lexing.position + +let tsl_parse_file test_filename = let input_channel = open_in test_filename in let lexbuf = Lexing.from_channel input_channel in Location.init lexbuf test_filename; - match Tsl_parser.tsl_block Tsl_lexer.token lexbuf with + match Tsl_parser.tsl_script Tsl_lexer.token lexbuf with + | exception Parsing.Parse_error -> + raise (Syntax_error lexbuf.Lexing.lex_start_p) | exception e -> close_in input_channel; raise e | _ as tsl_block -> close_in input_channel; tsl_block -let tsl_block_of_file_safe test_filename = - try tsl_block_of_file test_filename with +let tsl_parse_file_safe test_filename = + try tsl_parse_file test_filename with | Sys_error message -> Printf.eprintf "%s\n%!" message; announce_test_error test_filename message; exit 1 - | Parsing.Parse_error -> - Printf.eprintf "Could not read test block in %s\n%!" test_filename; - announce_test_error test_filename "could not read test block"; + | Syntax_error p -> + let open Lexing in + Printf.eprintf "%s:%d.%d: syntax error in test script\n%!" + test_filename p.pos_lnum (p.pos_cnum - p.pos_bol); + announce_test_error test_filename "could not read test script"; exit 1 let print_usage () = @@ -115,8 +121,8 @@ let init_tests_to_skip () = let test_file test_filename = let start = if Options.show_timings then Unix.gettimeofday () else 0.0 in let skip_test = List.mem test_filename !tests_to_skip in - let tsl_block = tsl_block_of_file_safe test_filename in - let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in + let tsl_ast = tsl_parse_file_safe test_filename in + let (rootenv_statements, test_trees) = test_trees_of_tsl_ast tsl_ast in let test_trees = match test_trees with | [] -> let default_tests = Tests.default_tests() in @@ -263,6 +269,12 @@ let () = let doit f x = work_done := true; f x in List.iter (doit find_test_dirs) Options.find_test_dirs; List.iter (doit list_tests) Options.list_tests; - List.iter (doit test_file) Options.files_to_test; + let do_file = + if Options.translate then + Translate.file ~style:Options.style ~compact:Options.compact + else + test_file + in + List.iter (doit do_file) Options.files_to_test; if not !work_done then print_usage(); if !failed || not !work_done then exit 1 diff --git a/ocamltest/ocamltest.org b/ocamltest/ocamltest.org index bcee038b1d..f547a0f2c8 100644 --- a/ocamltest/ocamltest.org +++ b/ocamltest/ocamltest.org @@ -28,7 +28,7 @@ should be written. It may indeed seem odd to write a test-driver for a compiler in the language it compiles, since the compiler itself is yet untested and thus not trustworthy. -It can however be observed that the OCaml compiler is /bootstraped/, +It can however be observed that the OCaml compiler is /bootstrapped/, meaning that it is itself written in OCaml. A newer version of the compiler can thus be produced from an existing one and the (OCaml) source code of that newer version. Practically, this means that the @@ -50,7 +50,7 @@ For example, the reason why ocamltest has no support for running unit tests is that there were no such tests in the OCaml compiler's test suite. Indeed, the OCaml compiler's test suite is composed mainly of complete -programs. In this context, the most current meaning of "testing" a program +programs. In this context, the most usual meaning of "testing" a program is that the program needs to be compiled and executed. The test will be considered successful if the program compiles as expected and, when run, returns the expected value. @@ -61,7 +61,7 @@ importance to make writing tests of this form as simple as possible. However, not all tests fall into the previously described category, so it is also necessary to support not only variations on the previous scenario (compile but do not run, compile with certain options, etc.) but also -completely different tests, such as top-level tests, debugger tests, +completely different tests, such as REPL tests, debugger tests, etc. To fulfill these requirements and make it as easy as possible to turn a @@ -75,7 +75,7 @@ should be performed. The next chapter explains through examples how to write simple tests. We then introduce the key concepts used by ocamltest to provide a better understanding of how it works and can be used to write more complex -tests. The two last chapters give an in-depth description of the +tests. The last two chapters give an in-depth description of the built-in tests and actions and of the tests and actions that are specific to the OCaml compiler. @@ -96,7 +96,7 @@ with a few other useful tests. Writing tests requires that the sources of the OCaml compiler for which one wants to write them are downloaded and compiled. The compiler -does not need to be installed, though. +does not need to be installed. The sources can be downloaded either as an archive, or directly cloned through git, which seems more appropriate in the context of writing ones @@ -289,7 +289,7 @@ quite similar): output, we compare it to the one produced in action 2. Such a check may seem strange, because what it requires is that =ocamlc.byte= and =ocamlc.opt= produce exactly the same binary and not two binaries - than perform similarly when they are run, but it has proven useful in + that perform similarly when they are run, but it has proven useful in the past and has permitted to detect a subtle bug in the compiler. ** Customizing the default tests @@ -327,13 +327,13 @@ required steps to achieve this: 1. We slightly modify the test block in =hello.ml=, as follows: #+begin_src (* TEST - flags = "-w +33" + flags = "-w +33"; *) #+end_src 2. Since we now expect a non-empty output for the compilers, we need to - store the expected output in a file, namely =hello.compilers.output= - besides to =hello.ml= and =hello.reference=. To figure out what + store the expected output in a file, namely =hello.compilers.reference= + beside =hello.ml= and =hello.reference=. To figure out what this file shall contain, we can run ocamltest even before it has been created. Of course, the action that checks compiler output will fail, but in this way we will get the compiler's output @@ -365,7 +365,7 @@ named appropriately. It will indeed first lookup the test source directory for a compiler-specific reference file, e.g. =hello.ocamlc.byte.reference=. If no such file exists, a back-end-specific reference file is searched, e.g. -=hello.ocamlc.reference= for a compiler common to both =ocamlc.byte= and +=hello.ocamlc.reference= for a reference common to both =ocamlc.byte= and =ocamlc.opt=. If this file does not exist either, ocamltest falls back to looking for =hello.compilers.reference= as we have seen in this example, the absence of which meaning that the compiler's output is @@ -390,7 +390,7 @@ Our =hello.ml= test program can then be rewritten as follows: #+begin_src (* TEST -modules = "greet.ml" + modules = "greet.ml"; *) let _ = Greet.greet "world" @@ -398,7 +398,7 @@ let _ = Greet.greet "world" Provided that the =hello.compilers.reference= file previously used to test warnings is deleted, running ocamltest on =hello.ml= should work. It -will also be worth looking at the two first lines of the log file generated +will also be worth looking at the first two lines of the log file generated while running the test. It says: #+begin_src @@ -453,8 +453,8 @@ it becomes a test: #+begin_src (* TEST -directories += " ${ocamlsrcdir}/otherlibs/str " -libraries += " str " + directories += " ${ocamlsrcdir}/otherlibs/str "; + libraries += " str "; *) #+end_src @@ -500,7 +500,7 @@ test block is actually written as follows: #+begin_src (* TEST -include str + include str; *) #+end_src @@ -519,80 +519,90 @@ that it is run only on Unix platforms: #+begin_src (* TEST -:* unix -:** bytecode -:** native + unix; + { + bytecode; + } + { + native; + } *) #+end_src -As can be understood from this example, lines starting with an asterisk -describe which tests should be executed. In addition, the number of -asterisks allows to specify the nesting level of each test or action. +As can be understood from this example, tests are organised in a tree +nested blocks. Each block begins with a brace and a list of tests and +environment statements that are executed in sequence. Then the block +contains a set of sub-blocks that are executed independently of each +other (i.e. their environments are independent and they are run +regardless of the success or failure of their siblings). Here for instance, =bytecode= and =native= are sub-tests that will be run only if the =unix= test passes and will not be started if it fails or skips. -This way of describing the dependencies between tests has been inspired -by the syntax of org-mode. Each line starting with asterisks (thus lines -specifying which tests to run) can also be seen as a title. The whole -set of lines is like the outline of the test scenario. - With this information in mind, it can be seen that the smallest test block : (* TEST *) is actually equivalent to #+begin_src (* TEST -:* bytecode -:* native + { + bytecode; + } + { + native; + } *) #+end_src One common error when designing tests is to believe that a block like #+begin_src (* TEST -:* unix + unix; *) #+end_src means to execute the =unix= test that verifies that the OS is indeed Unix and then to execute the default tests. This is actually not the case. The only situation in which the default tests are considered is -when the test block contains absolutely no line starting with an -asterisk. As soon as there is a line starting with an asterisk, the +when the test block contains absolutely no test statement. +As soon as there is a test statement, the default tests are ignored completely and one needs to be totally explicit about which tests to run. So the correct way to write the erroneous block above is the use shown at the beginning of this section, namely: #+begin_src (* TEST -:* unix -:** bytecode -:** native + unix; + { + bytecode; + } + { + native; + } *) #+end_src -The fact that the language is inspired by org-mode should also be -helpful in understanding the scope of variable assignments. Roughly -speaking: - -1. Variables defined at the root level are visible by all the tests and - sub-tests that follow their assignment. - -2. If a variable is defined just below a test line, then it is visible - by that test and all its sub-tests (unless its definition is - overridden) but not by tests at a nesting level whose depth is less or - equal than the one of the test in which the variable is defined. +The braces make explicit the scope of variable assignments: an +assignement modifies a variable for the rest of its block and for all +sub-blocks (unless overridden at some point). -For instance, given the following block: +For instance, given the following blocks: #+begin_src (* TEST -foo = "abc" -:* test1 -bar = "def" -:** subtest1 -baz = "hij" -:** subtest2 -:* test2 + foo = "abc"; + { + bar = "def"; + test1; + { + baz = "hij"; + subtest1; + } + { + subtest2; + } + } + { + test2; + } *) #+end_src - The definition of =foo= is visible in all the tests @@ -618,13 +628,13 @@ but they are different in the way one specifies the expected output and also in what they can test. The =toplevel= test behaves in a spirit similar to the compiler tests described above, meaning that the expected output has to be stored in its own, separate file. Since this test -invokes the real OCaml top-level, it is useful to test advanced features -like the behavior of the top-level when its input is a file rather than +invokes the real OCaml toplevel, it is useful to test advanced features +like the behavior of the toplevel when its input is a file rather than a terminal, or similar things. In the expect test, on the contrary, the input and the output it is expected to produce can be written in the same file, close to each other. However, this test uses the OCaml -top-level as a library, rather than calling it as an external program. -So this test is actually not testing the complete real OCaml top-level, +toplevel as a library, rather than calling it as an external program. +So this test is actually not testing the complete real OCaml toplevel, but for testing language features it remains perfectly valid and is actually what is needed in most of the cases. We thus give below an example of an expect test and will describe the =toplevel= test in @@ -634,7 +644,7 @@ So, here is a toy example of an =expect= test: #+begin_src (* TEST -:* expect + expect; *) type point = { x : int; y : int };; @@ -668,8 +678,8 @@ follows: #+begin_src (* TEST -script = "${test_source_directory}/faketest.sh" -:* script + script = "${test_source_directory}/faketest.sh"; + script; *) let _ = print_endline "Hello, world!" @@ -721,14 +731,14 @@ The list of builtin variables can be obtained by running =ocamltest Environment variables for a test can be set using: #+begin_src -set VARIABLE_NAME="value" +set VARIABLE_NAME="value"; #+end_src in the test header (the quotes are mandatory). On the contrary, you can ensure that an environment variable is not set when the test runs with: #+begin_src -unset VARIABLE_NAME +unset VARIABLE_NAME; #+end_src * Built-in actions and tests @@ -747,7 +757,6 @@ running =ocamltest -show-actions=. # Things to document (requested by Leo on caml-devel) # - the syntax of the DSL -# - the precise meaning of the stars # - a clear definition of what "test" means in the context of the DSL # - a list of the builtin "actions" # - a list of which "actions" depend on which "variables" diff --git a/ocamltest/options.ml b/ocamltest/options.ml index 342d2ff954..d85f5b1e7b 100644 --- a/ocamltest/options.ml +++ b/ocamltest/options.ml @@ -61,6 +61,11 @@ let list_tests = ref [] let show_timings = ref false +let translate = ref false +let style = ref Translate.Plain +let compact = ref false + + let add_to_list r x = r := !r @ [x] @@ -85,6 +90,14 @@ let commandline_options = " List tests in given directory."); ("-keep-test-dir-on-success", Arg.Set keep_test_dir_on_success, " Keep the test directory (with the generated test artefacts) on success."); + ("-translate", Arg.Set translate, + " Translate the test script from old to new syntax"); + ("-compact", Arg.Set compact, + " If translating, output the new script in compact mode."); + ("-keep-lines", Arg.Unit (fun () -> style := Translate.Lines), + " If translating, preserve line numbers in the output."); + ("-keep-chars", Arg.Unit (fun () -> style := Translate.Chars), + " If translating, preserve char offsets in the output."); ] let files_to_test = ref [] @@ -102,3 +115,6 @@ let find_test_dirs = !find_test_dirs let list_tests = !list_tests let keep_test_dir_on_success = !keep_test_dir_on_success let show_timings = !show_timings +let translate = !translate +let style = !style +let compact = !compact diff --git a/ocamltest/options.mli b/ocamltest/options.mli index 7b7c5943a4..4d98eec7cf 100644 --- a/ocamltest/options.mli +++ b/ocamltest/options.mli @@ -32,3 +32,7 @@ val list_tests : string list val keep_test_dir_on_success : bool val show_timings : bool + +val translate : bool +val style : Translate.style +val compact : bool diff --git a/ocamltest/tests.ml b/ocamltest/tests.ml index b6cf378c1d..f2c32c937f 100644 --- a/ocamltest/tests.ml +++ b/ocamltest/tests.ml @@ -22,6 +22,13 @@ type t = { test_description : string } +let null = { + test_name = "*pass*"; + test_run_by_default = false; + test_actions = []; + test_description = "dummy test inserted by parser; always pass" +} + let compare t1 t2 = String.compare t1.test_name t2.test_name let (tests: (string, t) Hashtbl.t) = Hashtbl.create 20 diff --git a/ocamltest/tests.mli b/ocamltest/tests.mli index 71ef2ac06e..bdb65c801b 100644 --- a/ocamltest/tests.mli +++ b/ocamltest/tests.mli @@ -22,6 +22,8 @@ type t = { test_description : string } +val null : t + val compare : t -> t -> int val register : t -> unit diff --git a/ocamltest/translate.ml b/ocamltest/translate.ml new file mode 100644 index 0000000000..2554d64a4d --- /dev/null +++ b/ocamltest/translate.ml @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translate a test file from old to new syntax. *) + +open Stdlib +open Printf + +let copy ic oc up_to = + try + while pos_in ic < up_to do + output_char oc (input_char ic) + done + with End_of_file -> () + +let text = + "Filler_text_added_to_preserve_locations_while_translating_from_old_syntax__" +let len = String.length text +let index = ref (-1) +let lorem () = incr index; text.[!index mod len] + +type mode = +| Keep_chars of int (* how many chars to skip before keeping chars *) +| Keep_lines + +let copy_newlines ~mode ic oc up_to = + let skip, insert = + match mode with + | Keep_lines -> + ref max_int, ref "(* Blank lines added here to preserve locations. *)" + | Keep_chars n -> ref n, ref "" + in + try + while pos_in ic < up_to do + let c = input_char ic in + if c = '\n' || c = '\r' then begin + output_char oc c; + output_string oc !insert; + insert := ""; + end else if !skip <= 0 then + output_char oc (lorem ()) + else + decr skip + done + with End_of_file -> () + +let tsl_block_of_file test_filename = + let input_channel = open_in test_filename in + let lexbuf = Lexing.from_channel input_channel in + Location.init lexbuf test_filename; + try + let block = Tsl_parser.tsl_block Tsl_lexer.token lexbuf in + close_in input_channel; + if !Tsl_lexer.has_comments then + eprintf "%s:1.0: warning: test script has comments\n" test_filename; + block + with + | Parsing.Parse_error -> + let open Lexing in + let p = lexbuf.lex_start_p in + Printf.eprintf "%s:%d.%d: syntax error in test script\n%!" + test_filename p.pos_lnum (p.pos_cnum - p.pos_bol); + raise Parsing.Parse_error + +(* In what style to output the translated test file *) +type style = +| Plain +| Lines +| Chars + +(* What kind of comments are used in the test file *) +type kind = { opening : string; closing : string } +let c_kind = { opening = "/*"; closing = "*/" } +let ocaml_kind = { opening = "(*"; closing = "*)" } + +let file ~style ~compact f = + let tsl_block = tsl_block_of_file f in + let (rootenv_statements, test_trees) = + Tsl_semantics.test_trees_of_tsl_block tsl_block + in + let ast = + Tsl_semantics.tsl_ast_of_test_trees (rootenv_statements, test_trees) + in + let lex_ic = open_in f in + let copy_ic = open_in f in + let lexbuf = Lexing.from_channel lex_ic in + Location.init lexbuf f; + let rec seek_to_begin () = + match Tsl_lexer.token lexbuf with + | Tsl_parser.TSL_BEGIN_C_STYLE position -> (c_kind, position) + | Tsl_parser.TSL_BEGIN_OCAML_STYLE position -> (ocaml_kind, position) + | _ -> seek_to_begin () + in + let rec seek_to_end () = + match Tsl_lexer.token lexbuf with + | Tsl_parser.TSL_END_C_STYLE -> () + | Tsl_parser.TSL_END_OCAML_STYLE -> () + | _ -> seek_to_end () + in + let (kind, position) = seek_to_begin () in + copy copy_ic stdout Lexing.(lexbuf.lex_curr_p.pos_cnum); + if position = `Below || style = Plain then begin + print_string (if ast = Tsl_ast.Ast ([], []) then " " else "\n"); + Tsl_semantics.print_tsl_ast ~compact stdout ast; + seek_to_end (); + seek_in copy_ic Lexing.(lexbuf.lex_start_p.pos_cnum); + copy copy_ic stdout max_int; + end else begin + printf "_BELOW"; + seek_to_end (); + let limit = Lexing.(lexbuf.lex_start_p.pos_cnum) in + let mode = + match style with + | Lines -> Keep_lines + | Chars -> Keep_chars 6 + | Plain -> assert false + in + copy_newlines ~mode copy_ic stdout limit; + copy copy_ic stdout max_int; + printf "\n%s TEST\n" kind.opening; + Tsl_semantics.print_tsl_ast ~compact stdout ast; + printf "%s\n" kind.closing; + end; + flush stdout; + close_in lex_ic; + close_in copy_ic; diff --git a/ocamltest/translate.mli b/ocamltest/translate.mli new file mode 100644 index 0000000000..24b02e320e --- /dev/null +++ b/ocamltest/translate.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Translate a test file from old to new syntax. *) + +type style = +| Plain +| Lines +| Chars + +val file : style:style -> compact:bool -> string -> unit diff --git a/ocamltest/tsl_ast.ml b/ocamltest/tsl_ast.ml index 0564019c12..a308282865 100644 --- a/ocamltest/tsl_ast.ml +++ b/ocamltest/tsl_ast.ml @@ -35,6 +35,8 @@ type tsl_item = type tsl_block = tsl_item list +type t = Ast of tsl_item list * t list + let make ?(loc = Location.none) foo = { node = foo; loc = loc } let make_identifier = make diff --git a/ocamltest/tsl_ast.mli b/ocamltest/tsl_ast.mli index f835504408..9b77255309 100644 --- a/ocamltest/tsl_ast.mli +++ b/ocamltest/tsl_ast.mli @@ -26,6 +26,7 @@ type environment_statement = | Include of string located (* include named environment *) | Unset of string located (* clear environment variable *) +(* old syntax *) type tsl_item = | Environment_statement of environment_statement located | Test of @@ -35,6 +36,9 @@ type tsl_item = type tsl_block = tsl_item list +(* New syntax *) +type t = Ast of tsl_item list * t list + val make_identifier : ?loc:Location.t -> string -> string located val make_string : ?loc:Location.t -> string -> string located val make_environment_statement : diff --git a/ocamltest/tsl_lexer.mli b/ocamltest/tsl_lexer.mli index 82a355f327..ec1688a403 100644 --- a/ocamltest/tsl_lexer.mli +++ b/ocamltest/tsl_lexer.mli @@ -19,3 +19,5 @@ val token : Lexing.lexbuf -> Tsl_parser.token val is_test : Lexing.lexbuf -> bool val modifier : Lexing.lexbuf -> string * [`Remove | `Add of string | `Append of string] + +val has_comments : bool ref diff --git a/ocamltest/tsl_lexer.mll b/ocamltest/tsl_lexer.mll index 2c40753747..b643509eca 100644 --- a/ocamltest/tsl_lexer.mll +++ b/ocamltest/tsl_lexer.mll @@ -20,6 +20,7 @@ open Tsl_parser let comment_start_pos = ref [] +let has_comments = ref false let lexer_error message = failwith (Printf.sprintf "Tsl lexer: %s" message) @@ -43,11 +44,19 @@ rule is_test = parse and token = parse | blank * { token lexbuf } | newline { Lexing.new_line lexbuf; token lexbuf } - | "/*" blank* "TEST" { TSL_BEGIN_C_STYLE } - | "/*" blank* "TEST_BELOW" _ * "/*" blank* "TEST" { TSL_BEGIN_C_STYLE } + | "/*" blank* "TEST" { TSL_BEGIN_C_STYLE `Above } + | "/*" blank* "TEST_BELOW" _ * "/*" blank* "TEST" { + let s = Lexing.lexeme lexbuf in + String.iter (fun c -> if c = '\n' then Lexing.new_line lexbuf) s; + TSL_BEGIN_C_STYLE `Below + } | "*/" { TSL_END_C_STYLE } - | "(*" blank* "TEST" { TSL_BEGIN_OCAML_STYLE } - | "(*" blank* "TEST_BELOW" _ * "(*" blank* "TEST" { TSL_BEGIN_OCAML_STYLE } + | "(*" blank* "TEST" { TSL_BEGIN_OCAML_STYLE `Above } + | "(*" blank* "TEST_BELOW" _ * "(*" blank* "TEST" { + let s = Lexing.lexeme lexbuf in + String.iter (fun c -> if c = '\n' then Lexing.new_line lexbuf) s; + TSL_BEGIN_OCAML_STYLE `Below + } | "*)" { TSL_END_OCAML_STYLE } | "," { COMMA } | '*'+ { TEST_DEPTH (String.length (Lexing.lexeme lexbuf)) } @@ -63,9 +72,13 @@ and token = parse | "with" -> WITH | _ -> IDENTIFIER s } + | "{" { LEFT_BRACE } + | "}" { RIGHT_BRACE } + | ";" { SEMI } | "(*" { comment_start_pos := [Lexing.lexeme_start_p lexbuf]; + has_comments := true; comment lexbuf } | '"' diff --git a/ocamltest/tsl_parser.mly b/ocamltest/tsl_parser.mly index e6a875a886..c8d52ab72b 100644 --- a/ocamltest/tsl_parser.mly +++ b/ocamltest/tsl_parser.mly @@ -31,9 +31,11 @@ let mkenvstmt envstmt = %} -%token TSL_BEGIN_C_STYLE TSL_END_C_STYLE -%token TSL_BEGIN_OCAML_STYLE TSL_END_OCAML_STYLE -%token COMMA +%token <[`Above | `Below]> TSL_BEGIN_C_STYLE +%token TSL_END_C_STYLE +%token <[`Above | `Below]> TSL_BEGIN_OCAML_STYLE +%token TSL_END_OCAML_STYLE +%token COMMA LEFT_BRACE RIGHT_BRACE SEMI %token <int> TEST_DEPTH %token EQUAL PLUSEQUAL /* %token COLON */ @@ -41,11 +43,34 @@ let mkenvstmt envstmt = %token <string> IDENTIFIER %token <string> STRING -%start tsl_block +%start tsl_block tsl_script %type <Tsl_ast.tsl_block> tsl_block +%type <Tsl_ast.t> tsl_script %% +node: +| statement_list tree_list { Ast ($1, $2) } + +tree_list: +| { [] } +| tree tree_list { $1 :: $2 } + +tree: +| LEFT_BRACE node RIGHT_BRACE { $2 } + +statement_list: +| { [] } +| statement statement_list { $1 :: $2 } + +statement: +| env_item SEMI { $1 } +| identifier with_environment_modifiers SEMI { Test (0, $1, $2) } + +tsl_script: +| TSL_BEGIN_C_STYLE node TSL_END_C_STYLE { $2 } +| TSL_BEGIN_OCAML_STYLE node TSL_END_OCAML_STYLE { $2 } + tsl_block: | TSL_BEGIN_C_STYLE tsl_items TSL_END_C_STYLE { $2 } | TSL_BEGIN_OCAML_STYLE tsl_items TSL_END_OCAML_STYLE { $2 } diff --git a/ocamltest/tsl_semantics.ml b/ocamltest/tsl_semantics.ml index 09fb8f9917..ee71bf4726 100644 --- a/ocamltest/tsl_semantics.ml +++ b/ocamltest/tsl_semantics.ml @@ -107,6 +107,17 @@ let no_such_test_or_action t = Printf.eprintf "%s\nNo such test or action: %s\n%!" locstr t.node; exit 2 +let lookup_test located_name = + let name = located_name.node in + match Tests.lookup name with + | None -> + begin match Actions.lookup name with + | None -> no_such_test_or_action located_name + | Some action -> + Tests.test_of_action action + end + | Some test -> test + let test_trees_of_tsl_block tsl_block = let rec env_of_lines = function | [] -> ([], []) @@ -127,16 +138,8 @@ let test_trees_of_tsl_block tsl_block = else let (env, rem) = env_of_lines remaining_lines in let (trees, rem) = trees_of_lines (depth+1) rem in - match Tests.lookup name with - | None -> - begin match Actions.lookup name with - | None -> no_such_test_or_action located_name - | Some action -> - let test = Tests.test_of_action action in - (Some (Node (env, test, env_modifiers, trees)), rem) - end - | Some test -> - (Some (Node (env, test, env_modifiers, trees)), rem) + let test = lookup_test located_name in + (Some (Node (env, test, env_modifiers, trees)), rem) end end and trees_of_lines depth lines = @@ -175,3 +178,93 @@ let actions_in_tests tests = let f test action_set = Actions.ActionSet.union (actions_in_test test) action_set in Tests.TestSet.fold f tests Actions.ActionSet.empty + +let rec split_env l = + match l with + | Environment_statement env :: tl -> + let (env2, rest) = split_env tl in (env :: env2, rest) + | _ -> ([], l) + +let rec test_trees_of_tsl_ast (Ast (seq, subs)) = + let (env, rest) = split_env seq in + let trees = + match rest with + | [] -> List.map test_tree_of_tsl_ast subs + | [ Test (_, name, mods) ] -> + [Node ([], lookup_test name, mods, List.map test_tree_of_tsl_ast subs)] + | Test (_, name, mods) :: seq1 -> + let sub = test_tree_of_tsl_ast (Ast (seq1, subs)) in + [Node ([], lookup_test name, mods, [sub])] + | Environment_statement _ :: _ -> assert false + in (env, trees) + +and test_tree_of_tsl_ast ast = + match test_trees_of_tsl_ast ast with + | (env, [Node (env1, t, m, s)]) -> Node (env @ env1, t, m, s) + | (env, trees) -> Node (env, Tests.null, [], trees) + +let rec ast_of_tree (Node (env, test, mods, subs)) = + let tst = [Test (0, Tsl_ast.make_identifier test.Tests.test_name, mods)] in + ast_of_tree_aux env tst subs + +and ast_of_tree_aux env tst subs = + let env = List.map (fun x -> Environment_statement x) env in + match List.map ast_of_tree subs with + | [ Ast (stmts, subs) ] -> Ast (env @ tst @ stmts, subs) + | asts -> Ast (env @ tst, asts) + +let tsl_ast_of_test_trees (env, trees) = ast_of_tree_aux env [] trees + +open Printf + +let print_tsl_ast ~compact oc ast = + let pr fmt (*args*) = fprintf oc fmt (*args*) in + + let rec print_ast indent (Ast (stmts, subs)) = + print_statements indent stmts; + print_forest indent subs; + + and print_sub indent ast = + pr "{\n"; + print_ast (indent ^ " ") ast; + pr "%s}" indent; + + and print_statements indent stmts = + match stmts with + | Test (_, name, mods) :: tl -> + pr "%s%s" indent name.node; + begin match mods with + | m :: tl -> + pr " with %s" m.node; + List.iter (fun m -> pr ", %s" m.node) tl; + | [] -> () + end; + pr ";\n"; + if tl <> [] && not compact then pr "\n"; + print_statements indent tl; + | Environment_statement env :: tl-> + print_env indent env; + print_statements indent tl; + | [] -> () + + and print_forest indent subs = + if subs <> [] then begin + pr "%s" indent; + List.iter (print_sub indent) subs; + pr "\n"; + end + + and print_env indent e = + match e.node with + | Assignment (set, variable, value) -> + pr "%s" indent; + if set then pr "set "; + pr "%s = \"%s\";\n" variable.node value.node; + | Append (variable, value) -> + pr "%s%s += \"%s\";\n" indent variable.node value.node; + | Include ls -> + pr "%sinclude %s;\n" indent ls.node; + | Unset ls -> + pr "%sunset %s;\n" indent ls.node; + in + print_ast " " ast; diff --git a/ocamltest/tsl_semantics.mli b/ocamltest/tsl_semantics.mli index cbb017e681..385692f0a7 100644 --- a/ocamltest/tsl_semantics.mli +++ b/ocamltest/tsl_semantics.mli @@ -35,9 +35,17 @@ type test_tree = (test_tree list) val test_trees_of_tsl_block : - Tsl_ast.tsl_block -> + Tsl_ast.tsl_item list -> Tsl_ast.environment_statement located list * test_tree list +val test_trees_of_tsl_ast : + Tsl_ast.t -> + Tsl_ast.environment_statement located list * test_tree list + +val tsl_ast_of_test_trees : + Tsl_ast.environment_statement located list * test_tree list -> + Tsl_ast.t + val tests_in_tree : test_tree -> Tests.TestSet.t val tests_in_trees : test_tree list -> Tests.TestSet.t @@ -45,3 +53,6 @@ val tests_in_trees : test_tree list -> Tests.TestSet.t val actions_in_test : Tests.t -> Actions.ActionSet.t val actions_in_tests : Tests.TestSet.t -> Actions.ActionSet.t + + +val print_tsl_ast : compact:bool -> out_channel -> Tsl_ast.t -> unit |