diff options
448 files changed, 8120 insertions, 6918 deletions
@@ -1,6 +1,9 @@ utils/arg_helper.cmo : utils/arg_helper.cmi utils/arg_helper.cmx : utils/arg_helper.cmi utils/arg_helper.cmi : +utils/build_path_prefix_map.cmo : utils/build_path_prefix_map.cmi +utils/build_path_prefix_map.cmx : utils/build_path_prefix_map.cmi +utils/build_path_prefix_map.cmi : utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \ @@ -108,9 +111,9 @@ parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \ - utils/clflags.cmi parsing/location.cmi + utils/clflags.cmi utils/build_path_prefix_map.cmi parsing/location.cmi parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \ - utils/clflags.cmx parsing/location.cmi + utils/clflags.cmx utils/build_path_prefix_map.cmx parsing/location.cmi parsing/location.cmi : utils/warnings.cmi parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi @@ -210,8 +213,8 @@ typing/envaux.cmo : typing/subst.cmi typing/printtyp.cmi typing/path.cmi \ typing/envaux.cmx : typing/subst.cmx typing/printtyp.cmx typing/path.cmx \ typing/ident.cmx typing/env.cmx typing/envaux.cmi typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi -typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi -typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi +typing/ident.cmo : utils/identifiable.cmi utils/clflags.cmi typing/ident.cmi +typing/ident.cmx : utils/identifiable.cmx utils/clflags.cmx typing/ident.cmi typing/ident.cmi : utils/identifiable.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ typing/path.cmi typing/ctype.cmi parsing/builtin_attributes.cmi \ @@ -558,12 +561,14 @@ bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/emitcode.cmi bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/emitcode.cmi bytecomp/emitcode.cmi : utils/misc.cmi bytecomp/instruct.cmi \ typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ diff --git a/.gitignore b/.gitignore index a70bfd7fd3..ae04b6be48 100644 --- a/.gitignore +++ b/.gitignore @@ -356,11 +356,6 @@ _ocamltest /testsuite/tests/typing-unboxed-types/true.flat-float /testsuite/tests/typing-unboxed-types/test.ml.reference -/testsuite/tests/translprim/false.flat-float -/testsuite/tests/translprim/true.flat-float -/testsuite/tests/translprim/array_spec.ml.reference -/testsuite/tests/translprim/module_coercion.ml.reference - /testsuite/tests/unboxed-primitive-args/main.ml /testsuite/tests/unboxed-primitive-args/stubs.c @@ -40,8 +40,8 @@ B ./otherlibs/unix S ./parsing B ./parsing -S ./stdlib -B ./stdlib +STDLIB ./stdlib +FLG -open Stdlib -nopervasives S ./toplevel B ./toplevel diff --git a/.travis-ci.sh b/.travis-ci.sh index 2ee05cef6d..8b970b1bb1 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -73,7 +73,7 @@ EOF $MAKE world.opt $MAKE ocamlnat (cd testsuite && $MAKE all) - [ $XARCH = "i386" ] || (cd testsuite && $MAKE USE_RUNTIME="d" all) + (cd testsuite && $MAKE USE_RUNTIME="d" all) $MAKE install $MAKE manual-pregen # check_all_arches checks tries to compile all backends in place, @@ -5,11 +5,17 @@ Working version ### Language features: +- MPR#6023, GPR#1648: Allow type-based selection of GADT constructors + (Thomas Refis and Leo White, review by Jacques Garrigue and Gabriel Scherer) + - GPR#1467: Allow expressions sequences inside extended indexing and bigarray indexing operators, e.g.: e1.![e2; e3; ...], etc. (Nicolás Ojeda Bär, review by Gabriel Radanne, Damien Doligez, Gabriel Scherer) +- GPR#1546: Allow empty variants + (Runhang Li, review by Gabriel Radanne and Jacques Garrigue) + ### Type system: - MPR#7717, GPR#1593: don't treat unboxed constructor size as statically known @@ -36,14 +42,28 @@ Working version For instance users can now use a largeFile.ml file in their project. (Jérémie Dimino, review by Nicolas Ojeda Bar, Alain Frisch and Gabriel Radanne) +- GPR#1609: Changes to ambivalence scope tracking + (Thomas Refis and Leo White, review by Jacques Garrigue) + +- GPR#1628: Treat reraise and raise_notrace as nonexpansive. + (Leo White, review by Alain Frisch) + ### Standard library: - MPR#7690, GPR#1528: fix the float_of_string function for hexadecimal floats with very large values of the exponent. (Olivier Andrieu) +- GPR#1637: String.escaped is faster does and not allocate when called with a + string that does not contain any characters needing to be escaped. + (Alain Frisch, review by Xavier Leroy and Gabriel Scherer) + ### Other libraries: +- MPR#7745, GPR#1629: Graphics.open_graph displays the correct window title on + Windows again (fault introduced by 4.06 Unicode changes). + (David Allsopp) + * GPR#1406: Unix.isatty now returns true in the native Windows ports when passed a file descriptor connected to a Cygwin PTY. In particular, compiler colors for the native Windows ports now work under Cygwin/MSYS2. @@ -91,6 +111,10 @@ Working version (Armaël Guéneau and Gabriel Scherer, original design by Arthur Charguéraud, review by Frédéric Bour, Gabriel Radanne and Alain Frisch) +- GPR#1515: honor the BUILD_PATH_PREFIX_MAP environment variable + to enable reproducible builds + (Gabriel Scherer, with help from Ximin Luo, review by Damien Doligez) + - GPR#1534: Extend the warning printed when (*) is used, adding a hint to suggest using ( * ) instead (Armaël Guéneau, with help and review from Florian Angeletti and Gabriel @@ -104,6 +128,13 @@ Working version - GPR#1554: warnings 52 and 57: fix reference to manual detailed explanation (Florian Angeletti, review by Thomas Refis and Gabriel Scherer) +- GPR#1618: add the -dno-unique-ids and -dunique-ids compiler flags + (Sébastien Hinderer, review by Leo White and Damien Doligez) + +- GPR#1649 change compilation order of toplevel definitions, so that some warnings + emitted by the bytecode compiler appear more in-order than before. + (Luc Maranget, advice and review by Damien Doligez) + ### Code generation and optimizations: - GPR#1370: Fix code duplication in Cmmgen @@ -121,6 +152,9 @@ Working version simpler IT blocks instead (Xavier Leroy, review by Mark Shinwell) +- GPR#1487: Treat negated float comparisons more directly + (Leo White, review by Xavier Leroy) + ### Runtime system: - MPR#6411, GPR#1535: don't compile everything with -static-libgcc on mingw32, @@ -135,6 +169,10 @@ Working version able to collect profiling information from C stubs). (Nicolás Ojeda Bär, review by Xavier Leroy, Mark Shinwell) +- GPR#1483: fix GC freelist accounting for chunks larger than the maximum block + size. + (David Allsopp and Damien Doligez) + - GPR#1526: install the debug and instrumented runtimes (lib{caml,asm}run{d,i}.a) (Gabriel Scherer, reminded by Julia Lawall) @@ -142,6 +180,10 @@ Working version - GPR#1563: simplify implementation of LSRINT and ASRINT (Max Mouratov, review by Frédéric Bour) +- GPR#1644: remove caml_alloc_float_array from the bytecode primitives list + (it's a native code primitive) + (David Allsopp) + ### Tools: - MPR#7643, GPR#1377: ocamldep, fix an exponential blowup in presence of nested @@ -197,11 +239,31 @@ Working version - GPR#1520: more robust implementation of Misc.no_overflow_mul (Max Mouratov, review by Xavier Leroy) +- GPR#1567: register all idents relevant for reraise + (Thomas Refis, review by Alain Frisch and Frédéric Bour) + +- GPR#1573: emitcode: merge events after instructions reordering + (Thomas Refis and Leo White, with help from David Allsopp, review by Frédéric + Bour) + - GPR#1586: testsuite: 'make promote' for ocamltest tests (The new "-promote" option for ocamltest is experimental and subject to change/removal). (Gabriel Scherer) +- GPR#1619: expect_test: print all the exceptions, even the unexpected ones + (Thomas Refis, review by Jérémie Dimino) + +- GPR#1621: expect_test: make sure to not use the installed stdlib + (Jérémie Dimino, review by Thomas Refis) + +- MPR#7738, GPR#1624: Asmlink.reset also resets lib_ccobjs/ccopts + (Cedric Cellier, review by Gabriel Scherer) + +- GPR#1646 : add ocamldoc test to ocamltest and + migrate ocamldoc tests to ocamltest + (Florian Angeletti, review by Sébastien Hinderer) + ### Bug fixes - MPR#5250, GPR#1435: on Cygwin, when ocamlrun searches the path @@ -217,6 +279,9 @@ Working version (Tadeu Zagallo, report by Roberto Di Cosmo, review by Hongbo Zhang, David Allsopp, Gabriel Scherer, Xavier Leroy) +- MPR#7391, GPR#1620: Do not put a dummy method in object types + (Thomas Refis, review by Jacques Garrigue) + - PR#7660, GPR#1445: Use native Windows API to implement Unix.utimes in order to avoid unintended shifts of the argument timestamp depending on DST setting. (Nicolás Ojeda Bär, review by David Allsopp, Xavier Leroy) @@ -256,10 +321,17 @@ Working version - MPR#7712, GPR#1576: assertion failure with type abbreviations (Thomas Refis, report by Michael O'Connor, review by Jacques Garrigue) +- MPR#7747: Type checker can loop infinitly and consumes all computer memory + (Jacques Garrigue, report by kantian) + - GPR#1530, GPR#1574: testsuite, fix 'make parallel' and 'make one DIR=...' to work on ocamltest-based tests. (Runhang Li and Sébastien Hinderer, review by Gabriel Scherer) +- GPR#1622: fix bug in the expansion of command-line arguments under Windows + which could result in some elements of Sys.argv being truncated in some cases. + (Nicolás Ojeda Bär, review by Sébastien Hinderer) + 4.06 maintenance branch ----------------------- diff --git a/HACKING.adoc b/HACKING.adoc index 2ab7638067..f6fe7b365f 100644 --- a/HACKING.adoc +++ b/HACKING.adoc @@ -307,6 +307,21 @@ OCaml's GitHub repository and then push "mybranch" to your fork. 7. You should receive a bunch of e-mails with the build logs for each slave and each tested configuration (with and without flambda) attached. +==== Changing what the CI does + +INRIA's CI "main" and "precheck" jobs run the script +tools/ci-build. In particular, when running the CI on a publicly +available branch via the "precheck" job as explained in the previous +section, you can edit this script to change what the CI will test. + +For instance, parallel builds are only tested for the "trunk" +branch. In order to use "precheck" to test parallel build on a custom +branch, add this at the beginning of tools/ci-build: + +---- +OCAML_JOBS=10 +---- + === The `caml-commits` mailing list If you would like to receive email notifications of all commits made to the main @@ -88,7 +88,9 @@ UTILS=utils/config.cmo utils/misc.cmo \ utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo \ utils/strongly_connected_components.cmo \ - utils/targetint.cmo utils/domainstate.cmo + utils/targetint.cmo utils/domainstate.cmo \ + utils/build_path_prefix_map.cmo \ + utils/targetint.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/docstrings.cmo parsing/syntaxerr.cmo \ @@ -281,11 +283,13 @@ INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) INSTALL_MANDIR=$(DESTDIR)$(MANDIR) INSTALL_FLEXDLL=$(INSTALL_LIBDIR)/flexdll +TOPINCLUDES=$(addprefix -I otherlibs/,$(filter-out %threads,$(OTHERLIBRARIES))) RUNTOP=./byterun/ocamlrun ./ocaml \ -nostdlib -I stdlib \ - -noinit $(TOPFLAGS) \ - -I otherlibs/$(UNIXLIB) -NATRUNTOP=./ocamlnat$(EXE) -nostdlib -I stdlib -noinit $(TOPFLAGS) + -noinit $(TOPFLAGS) $(TOPINCLUDES) +NATRUNTOP=./ocamlnat$(EXE) \ + -nostdlib -I stdlib \ + -noinit $(TOPFLAGS) $(TOPINCLUDES) ifeq "$(UNIX_OR_WIN32)" "unix" EXTRAPATH= else @@ -834,7 +838,6 @@ runtop: natruntop: $(MAKE) core $(MAKE) opt - $(MAKE) opt.opt $(MAKE) ocamlnat @rlwrap --help 2>/dev/null && $(EXTRAPATH) rlwrap $(NATRUNTOP) ||\ $(EXTRAPATH) $(NATRUNTOP) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index f26b24f31d..27b36c698c 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -408,7 +408,7 @@ let output_test_zero arg = (* Output a floating-point compare and branch *) -let emit_float_test cmp neg i lbl = +let emit_float_test cmp i lbl = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp @@ -418,33 +418,41 @@ let emit_float_test cmp neg i lbl = If FP traps are on (they are off by default), comisd traps on QNaN and SNaN but ucomisd traps on SNaN only. *) - match (cmp, neg) with - | (Ceq, false) | (Cne, true) -> + match cmp with + | CFeq -> let next = new_label() in I.ucomisd (arg i 1) (arg i 0); I.jp (label next); (* skip if unordered *) I.je lbl; (* branch taken if x=y *) def_label next - | (Cne, false) | (Ceq, true) -> + | CFneq -> I.ucomisd (arg i 1) (arg i 0); I.jp lbl; (* branch taken if unordered *) I.jne lbl (* branch taken if x<y or x>y *) - | (Clt, _) -> + | CFlt -> I.comisd (arg i 0) (arg i 1); - if not neg then I.ja lbl (* branch taken if y>x i.e. x<y *) - else I.jbe lbl (* taken if unordered or y<=x i.e. !(x<y) *) - | (Cle, _) -> + I.ja lbl (* branch taken if y>x i.e. x<y *) + | CFnlt -> + I.comisd (arg i 0) (arg i 1); + I.jbe lbl (* taken if unordered or y<=x i.e. !(x<y) *) + | CFle -> + I.comisd (arg i 0) (arg i 1);(* swap compare *) + I.jae lbl (* branch taken if y>=x i.e. x<=y *) + | CFnle -> I.comisd (arg i 0) (arg i 1);(* swap compare *) - if not neg then I.jae lbl (* branch taken if y>=x i.e. x<=y *) - else I.jb lbl (* taken if unordered or y<x i.e. !(x<=y) *) - | (Cgt, _) -> + I.jb lbl (* taken if unordered or y<x i.e. !(x<=y) *) + | CFgt -> I.comisd (arg i 1) (arg i 0); - if not neg then I.ja lbl (* branch taken if x>y *) - else I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *) - | (Cge, _) -> + I.ja lbl (* branch taken if x>y *) + | CFngt -> + I.comisd (arg i 1) (arg i 0); + I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *) + | CFge -> + I.comisd (arg i 1) (arg i 0);(* swap compare *) + I.jae lbl (* branch taken if x>=y *) + | CFnge -> I.comisd (arg i 1) (arg i 0);(* swap compare *) - if not neg then I.jae lbl (* branch taken if x>=y *) - else I.jb lbl (* taken if unordered or x<y i.e. !(x>=y) *) + I.jb lbl (* taken if unordered or x<y i.e. !(x>=y) *) (* Deallocate the stack frame before a return or tail call *) @@ -847,8 +855,8 @@ let emit_instr fallthrough i = | Iinttest_imm(cmp, n) -> I.cmp (int n) (arg i 0); I.j (cond cmp) lbl - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i lbl + | Ifloattest cmp -> + emit_float_test cmp i lbl | Ioddtest -> I.test (int 1) (arg8 i 0); I.jne lbl diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 690e01651b..a4070b47cd 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -107,13 +107,13 @@ method! reload_test tst arg = if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] else arg - | Ifloattest((Clt|Cle), _) -> + | Ifloattest (CFlt | CFnlt | CFle | CFnle) -> (* Cf. emit.mlp: we swap arguments in this case *) (* First argument can be on stack, second must be in register *) if stackp arg.(1) then [| arg.(0); self#makereg arg.(1) |] else arg - | Ifloattest((Ceq|Cne|Cgt|Cge), _) -> + | Ifloattest (CFeq | CFneq | CFgt | CFngt | CFge | CFnge) -> (* Second argument can be on stack, first must be in register *) if stackp arg.(0) then [| self#makereg arg.(0); arg.(1) |] diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index c90ce237e8..182ccbdfd3 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -165,8 +165,8 @@ let emit_call_bound_error bd = (* Negate a comparison *) let negate_integer_comparison = function - Isigned cmp -> Isigned(negate_comparison cmp) - | Iunsigned cmp -> Iunsigned(negate_comparison cmp) + | Isigned cmp -> Isigned(negate_integer_comparison cmp) + | Iunsigned cmp -> Iunsigned(negate_integer_comparison cmp) (* Names of various instructions *) @@ -726,18 +726,20 @@ let emit_instr i = ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; let comp = name_for_comparison cmp in ` b{emit_string comp} {emit_label lbl}\n`; 2 - | Ifloattest(cmp, neg) -> - let comp = (match (cmp, neg) with - (Ceq, false) | (Cne, true) -> "eq" - | (Cne, false) | (Ceq, true) -> "ne" - | (Clt, false) -> "cc" - | (Clt, true) -> "cs" - | (Cle, false) -> "ls" - | (Cle, true) -> "hi" - | (Cgt, false) -> "gt" - | (Cgt, true) -> "le" - | (Cge, false) -> "ge" - | (Cge, true) -> "lt") in + | Ifloattest cmp -> + let comp = + match cmp with + | CFeq -> "eq" + | CFneq -> "ne" + | CFlt -> "cc" + | CFnlt -> "cs" + | CFle -> "ls" + | CFnle -> "hi" + | CFgt -> "gt" + | CFngt -> "le" + | CFge -> "ge" + | CFnge -> "lt" + in ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` fmstat\n`; ` b{emit_string comp} {emit_label lbl}\n`; 3 diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 3f1f0f37f5..486dc580d8 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -241,16 +241,19 @@ method private select_operation_softfp op args dbg = | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args) | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args) | (Ccmpf comp, args) -> - let func = (match comp with - Cne (* there's no __aeabi_dcmpne *) - | Ceq -> "__aeabi_dcmpeq" - | Clt -> "__aeabi_dcmplt" - | Cle -> "__aeabi_dcmple" - | Cgt -> "__aeabi_dcmpgt" - | Cge -> "__aeabi_dcmpge") in - let comp = (match comp with - Cne -> Ceq (* eq 0 => false *) - | _ -> Cne (* ne 0 => true *)) in + let comp, func = + match comp with + | CFeq -> Cne, "__aeabi_dcmpeq" + | CFneq -> Ceq, "__aeabi_dcmpeq" + | CFlt -> Cne, "__aeabi_dcmplt" + | CFnlt -> Ceq, "__aeabi_dcmplt" + | CFle -> Cne, "__aeabi_dcmple" + | CFnle -> Ceq, "__aeabi_dcmple" + | CFgt -> Cne, "__aeabi_dcmpgt" + | CFngt -> Ceq, "__aeabi_dcmpgt" + | CFge -> Cne, "__aeabi_dcmpge" + | CFnge -> Ceq, "__aeabi_dcmpge" + in (Iintop_imm(Icomp(Iunsigned comp), 0), [Cop(Cextcall(func, typ_int, false, None), args, dbg)]) (* Add coercions around loads and stores of 32-bit floats *) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index e9d434ace4..acefced3b1 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -870,18 +870,20 @@ let emit_instr i = ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; let comp = name_for_comparison cmp in ` b.{emit_string comp} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - let comp = (match (cmp, neg) with - | (Ceq, false) | (Cne, true) -> "eq" - | (Cne, false) | (Ceq, true) -> "ne" - | (Clt, false) -> "cc" - | (Clt, true) -> "cs" - | (Cle, false) -> "ls" - | (Cle, true) -> "hi" - | (Cgt, false) -> "gt" - | (Cgt, true) -> "le" - | (Cge, false) -> "ge" - | (Cge, true) -> "lt") in + | Ifloattest cmp -> + let comp = + match cmp with + | CFeq -> "eq" + | CFneq -> "ne" + | CFlt -> "cc" + | CFnlt -> "cs" + | CFle -> "ls" + | CFnle -> "hi" + | CFgt -> "gt" + | CFngt -> "le" + | CFge -> "ge" + | CFnge -> "lt" + in ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.{emit_string comp} {emit_label lbl}\n` | Ioddtest -> diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index fe93e5e14b..ee35ac69eb 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -119,7 +119,7 @@ let object_file_name name = try find_in_path !load_path name with Not_found -> - fatal_error "Asmlink.object_file_name: not found" in + fatal_errorf "Asmlink.object_file_name: %s not found" name in if Filename.check_suffix file_name ".cmx" then Filename.chop_suffix file_name ".cmx" ^ ext_obj else if Filename.check_suffix file_name ".cmxa" then @@ -422,4 +422,6 @@ let reset () = implementations_defined := []; cmx_required := []; interfaces := []; - implementations := [] + implementations := []; + lib_ccobjs := []; + lib_ccopts := [] diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 1e441ba19b..ac71204a68 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -232,15 +232,31 @@ let make_const_ref c = let make_const_int n = make_const (Uconst_int n) let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp x y = + +let make_integer_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y - | Cneq -> x <> y + | Cne -> x <> y | Clt -> x < y | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) + +let make_float_comparison cmp x y = + make_const_bool + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) + let make_const_float n = make_const_ref (Uconst_float n) let make_const_natint n = make_const_ref (Uconst_nativeint n) let make_const_int32 n = make_const_ref (Uconst_int32 n) @@ -286,7 +302,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = make_const_int (n1 lsr n2) | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> make_const_int (n1 asr n2) - | Pintcomp c -> make_comparison c n1 n2 + | Pintcomp c -> make_integer_comparison c n1 n2 | _ -> default end (* float *) @@ -305,7 +321,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Psubfloat -> make_const_float (n1 -. n2) | Pmulfloat -> make_const_float (n1 *. n2) | Pdivfloat -> make_const_float (n1 /. n2) - | Pfloatcomp c -> make_comparison c n1 n2 + | Pfloatcomp c -> make_float_comparison c n1 n2 | _ -> default end (* nativeint *) @@ -331,7 +347,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) - | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 | _ -> default end (* nativeint, int *) @@ -369,7 +385,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) - | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 | _ -> default end (* int32, int *) @@ -407,7 +423,7 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg = | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) - | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 | _ -> default end (* int64, int *) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 81b9ec4260..09c6244197 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -89,24 +89,21 @@ let size_machtype mty = done; !size -type comparison = - Ceq - | Cne - | Clt - | Cle - | Cgt - | Cge - -let negate_comparison = function - Ceq -> Cne | Cne -> Ceq - | Clt -> Cge | Cle -> Cgt - | Cgt -> Cle | Cge -> Clt - -let swap_comparison = function - Ceq -> Ceq | Cne -> Cne - | Clt -> Cgt | Cle -> Cge - | Cgt -> Clt | Cge -> Cle +type integer_comparison = Lambda.integer_comparison = + | Ceq | Cne | Clt | Cgt | Cle | Cge +let negate_integer_comparison = Lambda.negate_integer_comparison + +let swap_integer_comparison = Lambda.swap_integer_comparison + +(* With floats [not (x < y)] is not the same as [x >= y] due to NaNs, + so we provide additional comparisons to represent the negations.*) +type float_comparison = Lambda.float_comparison = + | CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +let negate_float_comparison = Lambda.negate_float_comparison + +let swap_float_comparison = Lambda.swap_float_comparison type label = int let label_counter = ref 99 @@ -144,14 +141,14 @@ and operation = | Cstore of memory_chunk * Lambda.initialization_or_assignment | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr - | Ccmpi of comparison + | Ccmpi of integer_comparison | Caddv | Cadda - | Ccmpa of comparison + | Ccmpa of integer_comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat - | Ccmpf of comparison - | Craise of Lambda.raise_kind + | Ccmpf of float_comparison + | Craise of raise_kind | Ccheckbound | Cpoll diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 291aa4717b..98ff437381 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -72,16 +72,17 @@ val ge_component val size_machtype: machtype -> int -type comparison = - Ceq - | Cne - | Clt - | Cle - | Cgt - | Cge +type integer_comparison = Lambda.integer_comparison = + | Ceq | Cne | Clt | Cgt | Cle | Cge -val negate_comparison: comparison -> comparison -val swap_comparison: comparison -> comparison +val negate_integer_comparison: integer_comparison -> integer_comparison +val swap_integer_comparison: integer_comparison -> integer_comparison + +type float_comparison = Lambda.float_comparison = + | CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +val negate_float_comparison: float_comparison -> float_comparison +val swap_float_comparison: float_comparison -> float_comparison type label = int val new_label: unit -> label @@ -117,15 +118,15 @@ and operation = | Cstore of memory_chunk * Lambda.initialization_or_assignment | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr - | Ccmpi of comparison + | Ccmpi of integer_comparison | Caddv (* pointer addition that produces a [Val] (well-formed Caml value) *) | Cadda (* pointer addition that produces a [Addr] (derived heap pointer) *) - | Ccmpa of comparison + | Ccmpa of integer_comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat - | Ccmpf of comparison - | Craise of Lambda.raise_kind + | Ccmpf of float_comparison + | Craise of raise_kind | Ccheckbound | Cpoll diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 07225e67cd..d3ceee8462 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -291,9 +291,14 @@ let mk_not dbg cmm = | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') -> begin match c with | Cop(Ccmpi cmp, [c1; c2], dbg'') -> - tag_int (Cop(Ccmpi (negate_comparison cmp), [c1; c2], dbg'')) dbg' + tag_int + (Cop(Ccmpi (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' | Cop(Ccmpa cmp, [c1; c2], dbg'') -> - tag_int (Cop(Ccmpa (negate_comparison cmp), [c1; c2], dbg'')) dbg' + tag_int + (Cop(Ccmpa (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg' + | Cop(Ccmpf cmp, [c1; c2], dbg'') -> + tag_int + (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg' | _ -> (* 0 -> 3, 1 -> 1 *) Cop(Csubi, [Cconst_int 3; Cop(Clsl, [c; Cconst_int 1], dbg)], dbg) @@ -870,13 +875,9 @@ let curry_function n = (* Comparisons *) -let transl_comparison = function - Lambda.Ceq -> Ceq - | Lambda.Cneq -> Cne - | Lambda.Cge -> Cge - | Lambda.Cgt -> Cgt - | Lambda.Cle -> Cle - | Lambda.Clt -> Clt +let transl_int_comparison cmp = cmp + +let transl_float_comparison cmp = cmp (* Translate structured constants *) @@ -1367,7 +1368,7 @@ let simplif_primitive_32bits = function | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned") | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right") | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal") - | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal") + | Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal") | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan") | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") @@ -2211,7 +2212,7 @@ and transl_prim_2 env p arg1 arg2 dbg = Cop(Cor, [asr_int (transl env arg1) (untag_int(transl env arg2) dbg) dbg; Cconst_int 1], dbg) | Pintcomp cmp -> - tag_int(Cop(Ccmpi(transl_comparison cmp), + tag_int(Cop(Ccmpi(transl_int_comparison cmp), [transl env arg1; transl env arg2], dbg)) dbg | Pisout -> transl_isout (transl env arg1) (transl env arg2) dbg @@ -2233,7 +2234,7 @@ and transl_prim_2 env p arg1 arg2 dbg = [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) | Pfloatcomp cmp -> - tag_int(Cop(Ccmpf(transl_comparison cmp), + tag_int(Cop(Ccmpf(transl_float_comparison cmp), [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) dbg @@ -2428,7 +2429,7 @@ and transl_prim_2 env p arg1 arg2 dbg = [transl_unbox_int dbg env bi arg1; untag_int(transl env arg2) dbg], dbg)) | Pbintcomp(bi, cmp) -> - tag_int (Cop(Ccmpi(transl_comparison cmp), + tag_int (Cop(Ccmpi(transl_int_comparison cmp), [transl_unbox_int dbg env bi arg1; transl_unbox_int dbg env bi arg2], dbg)) dbg | Patomic_exchange -> diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 0d984d5dd4..2d633f55ad 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -356,7 +356,7 @@ let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false (* Emit the code for a floating-point comparison *) -let emit_float_test cmp neg arg lbl = +let emit_float_test cmp arg lbl = let actual_cmp = match (is_tos arg.(0), is_tos arg.(1)) with | (true, true) -> @@ -370,7 +370,7 @@ let emit_float_test cmp neg arg lbl = | (false, true) -> (* second arg on top of FP stack *) I.fcomp (reg arg.(0)); - Cmm.swap_comparison cmp + Cmm.swap_float_comparison cmp | (false, false) -> I.fld (reg arg.(0)); I.fcomp (reg arg.(1)); @@ -378,49 +378,44 @@ let emit_float_test cmp neg arg lbl = in I.fnstsw ax; match actual_cmp with - | Ceq -> - if neg then begin - I.and_ (int 68) ah; - I.xor (int 64) ah; - I.jne lbl - end else begin - I.and_ (int 69) ah; - I.cmp (int 64) ah; - I.je lbl - end - | Cne -> - if neg then begin - I.and_ (int 69) ah; - I.cmp (int 64) ah; - I.je lbl - end else begin - I.and_ (int 68) ah; - I.xor (int 64) ah; - I.jne lbl - end - | Cle -> + | CFeq -> + I.and_ (int 69) ah; + I.cmp (int 64) ah; + I.je lbl + | CFneq -> + I.and_ (int 68) ah; + I.xor (int 64) ah; + I.jne lbl + | CFle -> I.and_ (int 69) ah; I.dec ah; I.cmp (int 64) ah; - if neg - then I.jae lbl - else I.jb lbl - | Cge -> + I.jb lbl + | CFnle -> + I.and_ (int 69) ah; + I.dec ah; + I.cmp (int 64) ah; + I.jae lbl + | CFge -> + I.and_ (int 5) ah; + I.je lbl + | CFnge -> I.and_ (int 5) ah; - if neg - then I.jne lbl - else I.je lbl - | Clt -> + I.jne lbl + | CFlt -> I.and_ (int 69) ah; I.cmp (int 1) ah; - if neg - then I.jne lbl - else I.je lbl - | Cgt -> + I.je lbl + | CFnlt -> + I.and_ (int 69) ah; + I.cmp (int 1) ah; + I.jne lbl + | CFgt -> + I.and_ (int 69) ah; + I.je lbl + | CFngt -> I.and_ (int 69) ah; - if neg - then I.jne lbl - else I.je lbl + I.jne lbl (* Emit a Ifloatspecial instruction *) @@ -825,8 +820,8 @@ let emit_instr fallthrough i = | Iinttest_imm(cmp, n) -> I.cmp (int n) (reg i.arg.(0)); I.j (cond cmp) lbl - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl + | Ifloattest cmp -> + emit_float_test cmp i.arg lbl | Ioddtest -> I.test (int 1) (reg i.arg.(0)); I.jne lbl diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 9350fc96d4..7e883fc7ee 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -191,7 +191,7 @@ let destroyed_at_oper = function | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] | Iop(Iintoffloat) -> [| eax |] - | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] + | Iifthenelse(Ifloattest _, _, _) -> [| eax |] | _ -> [||] let destroyed_at_raise = all_phys_regs diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 9553d2e407..c66f299e8c 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -60,15 +60,15 @@ type fundecl = (* Invert a test *) let invert_integer_test = function - Isigned cmp -> Isigned(Cmm.negate_comparison cmp) - | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) + Isigned cmp -> Isigned(Cmm.negate_integer_comparison cmp) + | Iunsigned cmp -> Iunsigned(Cmm.negate_integer_comparison cmp) let invert_test = function Itruetest -> Ifalsetest | Ifalsetest -> Itruetest | Iinttest(cmp) -> Iinttest(invert_integer_test cmp) | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n) - | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg) + | Ifloattest(cmp) -> Ifloattest(Cmm.negate_float_comparison cmp) | Ieventest -> Ioddtest | Ioddtest -> Ieventest diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 7c13a60189..52e5ba977c 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -18,8 +18,8 @@ type label = Cmm.label type integer_comparison = - Isigned of Cmm.comparison - | Iunsigned of Cmm.comparison + Isigned of Cmm.integer_comparison + | Iunsigned of Cmm.integer_comparison type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod @@ -28,12 +28,14 @@ type integer_operation = | Icheckbound of { label_after_error : label option; spacetime_index : int; } +type float_comparison = Cmm.float_comparison + type test = Itruetest | Ifalsetest | Iinttest of integer_comparison | Iinttest_imm of integer_comparison * int - | Ifloattest of Cmm.comparison * bool + | Ifloattest of float_comparison | Ioddtest | Ieventest diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index f5a6bfba25..15561538b4 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -22,8 +22,8 @@ type label = Cmm.label type integer_comparison = - Isigned of Cmm.comparison - | Iunsigned of Cmm.comparison + Isigned of Cmm.integer_comparison + | Iunsigned of Cmm.integer_comparison type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod @@ -35,12 +35,14 @@ type integer_operation = second being the pointer to the trie node for the current function (and the first being as per non-Spacetime mode). *) +type float_comparison = Cmm.float_comparison + type test = Itruetest | Ifalsetest | Iinttest of integer_comparison | Iinttest_imm of integer_comparison * int - | Ifloattest of Cmm.comparison * bool + | Ifloattest of float_comparison | Ioddtest | Ieventest diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 0ab36376c1..bd0c7134ad 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -847,22 +847,27 @@ let emit_instr i = let (comp, branch) = name_for_int_comparison cmp in ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; ` {emit_string branch} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> + | Ifloattest cmp -> begin ` fcmpu 0, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) - let (bitnum, negtst) = + let bitnum = match cmp with - Ceq -> (2, neg) - | Cne -> (2, not neg) - | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *) - (3, neg) - | Cgt -> (1, neg) - | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) - (3, neg) - | Clt -> (0, neg) in - if negtst - then ` bf {emit_int bitnum}, {emit_label lbl}\n` - else ` bt {emit_int bitnum}, {emit_label lbl}\n` + | CFeq | CFneq -> 2 + | CFle | CFnle -> + ` cror 3, 0, 2\n`; (* lt or eq *) + 3 + | CFgt | CFngt -> 1 + | CFge | CFnge -> + ` cror 3, 1, 2\n`; (* gt or eq *) + 3 + | CFlt | CFnlt -> 0 + in + match cmp with + | CFneq | CFngt | CFnge | CFnlt | CFnle -> + ` bf {emit_int bitnum}, {emit_label lbl}\n` + | CFeq | CFgt | CFge | CFlt | CFle -> + ` bt {emit_int bitnum}, {emit_label lbl}\n` + end | Ioddtest -> ` andi. 0, {emit_reg i.arg.(0)}, 1\n`; ` bne {emit_label lbl}\n` diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 7d5a39e42b..4c0007d2b7 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -36,7 +36,7 @@ let machtype ppf mty = fprintf ppf "*%a" machtype_component mty.(i) done -let comparison = function +let integer_comparison = function | Ceq -> "==" | Cne -> "!=" | Clt -> "<" @@ -44,6 +44,18 @@ let comparison = function | Cgt -> ">" | Cge -> ">=" +let float_comparison = function + | CFeq -> "==" + | CFneq -> "!=" + | CFlt -> "<" + | CFnlt -> "!<" + | CFle -> "<=" + | CFnle -> "!<=" + | CFgt -> ">" + | CFngt -> "!>" + | CFge -> ">=" + | CFnge -> "!>=" + let chunk = function | Byte_unsigned -> "unsigned int8" | Byte_signed -> "signed int8" @@ -87,10 +99,10 @@ let operation d = function | Clsl -> "<<" | Clsr -> ">>u" | Casr -> ">>s" - | Ccmpi c -> comparison c + | Ccmpi c -> integer_comparison c | Caddv -> "+v" | Cadda -> "+a" - | Ccmpa c -> Printf.sprintf "%sa" (comparison c) + | Ccmpa c -> Printf.sprintf "%sa" (integer_comparison c) | Cnegf -> "~f" | Cabsf -> "absf" | Caddf -> "+f" @@ -99,8 +111,8 @@ let operation d = function | Cdivf -> "/f" | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" - | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise k -> Format.asprintf "%s%s" (Lambda.raise_kind k) (Debuginfo.to_string d) + | Ccmpf c -> Printf.sprintf "%sf" (float_comparison c) + | Craise k -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d) | Ccheckbound -> "checkbound" ^ Debuginfo.to_string d | Cpoll -> "poll" diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index 5f5eb41c0b..462239ac82 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -20,7 +20,8 @@ open Format val rec_flag : formatter -> Cmm.rec_flag -> unit val machtype_component : formatter -> Cmm.machtype_component -> unit val machtype : formatter -> Cmm.machtype_component array -> unit -val comparison : Cmm.comparison -> string +val integer_comparison : Cmm.integer_comparison -> string +val float_comparison : Cmm.float_comparison -> string val chunk : Cmm.memory_chunk -> string val operation : Debuginfo.t -> Cmm.operation -> string val expression : formatter -> Cmm.expression -> unit diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 62e4ec442a..dd6f904fc9 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -68,11 +68,11 @@ let regsetaddr ppf s = s let intcomp = function - | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c) - | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c) + | Isigned c -> Printf.sprintf " %ss " (Printcmm.integer_comparison c) + | Iunsigned c -> Printf.sprintf " %su " (Printcmm.integer_comparison c) let floatcomp c = - Printf.sprintf " %sf " (Printcmm.comparison c) + Printf.sprintf " %sf " (Printcmm.float_comparison c) let intop = function | Iadd -> " + " @@ -105,9 +105,8 @@ let test tst ppf arg = | Ifalsetest -> fprintf ppf "not %a" reg arg.(0) | Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1) | Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n - | Ifloattest(cmp, neg) -> - fprintf ppf "%s%a%s%a" - (if neg then "not " else "") + | Ifloattest cmp -> + fprintf ppf "%a%s%a" reg arg.(0) (floatcomp cmp) reg arg.(1) | Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0) | Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0) diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index 3487005ec6..cef1022ae1 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -238,10 +238,11 @@ let int_literals = ref ([] : (nativeint * int) list) (* Masks for conditional branches after comparisons *) +(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = overflow*) let branch_for_comparison = function - Ceq -> 8 | Cne -> 7 - | Cle -> 12 | Cgt -> 2 - | Cge -> 10 | Clt -> 4 + | Ceq -> 0b1000 | Cne -> 0b0111 (* BRNEL is 0111 rather than 0110 *) + | Cle -> 0b1100 | Cgt -> 0b0010 + | Cge -> 0b1010 | Clt -> 0b0100 let name_for_int_comparison = function Isigned cmp -> ("cgr", branch_for_comparison cmp) @@ -252,14 +253,21 @@ let name_for_int_comparison_imm = function | Iunsigned cmp -> ("clgfi", branch_for_comparison cmp) (* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*) -let branch_for_float_comparison cmp neg = - match cmp with - Ceq -> if neg then 7 else 8 - | Cne -> if neg then 8 else 7 - | Cle -> if neg then 3 else 12 - | Cgt -> if neg then 13 else 2 - | Cge -> if neg then 5 else 10 - | Clt -> if neg then 11 else 4 +let branch_for_float_comparison = function + | CFeq -> 0b1000 + | CFneq -> 0b0111 + + | CFle -> 0b1100 + | CFnle -> 0b0011 + + | CFgt -> 0b0010 + | CFngt -> 0b1101 + + | CFge -> 0b1010 + | CFnge -> 0b0101 + + | CFlt -> 0b0100 + | CFnlt -> 0b1011 (* Names for various instructions *) @@ -554,9 +562,9 @@ let emit_instr i = let (comp, mask) = name_for_int_comparison_imm cmp in ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`; ` brcl {emit_int mask}, {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> + | Ifloattest cmp -> ` cdbr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - let mask = branch_for_float_comparison cmp neg in + let mask = branch_for_float_comparison cmp in ` brcl {emit_int mask}, {emit_label lbl}\n` | Ioddtest -> ` tmll {emit_reg i.arg.(0)}, 1\n`; diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 68fca60364..0ee1815e33 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -107,8 +107,8 @@ let size_expr (env:environment) exp = (* Swap the two arguments of an integer comparison *) let swap_intcomp = function - Isigned cmp -> Isigned(swap_comparison cmp) - | Iunsigned cmp -> Iunsigned(swap_comparison cmp) + Isigned cmp -> Isigned(swap_integer_comparison cmp) + | Iunsigned cmp -> Iunsigned(swap_integer_comparison cmp) (* Naming of registers *) @@ -516,11 +516,11 @@ method select_condition = function Cop(Ccmpi cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) | Cop(Ccmpi cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> - (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) + (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpi cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) | Cop(Ccmpi cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> - (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) + (Iinttest_imm(Isigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpi cmp, args, _) -> (Iinttest(Isigned cmp), Ctuple args) | Cop(Ccmpa cmp, [arg1; Cconst_pointer n], _) when self#is_immediate n -> @@ -528,13 +528,13 @@ method select_condition = function | Cop(Ccmpa cmp, [arg1; Cconst_int n], _) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) | Cop(Ccmpa cmp, [Cconst_pointer n; arg2], _) when self#is_immediate n -> - (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) + (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpa cmp, [Cconst_int n; arg2], _) when self#is_immediate n -> - (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) + (Iinttest_imm(Iunsigned(swap_integer_comparison cmp), n), arg2) | Cop(Ccmpa cmp, args, _) -> (Iinttest(Iunsigned cmp), Ctuple args) | Cop(Ccmpf cmp, args, _) -> - (Ifloattest(cmp, false), Ctuple args) + (Ifloattest cmp, Ctuple args) | Cop(Cand, [arg; Cconst_int 1], _) -> (Ioddtest, arg) | arg -> diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 722704f3a1..74e17ad0b8 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 899238abbb..b8fb495cf4 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 81a5f76367..0ee996c19a 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index c2784b860c..6bb504699d 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -362,12 +362,6 @@ let comp_primitive p sz args = | Psubfloat -> Kccall("caml_sub_float", 2) | Pmulfloat -> Kccall("caml_mul_float", 2) | Pdivfloat -> Kccall("caml_div_float", 2) - | Pfloatcomp Ceq -> Kccall("caml_eq_float", 2) - | Pfloatcomp Cneq -> Kccall("caml_neq_float", 2) - | Pfloatcomp Clt -> Kccall("caml_lt_float", 2) - | Pfloatcomp Cgt -> Kccall("caml_gt_float", 2) - | Pfloatcomp Cle -> Kccall("caml_le_float", 2) - | Pfloatcomp Cge -> Kccall("caml_ge_float", 2) | Pstringlength -> Kccall("caml_ml_string_length", 1) | Pbyteslength -> Kccall("caml_ml_bytes_length", 1) | Pstringrefs -> Kccall("caml_string_get", 2) @@ -429,7 +423,7 @@ let comp_primitive p sz args = | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args | Pasrbint bi -> comp_bint_primitive bi "shift_right" args | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2) - | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2) + | Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2) | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2) | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2) | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2) @@ -714,10 +708,25 @@ let rec comp_expr env exp sz cont = Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg" (* Integer first for enabling further optimization (cf. emitcode.ml) *) | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) -> - let p = Pintcomp (commute_comparison c) + let p = Pintcomp (swap_integer_comparison c) and args = [k ; arg] in let nargs = List.length args - 1 in comp_args env args sz (comp_primitive p (sz + nargs - 1) args :: cont) + | Lprim (Pfloatcomp cmp, args, _) -> + let cont = + match cmp with + | CFeq -> Kccall("caml_eq_float", 2) :: cont + | CFneq -> Kccall("caml_neq_float", 2) :: cont + | CFlt -> Kccall("caml_lt_float", 2) :: cont + | CFnlt -> Kccall("caml_lt_float", 2) :: Kboolnot :: cont + | CFgt -> Kccall("caml_gt_float", 2) :: cont + | CFngt -> Kccall("caml_gt_float", 2) :: Kboolnot :: cont + | CFle -> Kccall("caml_le_float", 2) :: cont + | CFnle -> Kccall("caml_le_float", 2) :: Kboolnot :: cont + | CFge -> Kccall("caml_ge_float", 2) :: cont + | CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont + in + comp_args env args sz cont | Lprim(p, args, _) -> let nargs = List.length args - 1 in comp_args env args sz (comp_primitive p (sz + nargs - 1) args :: cont) @@ -797,7 +806,7 @@ let rec comp_expr env exp sz cont = Klabel lbl_loop :: Kcheck_signals :: comp_expr (add_var param (sz+1) env) body (sz+2) (Kacc 1 :: Kpush :: Koffsetint offset :: Kassign 2 :: - Kacc 1 :: Kintcomp Cneq :: Kbranchif lbl_loop :: + Kacc 1 :: Kintcomp Cne :: Kbranchif lbl_loop :: Klabel lbl_exit :: add_const_unit (add_pop 2 cont)))) | Lswitch(arg, sw, _loc) -> let (branch, cont1) = make_branch cont in diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index b23a1dc6bf..24855ec696 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -21,3 +21,5 @@ open Instruct val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list val reset: unit -> unit + +val merge_events : Instruct.debug_event -> Instruct.debug_event -> Instruct.debug_event diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 755e276b9a..b554c75051 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -292,9 +292,9 @@ let output_stringlist oc l = (* Transform a file name into an absolute file name *) let make_absolute file = - if Filename.is_relative file - then Filename.concat (Sys.getcwd()) file - else file + if not (Filename.is_relative file) then file + else Location.rewrite_absolute_path + (Filename.concat (Sys.getcwd()) file) (* Create a bytecode executable file *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 3cd252e556..c0e976a942 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -168,8 +168,10 @@ let record_event ev = let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in let abspath = Location.absolute_path path in debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; - if Filename.is_relative path then - debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs; + if Filename.is_relative path then begin + let cwd = Location.rewrite_absolute_path (Sys.getcwd ()) in + debug_dirs := StringSet.add cwd !debug_dirs; + end; ev.ev_pos <- !out_position; events := ev :: !events @@ -185,12 +187,12 @@ let init () = (* Emission of one instruction *) let emit_comp = function -| Ceq -> out opEQ | Cneq -> out opNEQ +| Ceq -> out opEQ | Cne -> out opNEQ | Clt -> out opLTINT | Cle -> out opLEINT | Cgt -> out opGTINT | Cge -> out opGEINT and emit_branch_comp = function -| Ceq -> out opBEQ | Cneq -> out opBNEQ +| Ceq -> out opBEQ | Cne -> out opBNEQ | Clt -> out opBLTINT | Cle -> out opBLEINT | Cgt -> out opBGTINT | Cge -> out opBGEINT @@ -310,6 +312,11 @@ let emit_instr = function (* Emission of a list of instructions. Include some peephole optimization. *) +let remerge_events ev1 = function + | Kevent ev2 :: c -> + Kevent (Bytegen.merge_events ev1 ev2) :: c + | c -> Kevent ev1 :: c + let rec emit = function [] -> () (* Peephole optimizations *) @@ -322,7 +329,7 @@ let rec emit = function emit rem | Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem when is_immed_const k -> - emit_branch_comp (negate_comparison c) ; + emit_branch_comp (negate_integer_comparison c) ; out_const k ; out_label lbl ; emit rem @@ -378,13 +385,13 @@ let rec emit = function out opPUSHGETGLOBAL; slot_for_literal sc end; emit c - | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + | Kpush :: (Kevent ({ev_kind = Event_before} as ev)) :: (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c -> - emit (Kpush :: instr1 :: instr2 :: ev :: c) - | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: + emit (Kpush :: instr1 :: instr2 :: remerge_events ev c) + | Kpush :: (Kevent ({ev_kind = Event_before} as ev)) :: (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr):: c -> - emit (Kpush :: instr :: ev :: c) + emit (Kpush :: instr :: remerge_events ev c) | Kgetglobal id :: Kgetfield n :: c -> out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c (* Default case *) diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 6480777c6a..3f38041972 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -94,7 +94,7 @@ type instruction = | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint - | Kintcomp of comparison + | Kintcomp of integer_comparison | Koffsetint of int | Koffsetref of int | Kisint diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 9bcc09f4c0..314aac0d8e 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -114,7 +114,7 @@ type instruction = | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint - | Kintcomp of comparison + | Kintcomp of integer_comparison | Koffsetint of int | Koffsetref of int | Kisint diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index bc905860bb..261a683583 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -85,14 +85,14 @@ type primitive = | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintcomp of comparison + | Pintcomp of integer_comparison | Poffsetint of int | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of comparison + | Pfloatcomp of float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -126,7 +126,7 @@ type primitive = | Plslbint of boxed_integer | Plsrbint of boxed_integer | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * comparison + | Pbintcomp of boxed_integer * integer_comparison (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -164,8 +164,11 @@ type primitive = (* Polling for interrupts *) | Ppoll -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge and value_kind = Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval @@ -677,15 +680,45 @@ let bind str var exp body = Lvar var' when Ident.same var var' -> body | _ -> Llet(str, Pgenval, var, exp, body) -and commute_comparison = function -| Ceq -> Ceq| Cneq -> Cneq -| Clt -> Cgt | Cle -> Cge -| Cgt -> Clt | Cge -> Cle - -and negate_comparison = function -| Ceq -> Cneq| Cneq -> Ceq -| Clt -> Cge | Cle -> Cgt -| Cgt -> Cle | Cge -> Clt +let negate_integer_comparison = function + | Ceq -> Cne + | Cne -> Ceq + | Clt -> Cge + | Cle -> Cgt + | Cgt -> Cle + | Cge -> Clt + +let swap_integer_comparison = function + | Ceq -> Ceq + | Cne -> Cne + | Clt -> Cgt + | Cle -> Cge + | Cgt -> Clt + | Cge -> Cle + +let negate_float_comparison = function + | CFeq -> CFneq + | CFneq -> CFeq + | CFlt -> CFnlt + | CFnlt -> CFlt + | CFgt -> CFngt + | CFngt -> CFgt + | CFle -> CFnle + | CFnle -> CFle + | CFge -> CFnge + | CFnge -> CFge + +let swap_float_comparison = function + | CFeq -> CFeq + | CFneq -> CFneq + | CFlt -> CFgt + | CFnlt -> CFngt + | CFle -> CFge + | CFnle -> CFnge + | CFgt -> CFlt + | CFngt -> CFnlt + | CFge -> CFle + | CFnge -> CFnle let raise_kind = function | Raise_regular -> "raise" diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index f2ac7f0635..18e87ad285 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -90,14 +90,14 @@ type primitive = | Pdivint of is_safe | Pmodint of is_safe | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintcomp of comparison + | Pintcomp of integer_comparison | Poffsetint of int | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of comparison + | Pfloatcomp of float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -134,7 +134,7 @@ type primitive = | Plslbint of boxed_integer | Plsrbint of boxed_integer | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * comparison + | Pbintcomp of boxed_integer * integer_comparison (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -172,8 +172,11 @@ type primitive = (* Polling for interrupts *) | Ppoll -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray @@ -353,8 +356,11 @@ val subst_lambda: lambda Ident.tbl -> lambda -> lambda val map : (lambda -> lambda) -> lambda -> lambda val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda -val commute_comparison : comparison -> comparison -val negate_comparison : comparison -> comparison +val negate_integer_comparison : integer_comparison -> integer_comparison +val swap_integer_comparison : integer_comparison -> integer_comparison + +val negate_float_comparison : float_comparison -> float_comparison +val swap_float_comparison : float_comparison -> float_comparison val default_function_attribute : function_attribute val default_stub_attribute : function_attribute diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 9d17989d03..44cf8724d9 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1909,7 +1909,7 @@ module SArg = struct type primitive = Lambda.primitive let eqint = Pintcomp Ceq - let neint = Pintcomp Cneq + let neint = Pintcomp Cne let leint = Pintcomp Cle let ltint = Pintcomp Clt let geint = Pintcomp Cge @@ -2262,22 +2262,22 @@ let combine_constant loc arg cst partial ctx def | Const_float _ -> make_test_sequence loc fail - (Pfloatcomp Cneq) (Pfloatcomp Clt) + (Pfloatcomp CFneq) (Pfloatcomp CFlt) arg const_lambda_list | Const_int32 _ -> make_test_sequence loc fail - (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) + (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt)) arg const_lambda_list | Const_int64 _ -> make_test_sequence loc fail - (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) + (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt)) arg const_lambda_list | Const_nativeint _ -> make_test_sequence loc fail - (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) + (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt)) arg const_lambda_list in lambda1,jumps_union local_jumps total diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 8068f1e2f7..1ab3ef1616 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -88,7 +88,7 @@ let instruction ppf = function | Klsrint -> fprintf ppf "\tlsrint" | Kasrint -> fprintf ppf "\tasrint" | Kintcomp Ceq -> fprintf ppf "\teqint" - | Kintcomp Cneq -> fprintf ppf "\tneqint" + | Kintcomp Cne -> fprintf ppf "\tneqint" | Kintcomp Clt -> fprintf ppf "\tltint" | Kintcomp Cgt -> fprintf ppf "\tgtint" | Kintcomp Cle -> fprintf ppf "\tleint" diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 1ac429b20d..75d1a60e0f 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -128,6 +128,26 @@ let block_shape ppf shape = match shape with t; Format.fprintf ppf ")" +let integer_comparison ppf = function + | Ceq -> fprintf ppf "==" + | Cne -> fprintf ppf "!=" + | Clt -> fprintf ppf "<" + | Cle -> fprintf ppf "<=" + | Cgt -> fprintf ppf ">" + | Cge -> fprintf ppf ">=" + +let float_comparison ppf = function + | CFeq -> fprintf ppf "==." + | CFneq -> fprintf ppf "!=." + | CFlt -> fprintf ppf "<." + | CFnlt -> fprintf ppf "!<." + | CFle -> fprintf ppf "<=." + | CFnle -> fprintf ppf "!<=." + | CFgt -> fprintf ppf ">." + | CFngt -> fprintf ppf "!>." + | CFge -> fprintf ppf ">=." + | CFnge -> fprintf ppf "!>=." + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pbytes_to_string -> fprintf ppf "bytes_to_string" @@ -211,12 +231,7 @@ let primitive ppf = function | Plslint -> fprintf ppf "lsl" | Plsrint -> fprintf ppf "lsr" | Pasrint -> fprintf ppf "asr" - | Pintcomp(Ceq) -> fprintf ppf "==" - | Pintcomp(Cneq) -> fprintf ppf "!=" - | Pintcomp(Clt) -> fprintf ppf "<" - | Pintcomp(Cle) -> fprintf ppf "<=" - | Pintcomp(Cgt) -> fprintf ppf ">" - | Pintcomp(Cge) -> fprintf ppf ">=" + | Pintcomp(cmp) -> integer_comparison ppf cmp | Poffsetint n -> fprintf ppf "%i+" n | Poffsetref n -> fprintf ppf "+:=%i"n | Pintoffloat -> fprintf ppf "int_of_float" @@ -227,12 +242,7 @@ let primitive ppf = function | Psubfloat -> fprintf ppf "-." | Pmulfloat -> fprintf ppf "*." | Pdivfloat -> fprintf ppf "/." - | Pfloatcomp(Ceq) -> fprintf ppf "==." - | Pfloatcomp(Cneq) -> fprintf ppf "!=." - | Pfloatcomp(Clt) -> fprintf ppf "<." - | Pfloatcomp(Cle) -> fprintf ppf "<=." - | Pfloatcomp(Cgt) -> fprintf ppf ">." - | Pfloatcomp(Cge) -> fprintf ppf ">=." + | Pfloatcomp(cmp) -> float_comparison ppf cmp | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" @@ -287,7 +297,7 @@ let primitive ppf = function | Plsrbint bi -> print_boxed_integer "lsr" ppf bi | Pasrbint bi -> print_boxed_integer "asr" ppf bi | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi - | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 5dad389548..5c2d39f6c1 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -73,7 +73,7 @@ let comparisons_table = create_hashtable 11 [ "%equal", (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true), Pintcomp Ceq, - Pfloatcomp Ceq, + Pfloatcomp CFeq, Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false), Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2 @@ -84,20 +84,20 @@ let comparisons_table = create_hashtable 11 [ true); "%notequal", (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true), - Pintcomp Cneq, - Pfloatcomp Cneq, + Pintcomp Cne, + Pfloatcomp CFneq, Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false), Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false), - Pbintcomp(Pnativeint, Cneq), - Pbintcomp(Pint32, Cneq), - Pbintcomp(Pint64, Cneq), + Pbintcomp(Pnativeint, Cne), + Pbintcomp(Pint32, Cne), + Pbintcomp(Pint64, Cne), true); "%lessthan", (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true), Pintcomp Clt, - Pfloatcomp Clt, + Pfloatcomp CFlt, Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false), Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 @@ -109,7 +109,7 @@ let comparisons_table = create_hashtable 11 [ "%greaterthan", (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true), Pintcomp Cgt, - Pfloatcomp Cgt, + Pfloatcomp CFgt, Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false), Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 @@ -121,7 +121,7 @@ let comparisons_table = create_hashtable 11 [ "%lessequal", (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true), Pintcomp Cle, - Pfloatcomp Cle, + Pfloatcomp CFle, Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false), Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 @@ -133,7 +133,7 @@ let comparisons_table = create_hashtable 11 [ "%greaterequal", (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true), Pintcomp Cge, - Pfloatcomp Cge, + Pfloatcomp CFge, Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false), Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 @@ -213,7 +213,7 @@ let primitives_table = create_hashtable 57 [ "%lsrint", Plsrint; "%asrint", Pasrint; "%eq", Pintcomp Ceq; - "%noteq", Pintcomp Cneq; + "%noteq", Pintcomp Cne; "%ltint", Pintcomp Clt; "%leint", Pintcomp Cle; "%gtint", Pintcomp Cgt; @@ -228,12 +228,12 @@ let primitives_table = create_hashtable 57 [ "%subfloat", Psubfloat; "%mulfloat", Pmulfloat; "%divfloat", Pdivfloat; - "%eqfloat", Pfloatcomp Ceq; - "%noteqfloat", Pfloatcomp Cneq; - "%ltfloat", Pfloatcomp Clt; - "%lefloat", Pfloatcomp Cle; - "%gtfloat", Pfloatcomp Cgt; - "%gefloat", Pfloatcomp Cge; + "%eqfloat", Pfloatcomp CFeq; + "%noteqfloat", Pfloatcomp CFneq; + "%ltfloat", Pfloatcomp CFlt; + "%lefloat", Pfloatcomp CFle; + "%gtfloat", Pfloatcomp CFgt; + "%gefloat", Pfloatcomp CFge; "%string_length", Pstringlength; "%string_safe_get", Pstringrefs; "%string_safe_set", Pbytessets; @@ -1123,15 +1123,18 @@ and transl_cases ?cont cases = List.map (transl_case ?cont) cases and transl_case_try {c_lhs; c_guard; c_rhs} = - match c_lhs.pat_desc with - | Tpat_var (id, _) - | Tpat_alias (_, id, _) -> - Hashtbl.replace try_ids id (); - Misc.try_finally - (fun () -> c_lhs, transl_guard c_guard c_rhs) - (fun () -> Hashtbl.remove try_ids id) - | _ -> - c_lhs, transl_guard c_guard c_rhs + let rec iter_exn_names f pat = + match pat.pat_desc with + | Tpat_var (id, _) -> f id + | Tpat_alias (p, id, _) -> + f id; + iter_exn_names f p + | _ -> () + in + iter_exn_names (fun id -> Hashtbl.replace try_ids id ()) c_lhs; + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + (fun () -> iter_exn_names (Hashtbl.remove try_ids) c_lhs) and transl_cases_try cases = let cases = @@ -1240,12 +1243,18 @@ and transl_function loc untuplify_fn repr partial param cases = Matching.for_function loc repr (Lvar param) (transl_cases cases) partial) -and transl_let rec_flag pat_expr_list body = +(* + Notice: transl_let consumes (ie compiles) its pat_expr_list argument, + and returns a function that will take the body of the lambda-let construct. + This complication allows choosing any compilation order for the + bindings and body of let constructs. +*) +and transl_let rec_flag pat_expr_list = match rec_flag with Nonrecursive -> let rec transl = function [] -> - body + fun body -> body | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> let lam = transl_exp expr in let lam = @@ -1254,7 +1263,8 @@ and transl_let rec_flag pat_expr_list body = let lam = Translattribute.add_specialise_attribute lam vb_loc attr in - Matching.for_let pat.pat_loc lam pat (transl rem) + let mk_body = transl rem in + fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body) in transl pat_expr_list | Recursive -> let idlist = @@ -1275,7 +1285,8 @@ and transl_let rec_flag pat_expr_list body = vb_attributes in (id, lam) in - Lletrec(List.map2 transl_case pat_expr_list idlist, body) + let lam_bds = List.map2 transl_case pat_expr_list idlist in + fun body -> Lletrec(lam_bds, body) and transl_setinstvar loc self var expr = Lprim(Psetfield_computed (maybe_pointer expr, Assignment), diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 1ef5aaf757..20197b89ec 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -458,6 +458,9 @@ and transl_module cc rootpath mexp = and transl_struct loc fields cc rootpath str = transl_structure loc fields cc rootpath str.str_final_env str.str_items +(* The function transl_structure is called by the bytecode compiler. + Some effort is made to compile in top to bottom order, in order to display + warning by increasing locations. *) and transl_structure loc fields cc rootpath final_env = function [] -> let body, size = @@ -514,11 +517,14 @@ and transl_structure loc fields cc rootpath final_env = function in Lsequence(transl_exp expr, body), size | Tstr_value(rec_flag, pat_expr_list) -> + (* Translate bindings first *) + let mk_lam_let = transl_let rec_flag pat_expr_list in let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + (* Then, translate remainder of struct *) let body, size = transl_structure loc ext_fields cc rootpath final_env rem in - transl_let rec_flag pat_expr_list body, size + mk_lam_let body, size | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure loc fields cc rootpath final_env rem @@ -551,9 +557,7 @@ and transl_structure loc fields cc rootpath final_env = function size | Tstr_module mb -> let id = mb.mb_id in - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in + (* Translate module first *) let module_body = transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr in @@ -561,6 +565,10 @@ and transl_structure loc fields cc rootpath final_env = function Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes in + (* Translate remainder second *) + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in let module_body = Levent (module_body, { lev_loc = mb.mb_loc; diff --git a/byterun/alloc.c b/byterun/alloc.c index 04ac3a71da..67d2aaa2f7 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -248,7 +248,7 @@ CAMLexport value caml_alloc_array(value (*funct)(char const *), } /* [len] is a number of floats */ -CAMLprim value caml_alloc_float_array(mlsize_t len) +value caml_alloc_float_array(mlsize_t len) { #ifdef FLAT_FLOAT_ARRAY mlsize_t wosize = len * Double_wosize; diff --git a/byterun/win32.c b/byterun/win32.c index a611ae0b3b..629a00d397 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -299,8 +299,6 @@ static volatile sighandler ctrl_handler_action = SIG_DFL; static BOOL WINAPI ctrl_handler(DWORD event) { - int saved_mode; - /* Only ctrl-C and ctrl-Break are handled */ if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE; /* Default behavior is to exit, which we get by not handling the event */ @@ -385,7 +383,7 @@ static void expand_pattern(wchar_t * pat) /* We need to stop at the first directory or drive boundary, because the * _findata_t structure contains the filename, not the leading directory. */ for (i = wcslen(prefix); i > 0; i--) { - char c = prefix[i - 1]; + wchar_t c = prefix[i - 1]; if (c == L'\\' || c == L'/' || c == L':') { prefix[i] = 0; break; } } /* No separator was found, it's a filename pattern without a leading directory. */ diff --git a/debugger/Makefile b/debugger/Makefile index 2c130dd1be..ae78b2e7fa 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -39,6 +39,7 @@ OTHEROBJS=\ ../utils/identifiable.cmo ../utils/numbers.cmo \ ../utils/arg_helper.cmo ../utils/clflags.cmo \ ../utils/consistbl.cmo ../utils/warnings.cmo \ + ../utils/build_path_prefix_map.cmo \ ../utils/terminfo.cmo \ ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \ ../parsing/syntaxerr.cmo \ diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 54a2c16707..9ab0d68096 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -124,7 +124,7 @@ let match_printer_type desc typename = let ty_arg = Ctype.newvar() in Ctype.unify Env.empty (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance Env.empty desc.val_type); + (Ctype.instance desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; ty_arg diff --git a/driver/main.ml b/driver/main.ml index 110ea3cf3e..5fc9387b8a 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -111,6 +111,8 @@ module Options = Main_args.Make_bytecomp_options (struct let _where = print_standard_library let _verbose = set verbose let _nopervasives = set nopervasives + let _dno_unique_ids = unset unique_ids + let _dunique_ids = set unique_ids let _dsource = set dump_source let _dparsetree = set dump_parsetree let _dtypedtree = set dump_typedtree diff --git a/driver/main_args.ml b/driver/main_args.ml index 757c7ac5b4..3501557a7e 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -613,6 +613,14 @@ let mk_drawlambda f = "-drawlambda", Arg.Unit f, " (undocumented)" ;; +let mk_dno_unique_ids f = + "-dno-unique-ids", Arg.Unit f, " (undocumented)" +;; + +let mk_dunique_ids f = + "-dunique-ids", Arg.Unit f, " (undocumented)" +;; + let mk_dsource f = "-dsource", Arg.Unit f, " (undocumented)" ;; @@ -809,6 +817,8 @@ module type Common_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dno_unique_ids : unit -> unit + val _dunique_ids : unit -> unit val _dsource : unit -> unit val _dparsetree : unit -> unit val _dtypedtree : unit -> unit @@ -1082,6 +1092,8 @@ struct mk_nopervasives F._nopervasives; mk_use_prims F._use_prims; + mk_dno_unique_ids F._dno_unique_ids; + mk_dunique_ids F._dunique_ids; mk_dsource F._dsource; mk_dparsetree F._dparsetree; mk_dtypedtree F._dtypedtree; @@ -1139,6 +1151,8 @@ struct mk_warn_help F._warn_help; mk__ F.anonymous; + mk_dno_unique_ids F._dno_unique_ids; + mk_dunique_ids F._dunique_ids; mk_dsource F._dsource; mk_dparsetree F._dparsetree; mk_dtypedtree F._dtypedtree; @@ -1254,6 +1268,8 @@ struct mk__ F.anonymous; mk_nopervasives F._nopervasives; + mk_dno_unique_ids F._dno_unique_ids; + mk_dunique_ids F._dunique_ids; mk_dsource F._dsource; mk_dparsetree F._dparsetree; mk_dtypedtree F._dtypedtree; diff --git a/driver/main_args.mli b/driver/main_args.mli index 3d6db5351e..848ae7b44c 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -49,6 +49,8 @@ module type Common_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dno_unique_ids : unit -> unit + val _dunique_ids : unit -> unit val _dsource : unit -> unit val _dparsetree : unit -> unit val _dtypedtree : unit -> unit diff --git a/driver/makedepend.ml b/driver/makedepend.ml index a10f6f6d4b..32d6e9d746 100644 --- a/driver/makedepend.ml +++ b/driver/makedepend.ml @@ -464,7 +464,8 @@ let sort_files_by_dependencies files = if !worklist <> [] then begin Format.fprintf Format.err_formatter - "@[Error: cycle in dependencies. End of list is not sorted.@]@."; + "@[%t: cycle in dependencies. End of list is not sorted.@]@." + Location.print_error_prefix; let sorted_deps = let li = ref [] in Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h; diff --git a/driver/optmain.ml b/driver/optmain.ml index 33fc848d14..8201320177 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -195,6 +195,8 @@ module Options = Main_args.Make_optcomp_options (struct let _where () = print_standard_library () let _nopervasives = set nopervasives + let _dno_unique_ids = clear unique_ids + let _dunique_ids = set unique_ids let _dsource = set dump_source let _dparsetree = set dump_parsetree let _dtypedtree = set dump_typedtree diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 7f5a0a515d..37ff25b008 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -260,7 +260,7 @@ let output_automata ctx auto inline = (* Output the entries *) -let output_init ctx pref e = +let output_init ctx pref e init_moves = if e.auto_mem_size > 0 then pr ctx "%slexbuf.Lexing.lex_mem <- Array.make %d (-1);\n" pref e.auto_mem_size; @@ -269,7 +269,8 @@ let output_init ctx pref e = pr ctx "%slet _len = lexbuf.Lexing.lex_buffer_len in\n" pref; pr ctx "%slet _buf = lexbuf.Lexing.lex_buffer in\n" pref; pr ctx "%slet _last_action = -1 in\n" pref; - pr ctx "%slexbuf.Lexing.lex_start_pos <- _curr;\n" pref + pr ctx "%slexbuf.Lexing.lex_start_pos <- _curr;\n" pref; + output_memory_actions pref ctx.oc init_moves let output_rules ic ctx pref tr e = pr ctx "%sbegin\n" pref; @@ -294,17 +295,16 @@ let output_rules ic ctx pref tr e = let output_entry ic ctx tr e = let init_num, init_moves = e.auto_initial_state in pr ctx "%s %alexbuf =\n" e.auto_name output_args e.auto_args; - output_memory_actions " " ctx.oc init_moves; if ctx.has_refill then begin pr ctx " let k lexbuf __ocaml_lex_result =\n"; output_rules ic ctx " " tr e; pr ctx " in\n"; - output_init ctx " " e; + output_init ctx " " e init_moves; ctx.goto_state ctx " " init_num end else begin pr ctx " let __ocaml_lex_result =\n"; - output_init ctx " " e; + output_init ctx " " e init_moves; ctx.goto_state ctx " " init_num; pr ctx " in\n"; output_rules ic ctx " " tr e diff --git a/manual/manual/refman/exten.etex b/manual/manual/refman/exten.etex index ea00430ea4..f483912eaf 100644 --- a/manual/manual/refman/exten.etex +++ b/manual/manual/refman/exten.etex @@ -1776,7 +1776,7 @@ When this form is used together with the infix syntax for attributes, the attributes are considered to apply to the payload: \begin{verbatim} -fun%foo[@bar] x -> x + 1 === [%foo (fun x -> x + 1)[@foo ] ]; +fun%foo[@bar] x -> x + 1 === [%foo (fun x -> x + 1)[@bar ] ]; \end{verbatim} \subsection{Built-in extension nodes} @@ -2363,3 +2363,18 @@ let dict = dict.Dict.%{"one"};; let open Dict in dict.%{"two"};; \end{caml_example} + +\section{Empty variant types\label{s:empty-variants} } +(Introduced in 4.07.0) + +\begin{syntax} +type-representation: + ... + | '=' '|' +\end{syntax} +This extension allows user to define empty variants. +Empty variant type can be eliminated by refutation case of pattern matching. +\begin{caml_example*}{verbatim} +type t = | +let f (x: t) = match x with _ -> . +\end{caml_example*} diff --git a/manual/manual/refman/typedecl.etex b/manual/manual/refman/typedecl.etex index 074a4cae48..9961f18269 100644 --- a/manual/manual/refman/typedecl.etex +++ b/manual/manual/refman/typedecl.etex @@ -31,6 +31,7 @@ type-equation: type-representation: '=' ['|'] constr-decl { '|' constr-decl } | '=' record-decl + | '=' '|' ; type-params: type-param diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml index 68c8d3bceb..c2c2fc1af3 100755 --- a/middle_end/inlining_transforms.ml +++ b/middle_end/inlining_transforms.ml @@ -30,7 +30,7 @@ let which_function_parameters_can_we_specialise ~params ~args assert (List.length params = List.length args); assert (List.length args = List.length args_approxs); List.fold_right2 (fun (var, arg) approx - (worth_specialising_args, spec_args, args, args_decl) -> + (worth_specialising_args, spec_args) -> let spec_args = if Variable.Map.mem var (Lazy.force invariant_params) || Variable.Set.mem var specialised_args @@ -47,9 +47,9 @@ let which_function_parameters_can_we_specialise ~params ~args else worth_specialising_args in - worth_specialising_args, spec_args, arg :: args, args_decl) + worth_specialising_args, spec_args) (List.combine params args) args_approxs - (Variable.Set.empty, Variable.Map.empty, [], []) + (Variable.Set.empty, Variable.Map.empty) (** Fold over all variables bound by the given closure, which is bound to the variable [lhs_of_application], and corresponds to the given @@ -207,7 +207,7 @@ let inline_by_copying_function_declaration ~env ~r in let original_function_decls = function_decls in let specialised_args_set = Variable.Map.keys specialised_args in - let worth_specialising_args, specialisable_args, args, args_decl = + let worth_specialising_args, specialisable_args = which_function_parameters_can_we_specialise ~params:(Parameter.List.vars function_decl.params) ~args ~args_approxs ~invariant_params @@ -528,10 +528,5 @@ let inline_by_copying_function_declaration ~env ~r in Flambda_utils.bind ~bindings:free_vars_for_lets ~body in - (* Now bind the variables that will hold the arguments from the original - application. *) - let expr : Flambda.t = - Flambda_utils.bind ~body:duplicated_application ~bindings:args_decl - in let env = E.activate_freshening (E.set_never_inline env) in - Some (simplify env r expr) + Some (simplify env r duplicated_application) diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml index 965723db50..39ac5c361d 100644 --- a/middle_end/lift_constants.ml +++ b/middle_end/lift_constants.ml @@ -543,6 +543,8 @@ let constant_dependencies ~backend:_ | Project_closure (s, _) -> Symbol.Set.singleton s +module Symbol_SCC = Strongly_connected_components.Make (Symbol) + let program_graph ~backend imported_symbols symbol_to_constant (initialize_symbol_tbl : (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) @@ -584,7 +586,6 @@ let program_graph ~backend imported_symbols symbol_to_constant ) effect_tbl graph_with_initialisation in - let module Symbol_SCC = Strongly_connected_components.Make (Symbol) in let components = Symbol_SCC.connected_components_sorted_from_roots_to_leaf graph @@ -605,7 +606,6 @@ let add_definition_of_symbol constant_definitions assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); (sym, Symbol.Map.find sym constant_definitions) in - let module Symbol_SCC = Strongly_connected_components.Make (Symbol) in match component with | Symbol_SCC.Has_loop l -> let l = List.map symbol_declaration l in diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml index 8fdc045de5..31b66923cc 100644 --- a/middle_end/simplify_boxed_integer_ops.ml +++ b/middle_end/simplify_boxed_integer_ops.ml @@ -73,7 +73,7 @@ end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct | Porbint kind when kind = I.kind -> eval I.logor | Pxorbint kind when kind = I.kind -> eval I.logxor | Pbintcomp (kind, c) when kind = I.kind -> - S.const_comparison_expr expr c n1 n2 + S.const_integer_comparison_expr expr c n1 n2 | _ -> expr, A.value_unknown Other, C.Benefit.zero let simplify_binop_int (p : Lambda.primitive) (kind : I.t A.boxed_int) diff --git a/middle_end/simplify_common.ml b/middle_end/simplify_common.ml index 8044621bbc..3b408be2ac 100644 --- a/middle_end/simplify_common.ml +++ b/middle_end/simplify_common.ml @@ -52,15 +52,32 @@ let const_boxed_int_expr expr t i = new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero else expr, A.value_boxed_int t i, C.Benefit.zero -let const_comparison_expr expr (cmp : Lambda.comparison) x y = +let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = (* Using the [Pervasives] comparison functions here in the compiler coincides with the definitions of such functions in the code compiled by the user, and is thus correct. *) const_bool_expr expr (match cmp with | Ceq -> x = y - | Cneq -> x <> y + | Cne -> x <> y | Clt -> x < y | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) + +let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = + (* Using the [Pervasives] comparison functions here in the compiler + coincides with the definitions of such functions in the code + compiled by the user, and is thus correct. *) + const_bool_expr expr + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) diff --git a/middle_end/simplify_common.mli b/middle_end/simplify_common.mli index 1ab90cce60..ef0c0cf728 100644 --- a/middle_end/simplify_common.mli +++ b/middle_end/simplify_common.mli @@ -58,9 +58,16 @@ val const_boxed_int_expr -> 'a -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t -val const_comparison_expr +val const_integer_comparison_expr : Flambda.named - -> Lambda.comparison + -> Lambda.integer_comparison + -> 'a + -> 'a + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_float_comparison_expr + : Flambda.named + -> Lambda.float_comparison -> 'a -> 'a -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml index 759728d959..75c6a7f3fc 100644 --- a/middle_end/simplify_primitives.ml +++ b/middle_end/simplify_primitives.ml @@ -115,7 +115,7 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int expr, approx, C.Benefit.zero | Pintcomp Ceq when phys_equal approxs -> S.const_bool_expr expr true - | Pintcomp Cneq when phys_equal approxs -> + | Pintcomp Cne when phys_equal approxs -> S.const_bool_expr expr false (* N.B. Having [not (phys_equal approxs)] would not on its own tell us anything about whether the two values concerned are unequal. To judge @@ -140,7 +140,7 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int invalid. *) | Pintcomp Ceq when phys_different approxs -> S.const_bool_expr expr false - | Pintcomp Cneq when phys_different approxs -> + | Pintcomp Cne when phys_different approxs -> S.const_bool_expr expr true (* If two values are structurally different we are certain they can never be shared*) @@ -174,13 +174,13 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) - | Pintcomp cmp -> S.const_comparison_expr expr cmp x y + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y | Pisout -> S.const_bool_expr expr (y > x || y < 0) | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_char x; Value_char y] -> begin match p with - | Pintcomp cmp -> S.const_comparison_expr expr cmp x y + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_constptr x] -> @@ -220,7 +220,7 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int | Psubfloat -> S.const_float_expr expr (n1 -. n2) | Pmulfloat -> S.const_float_expr expr (n1 *. n2) | Pdivfloat -> S.const_float_expr expr (n1 /. n2) - | Pfloatcomp c -> S.const_comparison_expr expr c n1 n2 + | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [A.Value_boxed_int(A.Nativeint, n)] -> diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index e8ede81346..65802500ff 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -97,8 +97,8 @@ endif ############# INCLUDES_DEP=\ - -I $(ROOTDIR)/parsing \ -I $(ROOTDIR)/utils \ + -I $(ROOTDIR)/parsing \ -I $(ROOTDIR)/typing \ -I $(ROOTDIR)/driver \ -I $(ROOTDIR)/bytecomp \ diff --git a/ocamldoc/Makefile.unprefix b/ocamldoc/Makefile.unprefix index 1e14039562..0e8ec04f85 100644 --- a/ocamldoc/Makefile.unprefix +++ b/ocamldoc/Makefile.unprefix @@ -106,4 +106,4 @@ $(STDLIB_UNPREFIXED)/pervasives.mli: $(SRC)/stdlib/stdlib.mli $(STDLIB_UNPREFIXE # Build cmis file inside the STDLIB_UNPREFIXED directories $(STDLIB_CMIS): $(STDLIB_DEPS) - cd $(STDLIB_UNPREFIXED); make $(notdir $(STDLIB_CMIS)) + cd $(STDLIB_UNPREFIXED); $(MAKE) $(notdir $(STDLIB_CMIS)) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index b1ea42d6c4..cdaf1993c1 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -241,6 +241,8 @@ module Options = Main_args.Make_ocamldoc_options(struct let _where = Compenv.print_standard_library let _verbose = set Clflags.verbose let _nopervasives = set Clflags.nopervasives + let _dno_unique_ids = unset Clflags.unique_ids + let _dunique_ids = set Clflags.unique_ids let _dsource = set Clflags.dump_source let _dparsetree = set Clflags.dump_parsetree let _dtypedtree = set Clflags.dump_typedtree diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 123cc7b537..93c279c1c1 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1232,7 +1232,7 @@ class html = self#print_header b (self#inner_title in_title); bs b"<body>\n"; self#html_of_code ~with_pre b code; - bs b "</body></html>"; + bs b "</body></html>\n"; Buffer.output_buffer chanout b; close_out chanout with @@ -1780,12 +1780,14 @@ class html = | Some _ -> "</pre>" ); bs b "<table class=\"typetable\">\n"; - let print_one constr = + let print_bar () = bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; bs b "<code>"; bs b (self#keyword "|"); bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n"; - bs b "<code>"; + bs b "<code>" in + let print_one constr = + print_bar (); bp b "<span id=\"%s\">%s</span>" (Naming.const_target t constr) (self#constructor constr.vc_name); @@ -1823,7 +1825,8 @@ class html = ); bs b "\n</tr>" in - print_concat b "\n" print_one l; + if l = [] then print_bar () else + print_concat b "\n" print_one l; bs b "</table>\n" | Type_record l -> @@ -2425,7 +2428,7 @@ class html = bs b "<table>\n"; List.iter f_group groups ; bs b "</table>\n" ; - bs b "</body>\n</html>"; + bs b "</body>\n</html>\n"; Buffer.output_buffer chanout b; close_out chanout with @@ -2479,7 +2482,7 @@ class html = (* the various elements *) List.iter (self#html_of_class_element b) (Class.class_elements ~trans:false cl); - bs b "</body></html>"; + bs b "</body></html>\n"; Buffer.output_buffer chanout b; close_out chanout; @@ -2525,7 +2528,7 @@ class html = (* the various elements *) List.iter (self#html_of_class_element b) (Class.class_type_elements ~trans: false clt); - bs b "</body></html>"; + bs b "</body></html>\n"; Buffer.output_buffer chanout b; close_out chanout; @@ -2577,7 +2580,7 @@ class html = (self#html_of_module_element b mt.mt_name) (Module.module_type_elements mt); - bs b "</body></html>"; + bs b "</body></html>\n"; Buffer.output_buffer chanout b; close_out chanout; @@ -2663,7 +2666,7 @@ class html = (self#html_of_module_element b modu.m_name) (Module.module_elements modu); - bs b "</body></html>"; + bs b "</body></html>\n"; Buffer.output_buffer chanout b; close_out chanout; @@ -2727,7 +2730,7 @@ class html = (List.map (fun m -> m.m_name) module_list); | Some _ -> self#html_of_info ~indent: false b info ); - bs b "</body>\n</html>"; + bs b "</body>\n</html>\n"; Buffer.output_buffer chanout b; close_out chanout with diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 1c6075e8a4..76f6d7310d 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -641,13 +641,14 @@ class latex = | None | Some (Other _) -> [] end | Type_variant l -> + if l = [] then (p fmt2 "@[<h 6> |"; [CodePre (flush2())]) else ( let constructors = List.map (fun {vc_name; vc_args; vc_ret; vc_text} -> p fmt2 "@[<h 6> | %s" vc_name ; let l = self#latex_of_cstr_args f mod_name (vc_args,vc_ret) in l @ (self#entry_comment f vc_text) ) l in - List.flatten constructors + List.flatten constructors) | Type_record l -> self#latex_of_record f mod_name l | Type_open -> diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index e729fe3593..0ce40dcc99 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -83,7 +83,10 @@ let simpl_class_type t = | Types.Cty_signature cs -> (* we delete vals and methods in order to not print them when displaying the type *) - let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in + let tnil = + { Types.desc = Types.Tnil ; Types.level = 0; Types.scope = None + ; Types.id = 0 } + in Types.Cty_signature { Types.csig_self = { cs.Types.csig_self with Types.desc = Types.Tobject (tnil, ref None) }; csig_vars = Types.Vars.empty ; diff --git a/ocamldoc/stdlib_non_prefixed/.depend b/ocamldoc/stdlib_non_prefixed/.depend index a62ae23a1a..e69de29bb2 100644 --- a/ocamldoc/stdlib_non_prefixed/.depend +++ b/ocamldoc/stdlib_non_prefixed/.depend @@ -1,184 +0,0 @@ -annot.cmi : location.cmi -arg.cmi : -arg_helper.cmi : map.cmi -array.cmi : -arrayLabels.cmi : -ast_helper.cmi : parsetree.cmi longident.cmi location.cmi docstrings.cmi \ - asttypes.cmi -ast_invariants.cmi : parsetree.cmi -ast_iterator.cmi : parsetree.cmi location.cmi -ast_mapper.cmi : parsetree.cmi location.cmi -asttypes.cmi : location.cmi -atomic.cmi : -attr_helper.cmi : parsetree.cmi location.cmi format.cmi asttypes.cmi -bigarray.cmi : unix.cmi complex.cmi camlinternalBigarray.cmi -btype.cmi : types.cmi set.cmi path.cmi map.cmi hashtbl.cmi format.cmi \ - asttypes.cmi -buffer.cmi : uchar.cmi -builtin_attributes.cmi : parsetree.cmi location.cmi -bytegen.cmi : lambda.cmi instruct.cmi -bytelibrarian.cmi : format.cmi -bytelink.cmi : symtable.cmi format.cmi digest.cmi cmo_format.cmi -bytepackager.cmi : ident.cmi format.cmi env.cmi -bytes.cmi : -bytesLabels.cmi : -bytesections.cmi : -callback.cmi : -camlinternalBigarray.cmi : complex.cmi -camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi -camlinternalFormatBasics.cmi : -camlinternalLazy.cmi : -camlinternalMod.cmi : obj.cmi -camlinternalOO.cmi : obj.cmi -ccomp.cmi : -char.cmi : -clflags.cmi : profile.cmi misc.cmi arg.cmi -cmi_format.cmi : types.cmi format.cmi digest.cmi -cmo_format.cmi : tbl.cmi lambda.cmi ident.cmi digest.cmi -cmt_format.cmi : types.cmi typedtree.cmi location.cmi env.cmi digest.cmi \ - cmi_format.cmi -complex.cmi : -condition.cmi : mutex.cmi -config.cmi : -consistbl.cmi : digest.cmi -ctype.cmi : types.cmi path.cmi longident.cmi ident.cmi env.cmi asttypes.cmi -datarepr.cmi : types.cmi path.cmi ident.cmi -depend.cmi : set.cmi parsetree.cmi map.cmi longident.cmi -digest.cmi : -dll.cmi : -docstrings.cmi : parsetree.cmi location.cmi lexing.cmi lazy.cmi -domain.cmi : -domainstate.cmi : -dynlink.cmi : digest.cmi -emitcode.cmi : misc.cmi instruct.cmi ident.cmi cmo_format.cmi -env.cmi : warnings.cmi types.cmi subst.cmi path.cmi misc.cmi map.cmi \ - longident.cmi location.cmi ident.cmi format.cmi digest.cmi consistbl.cmi \ - cmi_format.cmi asttypes.cmi -envaux.cmi : subst.cmi path.cmi format.cmi env.cmi -ephemeron.cmi : hashtbl.cmi -event.cmi : -filename.cmi : -format.cmi : pervasives.cmi buffer.cmi -gc.cmi : -genlex.cmi : stream.cmi -graphics.cmi : -graphicsX11.cmi : -hashtbl.cmi : -ident.cmi : identifiable.cmi -identifiable.cmi : set.cmi map.cmi hashtbl.cmi format.cmi -includeclass.cmi : types.cmi location.cmi format.cmi env.cmi ctype.cmi -includecore.cmi : types.cmi typedtree.cmi location.cmi ident.cmi format.cmi \ - env.cmi -includemod.cmi : types.cmi typedtree.cmi path.cmi location.cmi \ - includecore.cmi ident.cmi format.cmi env.cmi ctype.cmi -instruct.cmi : types.cmi subst.cmi location.cmi lambda.cmi ident.cmi env.cmi -int32.cmi : -int64.cmi : -lambda.cmi : types.cmi primitive.cmi path.cmi location.cmi ident.cmi env.cmi \ - asttypes.cmi -lazy.cmi : camlinternalLazy.cmi -lexer.cmi : parser.cmi location.cmi lexing.cmi format.cmi -lexing.cmi : -list.cmi : -listLabels.cmi : -location.cmi : warnings.cmi lexing.cmi format.cmi -longident.cmi : -map.cmi : -marshal.cmi : -matching.cmi : typedtree.cmi location.cmi lambda.cmi ident.cmi -meta.cmi : obj.cmi instruct.cmi -misc.cmi : set.cmi map.cmi hashtbl.cmi format.cmi -moreLabels.cmi : set.cmi map.cmi hashtbl.cmi -mtype.cmi : types.cmi path.cmi ident.cmi env.cmi -mutex.cmi : -nativeint.cmi : -numbers.cmi : set.cmi int64.cmi identifiable.cmi -obj.cmi : int32.cmi -oo.cmi : camlinternalOO.cmi -oprint.cmi : outcometree.cmi format.cmi -outcometree.cmi : format.cmi asttypes.cmi -parmatch.cmi : types.cmi typedtree.cmi parsetree.cmi location.cmi \ - hashtbl.cmi env.cmi asttypes.cmi -parse.cmi : parsetree.cmi lexing.cmi -parser.cmi : parsetree.cmi location.cmi lexing.cmi docstrings.cmi -parsetree.cmi : longident.cmi location.cmi asttypes.cmi -parsing.cmi : obj.cmi lexing.cmi -path.cmi : ident.cmi -pervasives.cmi : camlinternalFormatBasics.cmi -pparse.cmi : parsetree.cmi misc.cmi lexing.cmi format.cmi -pprintast.cmi : parsetree.cmi format.cmi -predef.cmi : types.cmi path.cmi ident.cmi -primitive.cmi : parsetree.cmi outcometree.cmi location.cmi -printast.cmi : parsetree.cmi format.cmi -printexc.cmi : -printf.cmi : buffer.cmi -printinstr.cmi : instruct.cmi format.cmi -printlambda.cmi : lambda.cmi format.cmi -printpat.cmi : typedtree.cmi format.cmi asttypes.cmi -printtyp.cmi : types.cmi path.cmi outcometree.cmi longident.cmi ident.cmi \ - format.cmi env.cmi asttypes.cmi -printtyped.cmi : typedtree.cmi format.cmi -profile.cmi : format.cmi -queue.cmi : -random.cmi : nativeint.cmi int64.cmi int32.cmi -runtimedef.cmi : -scanf.cmi : pervasives.cmi -semantics_of_primitives.cmi : lambda.cmi -set.cmi : -simplif.cmi : misc.cmi location.cmi lambda.cmi ident.cmi -sort.cmi : -spacetime.cmi : -stack.cmi : -stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \ - arrayLabels.cmi -str.cmi : -stream.cmi : -string.cmi : -stringLabels.cmi : -strongly_connected_components.cmi : identifiable.cmi -stypes.cmi : typedtree.cmi location.cmi annot.cmi -subst.cmi : types.cmi path.cmi ident.cmi -switch.cmi : location.cmi -symtable.cmi : obj.cmi misc.cmi lambda.cmi ident.cmi format.cmi digest.cmi \ - cmo_format.cmi -syntaxerr.cmi : location.cmi format.cmi -sys.cmi : -targetint.cmi : -tast_mapper.cmi : typedtree.cmi env.cmi asttypes.cmi -tbl.cmi : format.cmi -terminfo.cmi : -thread.cmi : unix.cmi -threadUnix.cmi : unix.cmi -translattribute.cmi : typedtree.cmi parsetree.cmi location.cmi lambda.cmi -translclass.cmi : typedtree.cmi location.cmi lambda.cmi ident.cmi format.cmi \ - asttypes.cmi -translcore.cmi : types.cmi typedtree.cmi primitive.cmi path.cmi location.cmi \ - lambda.cmi ident.cmi hashtbl.cmi format.cmi env.cmi asttypes.cmi -translmod.cmi : typedtree.cmi primitive.cmi location.cmi lambda.cmi \ - ident.cmi format.cmi -translobj.cmi : lambda.cmi ident.cmi env.cmi -typeclass.cmi : types.cmi typedtree.cmi parsetree.cmi longident.cmi \ - location.cmi ident.cmi format.cmi env.cmi ctype.cmi asttypes.cmi -typecore.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \ - location.cmi ident.cmi format.cmi env.cmi asttypes.cmi annot.cmi -typedecl.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \ - location.cmi includecore.cmi ident.cmi format.cmi env.cmi asttypes.cmi -typedtree.cmi : types.cmi primitive.cmi path.cmi parsetree.cmi longident.cmi \ - location.cmi ident.cmi env.cmi asttypes.cmi -typedtreeIter.cmi : typedtree.cmi asttypes.cmi -typedtreeMap.cmi : typedtree.cmi -typemod.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi misc.cmi \ - longident.cmi location.cmi includemod.cmi ident.cmi format.cmi env.cmi \ - cmi_format.cmi asttypes.cmi -typeopt.cmi : types.cmi typedtree.cmi path.cmi lambda.cmi env.cmi -types.cmi : set.cmi primitive.cmi path.cmi parsetree.cmi map.cmi \ - longident.cmi location.cmi ident.cmi asttypes.cmi -typetexp.cmi : types.cmi typedtree.cmi path.cmi parsetree.cmi longident.cmi \ - location.cmi includemod.cmi format.cmi env.cmi asttypes.cmi -uchar.cmi : -unix.cmi : camlinternalBigarray.cmi -unixLabels.cmi : unix.cmi camlinternalBigarray.cmi -untypeast.cmi : typedtree.cmi path.cmi parsetree.cmi longident.cmi \ - location.cmi asttypes.cmi -warnings.cmi : lexing.cmi lazy.cmi -weak.cmi : hashtbl.cmi diff --git a/ocamltest/.depend b/ocamltest/.depend index 4cafacb50c..f4851ef19d 100644 --- a/ocamltest/.depend +++ b/ocamltest/.depend @@ -44,12 +44,14 @@ main.cmx : tsl_semantics.cmx tsl_parser.cmx tsl_lexer.cmx tests.cmx \ builtin_variables.cmx actions_helpers.cmx actions.cmx main.cmi main.cmi : ocaml_actions.cmo : result.cmi ocamltest_stdlib.cmi ocamltest_config.cmi \ - ocaml_variables.cmi ocaml_flags.cmi ocaml_filetypes.cmi ocaml_files.cmi \ + ocaml_variables.cmi ocaml_toplevels.cmi ocaml_tools.cmi \ + ocaml_modifiers.cmi ocaml_flags.cmi ocaml_filetypes.cmi ocaml_files.cmi \ ocaml_directories.cmi ocaml_compilers.cmi ocaml_commands.cmi \ ocaml_backends.cmi filecompare.cmi environments.cmi builtin_variables.cmi \ actions_helpers.cmi actions.cmi ocaml_actions.cmi ocaml_actions.cmx : result.cmx ocamltest_stdlib.cmx ocamltest_config.cmx \ - ocaml_variables.cmx ocaml_flags.cmx ocaml_filetypes.cmx ocaml_files.cmx \ + ocaml_variables.cmx ocaml_toplevels.cmx ocaml_tools.cmx \ + ocaml_modifiers.cmx ocaml_flags.cmx ocaml_filetypes.cmx ocaml_files.cmx \ ocaml_directories.cmx ocaml_compilers.cmx ocaml_commands.cmx \ ocaml_backends.cmx filecompare.cmx environments.cmx builtin_variables.cmx \ actions_helpers.cmx actions.cmx ocaml_actions.cmi @@ -61,42 +63,53 @@ ocaml_commands.cmo : ocaml_files.cmi ocaml_commands.cmi ocaml_commands.cmx : ocaml_files.cmx ocaml_commands.cmi ocaml_commands.cmi : ocaml_compilers.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \ - ocaml_files.cmi ocaml_commands.cmi ocaml_backends.cmi environments.cmi \ - ocaml_compilers.cmi + ocaml_tools.cmi ocaml_files.cmi ocaml_commands.cmi ocaml_backends.cmi \ + builtin_variables.cmi ocaml_compilers.cmi ocaml_compilers.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \ - ocaml_files.cmx ocaml_commands.cmx ocaml_backends.cmx environments.cmx \ - ocaml_compilers.cmi -ocaml_compilers.cmi : variables.cmi ocaml_backends.cmi environments.cmi + ocaml_tools.cmx ocaml_files.cmx ocaml_commands.cmx ocaml_backends.cmx \ + builtin_variables.cmx ocaml_compilers.cmi +ocaml_compilers.cmi : variables.cmi ocaml_tools.cmi ocaml_backends.cmi ocaml_directories.cmo : ocamltest_stdlib.cmi ocamltest_config.cmi \ - ocaml_directories.cmi + ocaml_backends.cmi ocaml_directories.cmi ocaml_directories.cmx : ocamltest_stdlib.cmx ocamltest_config.cmx \ - ocaml_directories.cmi -ocaml_directories.cmi : + ocaml_backends.cmx ocaml_directories.cmi +ocaml_directories.cmi : ocaml_backends.cmi ocaml_files.cmo : ocamltest_stdlib.cmi ocaml_files.cmi ocaml_files.cmx : ocamltest_stdlib.cmx ocaml_files.cmi ocaml_files.cmi : ocaml_filetypes.cmo : ocaml_backends.cmi ocaml_filetypes.cmi ocaml_filetypes.cmx : ocaml_backends.cmx ocaml_filetypes.cmi ocaml_filetypes.cmi : ocaml_backends.cmi -ocaml_flags.cmo : ocamltest_stdlib.cmi ocaml_files.cmi ocaml_directories.cmi \ - ocaml_backends.cmi ocaml_flags.cmi -ocaml_flags.cmx : ocamltest_stdlib.cmx ocaml_files.cmx ocaml_directories.cmx \ - ocaml_backends.cmx ocaml_flags.cmi +ocaml_flags.cmo : ocaml_files.cmi ocaml_directories.cmi ocaml_backends.cmi \ + ocaml_flags.cmi +ocaml_flags.cmx : ocaml_files.cmx ocaml_directories.cmx ocaml_backends.cmx \ + ocaml_flags.cmi ocaml_flags.cmi : ocaml_backends.cmi ocaml_modifiers.cmo : ocamltest_stdlib.cmi ocamltest_config.cmi \ - ocaml_variables.cmi environments.cmi builtin_variables.cmi \ - ocaml_modifiers.cmi + ocaml_variables.cmi environments.cmi ocaml_modifiers.cmi ocaml_modifiers.cmx : ocamltest_stdlib.cmx ocamltest_config.cmx \ - ocaml_variables.cmx environments.cmx builtin_variables.cmx \ - ocaml_modifiers.cmi + ocaml_variables.cmx environments.cmx ocaml_modifiers.cmi ocaml_modifiers.cmi : environments.cmi ocaml_tests.cmo : tests.cmi ocamltest_config.cmi ocaml_actions.cmi \ builtin_actions.cmi ocaml_tests.cmi ocaml_tests.cmx : tests.cmx ocamltest_config.cmx ocaml_actions.cmx \ builtin_actions.cmx ocaml_tests.cmi ocaml_tests.cmi : tests.cmi -ocaml_variables.cmo : variables.cmi ocaml_variables.cmi -ocaml_variables.cmx : variables.cmx ocaml_variables.cmi +ocaml_tools.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \ + ocaml_files.cmi environments.cmi actions_helpers.cmi ocaml_tools.cmi +ocaml_tools.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \ + ocaml_files.cmx environments.cmx actions_helpers.cmx ocaml_tools.cmi +ocaml_tools.cmi : variables.cmi environments.cmi +ocaml_toplevels.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi \ + ocaml_tools.cmi ocaml_files.cmi ocaml_compilers.cmi ocaml_commands.cmi \ + ocaml_backends.cmi ocaml_toplevels.cmi +ocaml_toplevels.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmx \ + ocaml_tools.cmx ocaml_files.cmx ocaml_compilers.cmx ocaml_commands.cmx \ + ocaml_backends.cmx ocaml_toplevels.cmi +ocaml_toplevels.cmi : variables.cmi ocaml_tools.cmi ocaml_compilers.cmi \ + ocaml_backends.cmi +ocaml_variables.cmo : variables.cmi ocamltest_stdlib.cmi ocaml_variables.cmi +ocaml_variables.cmx : variables.cmx ocamltest_stdlib.cmx ocaml_variables.cmi ocaml_variables.cmi : variables.cmi ocamltest_config.cmo : ocamltest_config.cmi ocamltest_config.cmx : ocamltest_config.cmi diff --git a/ocamltest/Makefile b/ocamltest/Makefile index 25abcd9730..f0d901f70c 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -69,7 +69,9 @@ ocaml_plugin := \ ocaml_files.mli ocaml_files.ml \ ocaml_flags.mli ocaml_flags.ml \ ocaml_commands.mli ocaml_commands.ml \ + ocaml_tools.mli ocaml_tools.ml \ ocaml_compilers.mli ocaml_compilers.ml \ + ocaml_toplevels.mli ocaml_toplevels.ml \ ocaml_actions.mli ocaml_actions.ml \ ocaml_tests.mli ocaml_tests.ml @@ -173,9 +175,16 @@ ocamltest.opt$(EXE): $(native_modules) %.$(O): %.c $(CC) $(CFLAGS) $(CPPFLAGS) $(BYTECCCOMPOPTS) -c $< +ifeq "$(WITH_OCAMLDOC)" "ocamldoc" +WITH_OCAMLDOC := true +else +WITH_OCAMLDOC := false +endif + + ocamltest_config.ml: ocamltest_config.ml.in sed \ - -e 's|@@AFL_SUPPORT@@|$(AFL_INSTRUMENT)|' \ + -e 's|@@AFL_INSTRUMENT@@|$(AFL_INSTRUMENT)|' \ -e 's|@@ARCH@@|$(ARCH)|' \ -e 's|@@SHARED_LIBRARIES@@|$(SUPPORTS_SHARED_LIBRARIES)|' \ -e 's|@@UNIX@@|$(unix)|' \ @@ -188,6 +197,7 @@ ocamltest_config.ml: ocamltest_config.ml.in -e 's|@@SPACETIME@@|$(WITH_SPACETIME)|' \ -e 's|@@FORCE_SAFE_STRING@@|$(FORCE_SAFE_STRING)|' \ -e 's|@@FLAT_FLOAT_ARRAY@@|$(FLAT_FLOAT_ARRAY)|' \ + -e 's|@@OCAMLDOC@@|$(WITH_OCAMLDOC)|' \ $< > $@ .PHONY: clean diff --git a/ocamltest/actions.ml b/ocamltest/actions.ml index b2c01a5bd7..cce0571ecb 100644 --- a/ocamltest/actions.ml +++ b/ocamltest/actions.ml @@ -27,6 +27,8 @@ let action_name a = a.name let make n c = { name = n; body = c; hook = None } +let update action code = { action with body = code } + let compare a1 a2 = String.compare a1.name a2.name let (actions : (string, t) Hashtbl.t) = Hashtbl.create 10 diff --git a/ocamltest/actions.mli b/ocamltest/actions.mli index 63714c3cdd..941fc477de 100644 --- a/ocamltest/actions.mli +++ b/ocamltest/actions.mli @@ -21,6 +21,8 @@ type t val action_name : t -> string +val update : t -> code -> t + val make : string -> code -> t val compare : t -> t -> int diff --git a/ocamltest/actions_helpers.ml b/ocamltest/actions_helpers.ml index dd3988ea71..86db66dcdc 100644 --- a/ocamltest/actions_helpers.ml +++ b/ocamltest/actions_helpers.ml @@ -46,6 +46,11 @@ let test_build_directory_prefix env = let words_of_variable env variable = String.words (Environments.safe_lookup variable env) +let exit_status_of_variable env variable = + try int_of_string + (Environments.safe_lookup variable env) + with _ -> 0 + let files env = words_of_variable env Builtin_variables.files let setup_symlinks test_source_directory build_directory files = @@ -119,21 +124,6 @@ let run_cmd Run_command.log = log } -let caml_ld_library_path = "CAML_LD_LIBRARY_PATH" - -let string_of_binding variable value = - if variable=Builtin_variables.ld_library_path then begin - let current_value = - try Sys.getenv caml_ld_library_path with Not_found -> "" in - let local_value = - (String.concat Filename.path_sep (String.words value)) in - let new_value = - if local_value="" then current_value else - if current_value="" then local_value else - String.concat Filename.path_sep [local_value; current_value] in - Printf.sprintf "%s=%s" caml_ld_library_path new_value - end else Environments.string_of_binding variable value - let run (log_message : string) (redirect_output : bool) @@ -168,19 +158,26 @@ let run Environments.add_bindings bindings env end else env in let systemenv = - Environments.to_system_env ~f:string_of_binding execution_env in - match run_cmd ~environment:systemenv log execution_env commandline with - | 0 -> - let newenv = - if redirect_output - then Environments.add Builtin_variables.output output env - else env in - (Result.pass, newenv) - | _ as exitcode -> - let reason = mkreason what (String.concat " " commandline) exitcode in - if exitcode = 125 && can_skip - then (Result.skip_with_reason reason, execution_env) - else (Result.fail_with_reason reason, execution_env) + Environments.to_system_env execution_env in + let expected_exit_status = + exit_status_of_variable env Builtin_variables.exit_status + in + let exit_status = + run_cmd ~environment:systemenv log execution_env commandline + in + if exit_status=expected_exit_status + then begin + let newenv = + if redirect_output + then Environments.add Builtin_variables.output output env + else env in + (Result.pass, newenv) + end else begin + let reason = mkreason what (String.concat " " commandline) exit_status in + if exit_status = 125 && can_skip + then (Result.skip_with_reason reason, execution_env) + else (Result.fail_with_reason reason, execution_env) + end let run_program = run @@ -221,7 +218,7 @@ let run_hook hook_name log input_env = let hookenv = Environments.add Builtin_variables.ocamltest_response response_file input_env in let systemenv = - Environments.to_system_env ~f:string_of_binding hookenv in + Environments.to_system_env hookenv in let open Run_command in let settings = { progname = "sh"; @@ -246,7 +243,13 @@ let run_hook hook_name log input_env = then (Result.skip_with_reason reason, hookenv) else (Result.fail_with_reason reason, hookenv) -let check_output kind_of_output output_variable reference_variable log env = +let check_output kind_of_output output_variable reference_variable log + env = + let to_int = function None -> 0 | Some s -> int_of_string s in + let skip_lines = + to_int (Environments.lookup Builtin_variables.skip_header_lines env) in + let skip_bytes = + to_int (Environments.lookup Builtin_variables.skip_header_bytes env) in let reference_filename = Environments.safe_lookup reference_variable env in let output_filename = Environments.safe_lookup output_variable env in Printf.fprintf log "Comparing %s output %s to reference %s\n%!" @@ -257,7 +260,9 @@ let check_output kind_of_output output_variable reference_variable log env = Filecompare.reference_filename = reference_filename; Filecompare.output_filename = output_filename } in - match Filecompare.check_file files with + let tool = + Filecompare.(make_cmp_tool ~ignore:{lines=skip_lines;bytes=skip_bytes}) in + match Filecompare.check_file ~tool files with | Filecompare.Same -> (Result.pass, env) | Filecompare.Different -> let diff = Filecompare.diff files in diff --git a/ocamltest/actions_helpers.mli b/ocamltest/actions_helpers.mli index c7694ab9c7..5e7d6904ba 100644 --- a/ocamltest/actions_helpers.mli +++ b/ocamltest/actions_helpers.mli @@ -29,6 +29,8 @@ val test_source_directory : Environments.t -> string val words_of_variable : Environments.t -> Variables.t -> string list +val exit_status_of_variable : Environments.t -> Variables.t -> int + val files : Environments.t -> string list val setup_symlinks : string -> string -> string list -> unit diff --git a/ocamltest/builtin_actions.ml b/ocamltest/builtin_actions.ml index e0ebf6cab3..97480bca6a 100644 --- a/ocamltest/builtin_actions.ml +++ b/ocamltest/builtin_actions.ml @@ -56,7 +56,7 @@ let libwin32unix = make let windows_OS = "Windows_NT" -let get_OS () = try Sys.getenv "OS" with Not_found -> "" +let get_OS () = Sys.safe_getenv "OS" let windows = make "windows" @@ -84,6 +84,18 @@ let not_bsd = make "not on a BSD system" "on a BSD system") +let arch32 = make + "arch32" + (Actions_helpers.pass_or_skip (Sys.word_size = 32) + "32-bit architecture" + "non-32-bit architecture") + +let arch64 = make + "arch64" + (Actions_helpers.pass_or_skip (Sys.word_size = 64) + "64-bit architecture" + "non-64-bit architecture") + let setup_build_env = make "setup-build-env" (Actions_helpers.setup_build_env true []) @@ -129,6 +141,8 @@ let _ = not_windows; bsd; not_bsd; + arch32; + arch64; setup_build_env; run; script; diff --git a/ocamltest/builtin_actions.mli b/ocamltest/builtin_actions.mli index 4f84ef131c..9f076dbc4e 100644 --- a/ocamltest/builtin_actions.mli +++ b/ocamltest/builtin_actions.mli @@ -30,6 +30,9 @@ val not_windows : Actions.t val bsd : Actions.t val not_bsd : Actions.t +val arch32 : Actions.t +val arch64 : Actions.t + val setup_build_env : Actions.t val setup_simple_build_env : Actions.t diff --git a/ocamltest/builtin_variables.ml b/ocamltest/builtin_variables.ml index b4684b1361..2fdcb680fb 100644 --- a/ocamltest/builtin_variables.ml +++ b/ocamltest/builtin_variables.ml @@ -27,12 +27,12 @@ open Variables (* Should not be necessary with a ppx *) let arguments = make ("arguments", "Arguments passed to executed programs and scripts") +let exit_status = make ("exit_status", + "Expected program exit status") + let files = make ("files", "Files used by the tests") -let ld_library_path = make ("ld_library_path", - "List of paths to lookup for loading dynamic libraries") - let ocamltest_response = make ("ocamltest_response", "File used by hooks to send back information.") @@ -53,6 +53,16 @@ let promote = make ("promote", let reference = make ("reference", "Path of file to which program output should be compared") +let skip_header_lines = + make ( "skip_header_lines", + "The number of lines to skip when comparing program output \ + with the reference file") + +let skip_header_bytes = + make ( "skip_header_bytes", + "The number of bytes to skip when comparing program output \ + with the reference file") + let script = make ("script", "External script to run") @@ -86,12 +96,15 @@ let test_fail = make ("TEST_FAIL", let _ = List.iter register_variable [ arguments; + exit_status; files; ocamltest_response; ocamltest_log; output; program; program2; reference; + skip_header_lines; + skip_header_bytes; script; stdin; stdout; diff --git a/ocamltest/builtin_variables.mli b/ocamltest/builtin_variables.mli index 19f6e5b6f4..6bac73f6d4 100644 --- a/ocamltest/builtin_variables.mli +++ b/ocamltest/builtin_variables.mli @@ -19,9 +19,9 @@ val arguments : Variables.t -val files : Variables.t +val exit_status : Variables.t -val ld_library_path : Variables.t +val files : Variables.t val ocamltest_response : Variables.t @@ -36,6 +36,9 @@ val promote : Variables.t val reference : Variables.t +val skip_header_lines : Variables.t +val skip_header_bytes : Variables.t + val script : Variables.t val stdin : Variables.t diff --git a/ocamltest/environments.ml b/ocamltest/environments.ml index e39b154386..202b478d91 100644 --- a/ocamltest/environments.ml +++ b/ocamltest/environments.ml @@ -27,21 +27,7 @@ let to_bindings env = let f variable value lst = (variable, value) :: lst in VariableMap.fold f env [] -let string_of_binding variable value = - let name = (Variables.name_of_variable variable) in - Printf.sprintf "%s=%s" name value - -let to_system_env ?(f= string_of_binding) env = - let system_env = Array.make (VariableMap.cardinal env) "" in - let i = ref 0 in - let store variable value = - system_env.(!i) <- f variable value; - incr i in - VariableMap.iter store env; - system_env - let expand env value = - let bindings = to_bindings env in let f (variable, value) = ((Variables.name_of_variable variable), value) in let simple_bindings = List.map f bindings in @@ -49,9 +35,23 @@ let expand env value = let b = Buffer.create 100 in try Buffer.add_substitute b subst value; Buffer.contents b with _ -> value +let to_system_env env = + let system_env = Array.make (VariableMap.cardinal env) "" in + let i = ref 0 in + let store variable value = + system_env.(!i) <- + Variables.string_of_binding variable (expand env value); + incr i in + VariableMap.iter store env; + system_env + let lookup variable env = try Some (expand env (VariableMap.find variable env)) with Not_found -> None +let lookup_nonempty variable env = match lookup variable env with + | None -> None + | Some x as t -> if String.words x = [] then None else t + let lookup_as_bool variable env = match lookup variable env with | None -> None @@ -67,6 +67,9 @@ let is_variable_defined variable env = let add variable value env = VariableMap.add variable value env +let add_if_undefined variable value env = + if VariableMap.mem variable env then env else add variable value env + let append variable appened_value environment = let previous_value = safe_lookup variable environment in let new_value = previous_value ^ appened_value in diff --git a/ocamltest/environments.mli b/ocamltest/environments.mli index 56c7fcd1e7..94d794bb97 100644 --- a/ocamltest/environments.mli +++ b/ocamltest/environments.mli @@ -21,11 +21,10 @@ val empty : t val from_bindings : (Variables.t * string) list -> t val to_bindings : t -> (Variables.t * string) list -val string_of_binding : Variables.t -> string -> string -val to_system_env : - ?f : (Variables.t -> string -> string) -> t -> string array +val to_system_env : t -> string array val lookup : Variables.t -> t -> string option +val lookup_nonempty : Variables.t -> t -> string option val safe_lookup : Variables.t -> t -> string val is_variable_defined : Variables.t -> t -> bool @@ -35,6 +34,7 @@ val lookup_as_bool : Variables.t -> t -> bool option [None] if not set. *) val add : Variables.t -> string -> t -> t +val add_if_undefined : Variables.t -> string -> t -> t val add_bindings : (Variables.t * string) list -> t -> t val append : Variables.t -> string -> t -> t diff --git a/ocamltest/filecompare.ml b/ocamltest/filecompare.ml index 38cc8a4d9e..9e88d31e93 100644 --- a/ocamltest/filecompare.ml +++ b/ocamltest/filecompare.ml @@ -23,21 +23,22 @@ type result = | Unexpected_output | Error of string * int +type ignore = {bytes: int; lines: int} type tool = | External of { tool_name : string; tool_flags : string; result_of_exitcode : string -> int -> result } - | Internal of int + | Internal of ignore let cmp_result_of_exitcode commandline = function | 0 -> Same | 1 -> Different | exit_code -> (Error (commandline, exit_code)) -let make_cmp_tool bytes_to_ignore = - Internal bytes_to_ignore +let make_cmp_tool ~ignore = + Internal ignore let make_comparison_tool ?(result_of_exitcode = cmp_result_of_exitcode) name flags = @@ -48,7 +49,7 @@ let make_comparison_tool ?(result_of_exitcode = cmp_result_of_exitcode) result_of_exitcode } -let default_comparison_tool = make_cmp_tool 0 +let default_comparison_tool = make_cmp_tool ~ignore:{bytes=0;lines=0} type filetype = Binary | Text @@ -58,14 +59,20 @@ type files = { output_filename : string; } -let read_text_file fn = +let read_text_file lines_to_drop fn = let ic = open_in_bin fn in let drop_cr s = let l = String.length s in if l > 0 && s.[l - 1] = '\r' then String.sub s 0 (l - 1) else raise Exit in - let rec loop acc = + let rec drop k = + if k = 0 then + loop [] + else + let stop = try ignore (input_line ic); false with End_of_file -> true in + if stop then [] else drop (k-1) + and loop acc = match input_line ic with | s -> loop (s :: acc) | exception End_of_file -> @@ -73,10 +80,10 @@ let read_text_file fn = try List.rev_map drop_cr acc with Exit -> List.rev acc in - loop [] + drop lines_to_drop -let compare_text_files file1 file2 = - if read_text_file file1 = read_text_file file2 then +let compare_text_files dropped_lines file1 file2 = + if read_text_file 0 file1 = read_text_file dropped_lines file2 then Same else Different @@ -138,13 +145,14 @@ let compare_files ?(tool = default_comparison_tool) files = ~stdout_fname:dev_null ~stderr_fname:dev_null commandline in let status = Run_command.run settings in result_of_exitcode commandline status - | Internal bytes_to_ignore -> + | Internal ignore -> match files.filetype with | Text -> (* bytes_to_ignore is silently ignored for text files *) - compare_text_files files.reference_filename files.output_filename + compare_text_files ignore.lines + files.reference_filename files.output_filename | Binary -> - compare_binary_files bytes_to_ignore + compare_binary_files ignore.bytes files.reference_filename files.output_filename let check_file ?(tool = default_comparison_tool) files = diff --git a/ocamltest/filecompare.mli b/ocamltest/filecompare.mli index c7d8ff6b1a..b1cb8569a1 100644 --- a/ocamltest/filecompare.mli +++ b/ocamltest/filecompare.mli @@ -23,7 +23,8 @@ type result = type tool -val make_cmp_tool : int -> tool +type ignore = {bytes: int; lines: int} +val make_cmp_tool : ignore:ignore -> tool val make_comparison_tool : ?result_of_exitcode:(string -> int -> result) -> string -> string -> tool diff --git a/ocamltest/main.ml b/ocamltest/main.ml index d0e441fc61..5b791ed424 100644 --- a/ocamltest/main.ml +++ b/ocamltest/main.ml @@ -38,6 +38,13 @@ let is_test filename = | _ -> false *) +(* this primitive announce should be used for tests + that were aborted on system error before ocamltest + could parse them *) +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 = let input_channel = open_in test_filename in let lexbuf = Lexing.from_channel input_channel in @@ -49,10 +56,12 @@ let tsl_block_of_file test_filename = let tsl_block_of_file_safe test_filename = try tsl_block_of_file test_filename with | Sys_error message -> - Printf.eprintf "%s\n" 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; + Printf.eprintf "Could not read test block in %s\n%!" test_filename; + announce_test_error test_filename "could not read test block"; exit 1 let print_usage () = @@ -84,8 +93,10 @@ let get_test_source_directory test_dirname = let get_test_build_directory_prefix test_dirname = let ocamltestdir_variable = "OCAMLTESTDIR" in - let root = try Sys.getenv ocamltestdir_variable with - | Not_found -> (Filename.concat (Sys.getcwd ()) "_ocamltest") in + let root = + Sys.getenv_with_default_value ocamltestdir_variable + (Filename.concat (Sys.getcwd ()) "_ocamltest") + in if test_dirname = "." then root else Filename.concat root test_dirname diff --git a/ocamltest/ocaml_actions.ml b/ocamltest/ocaml_actions.ml index b434393256..bdf4ee0a03 100644 --- a/ocamltest/ocaml_actions.ml +++ b/ocamltest/ocaml_actions.ml @@ -20,6 +20,14 @@ open Actions (* Extracting information from environment *) +let native_support = Ocamltest_config.arch <> "none" + +let no_native_compilers _log env = + (Result.skip_with_reason "native compilers disabled", env) + +let native_action a = + if native_support then a else (Actions.update a no_native_compilers) + let get_backend_value_from_env env bytecode_var native_var = Ocaml_backends.make_backend_function (Environments.safe_lookup bytecode_var env) @@ -28,6 +36,9 @@ let get_backend_value_from_env env bytecode_var native_var = let modules env = Actions_helpers.words_of_variable env Ocaml_variables.modules +let plugins env = + Actions_helpers.words_of_variable env Ocaml_variables.plugins + let directories env = Actions_helpers.words_of_variable env Ocaml_variables.directories @@ -38,6 +49,12 @@ let directory_flags env = let flags env = Environments.safe_lookup Ocaml_variables.flags env +let ocamllex_flags env = + Environments.safe_lookup Ocaml_variables.ocamllex_flags env + +let ocamlyacc_flags env = + Environments.safe_lookup Ocaml_variables.ocamlyacc_flags env + let libraries backend env = let value = Environments.safe_lookup Ocaml_variables.libraries env in let libs = String.words value in @@ -57,16 +74,85 @@ let backend_flags env = let dumb_term = [|"TERM=dumb"|] -let prepare_module (module_name, module_type) = +type module_generator = { + description : string; + command : string -> string; + flags : Environments.t -> string; + generated_compilation_units : + string -> (string * Ocaml_filetypes.t) list +} + +let ocamllex = +{ + description = "lexer"; + command = Ocaml_commands.ocamlrun_ocamllex; + flags = ocamllex_flags; + generated_compilation_units = + fun lexer_name -> [(lexer_name, Ocaml_filetypes.Implementation)] +} + +let ocamlyacc = +{ + description = "parser"; + command = Ocaml_files.ocamlyacc; + flags = ocamlyacc_flags; + generated_compilation_units = + fun parser_name -> + [ + (parser_name, Ocaml_filetypes.Interface); + (parser_name, Ocaml_filetypes.Implementation) + ] +} + +let generate_module generator ocamlsrcdir output_variable input log env = + let basename = fst input in + let input_file = Ocaml_filetypes.make_filename input in + let what = + Printf.sprintf "Generating %s module from %s" + generator.description input_file + in + Printf.fprintf log "%s\n%!" what; + let commandline = + [ + generator.command ocamlsrcdir; + generator.flags env; + input_file + ] in + let expected_exit_status = 0 in + let exit_status = + Actions_helpers.run_cmd + ~environment:dumb_term + ~stdout_variable:output_variable + ~stderr_variable:output_variable + ~append:true + log env commandline in + if exit_status=expected_exit_status + then generator.generated_compilation_units basename + else begin + let reason = + (Actions_helpers.mkreason + what (String.concat " " commandline) exit_status) in + Printf.fprintf log "%s\n%!" reason; + [] + end + +let generate_lexer = generate_module ocamllex + +let generate_parser = generate_module ocamlyacc + +let prepare_module ocamlsrcdir output_variable log env input = + let input_type = snd input in let open Ocaml_filetypes in - match module_type with - | Implementation | Interface | C -> - [(module_name, module_type)] - | Binary_interface -> [(module_name, module_type)] - | Backend_specific _ -> [(module_name, module_type)] + match input_type with + | Implementation | Interface | C -> [input] + | Binary_interface -> [input] + | Backend_specific _ -> [input] | C_minus_minus -> assert false - | Lexer -> assert false - | Grammar -> assert false + | Lexer -> + generate_lexer ocamlsrcdir output_variable input log env + | Grammar -> + generate_parser ocamlsrcdir output_variable input log env + | Text -> assert false let get_program_file backend env = let testfile = Actions_helpers.testfile env in @@ -79,55 +165,53 @@ let get_program_file backend env = Actions_helpers.test_build_directory env in Filename.make_path [test_build_directory; program_filename] -let compile_program ocamlsrcdir compiler program_variable log env = - let backend = compiler.Ocaml_compilers.backend in - let (env, program_file) = - match Environments.lookup program_variable env with - | None -> - let p = get_program_file backend env in - let env' = Environments.add program_variable p env in - (env', p) - | Some p -> (env, p) in +let compile_program ocamlsrcdir (compiler : Ocaml_compilers.compiler) log env = + let program_variable = compiler#program_variable in + let program_file = Environments.safe_lookup program_variable env in let all_modules = Actions_helpers.words_of_variable env Ocaml_variables.all_modules in + let output_variable = compiler#output_variable in + let prepare = prepare_module ocamlsrcdir output_variable log env in let modules = - List.concatmap prepare_module - (List.map Ocaml_filetypes.filetype all_modules) in + List.concatmap prepare (List.map Ocaml_filetypes.filetype all_modules) in let is_c_file (_filename, filetype) = filetype=Ocaml_filetypes.C in let has_c_file = List.exists is_c_file modules in - let custom = (backend = Ocaml_backends.Bytecode) && has_c_file in let c_headers_flags = if has_c_file then Ocaml_flags.c_includes ocamlsrcdir else "" in let expected_exit_status = - Ocaml_compilers.expected_exit_status env compiler in + Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in let module_names = String.concat " " (List.map Ocaml_filetypes.make_filename modules) in - let what = Printf.sprintf "Linking modules %s into %s" - module_names program_file in + let what = Printf.sprintf "Compiling program %s from modules %s" + program_file module_names in Printf.fprintf log "%s\n%!" what; - let output = "-o " ^ program_file in - let customstr = if custom then "-custom" else "" in + let compile_only = + Environments.lookup_as_bool Ocaml_variables.compile_only env = Some true + in + let compile_flags = + if compile_only then " -c " else "" + in + let output = if compile_only then "" else "-o " ^ program_file in let commandline = [ - compiler.Ocaml_compilers.name ocamlsrcdir; - customstr; + compiler#name ocamlsrcdir; + Ocaml_flags.runtime_flags ocamlsrcdir compiler#target has_c_file; c_headers_flags; - Ocaml_flags.use_runtime backend ocamlsrcdir; - Ocaml_flags.runtime_variant backend ocamlsrcdir; Ocaml_flags.stdlib ocamlsrcdir; directory_flags env; flags env; - libraries backend env; - backend_default_flags env backend; - backend_flags env backend; + libraries compiler#target env; + backend_default_flags env compiler#target; + backend_flags env compiler#target; + compile_flags; output; module_names ] in let exit_status = Actions_helpers.run_cmd ~environment:dumb_term - ~stdout_variable:compiler.Ocaml_compilers.output_variable - ~stderr_variable:compiler.Ocaml_compilers.output_variable + ~stdout_variable:compiler#output_variable + ~stderr_variable:compiler#output_variable ~append:true log env commandline in if exit_status=expected_exit_status @@ -140,29 +224,26 @@ let compile_program ocamlsrcdir compiler program_variable log env = end let compile_module ocamlsrcdir compiler module_ log env = - let backend = compiler.Ocaml_compilers.backend in let expected_exit_status = - Ocaml_compilers.expected_exit_status env compiler in - let what = Printf.sprintf "Compiling modules %s" module_ in + Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in + let what = Printf.sprintf "Compiling module %s" module_ in Printf.fprintf log "%s\n%!" what; let commandline = [ - compiler.Ocaml_compilers.name ocamlsrcdir; - Ocaml_flags.use_runtime backend ocamlsrcdir; - Ocaml_flags.runtime_variant backend ocamlsrcdir; + compiler#name ocamlsrcdir; Ocaml_flags.stdlib ocamlsrcdir; directory_flags env; flags env; - libraries backend env; - backend_default_flags env backend; - backend_flags env backend; + libraries compiler#target env; + backend_default_flags env compiler#target; + backend_flags env compiler#target; "-c " ^ module_; ] in let exit_status = Actions_helpers.run_cmd ~environment:dumb_term - ~stdout_variable:compiler.Ocaml_compilers.output_variable - ~stderr_variable:compiler.Ocaml_compilers.output_variable + ~stdout_variable:compiler#output_variable + ~stderr_variable:compiler#output_variable ~append:true log env commandline in if exit_status=expected_exit_status @@ -196,7 +277,7 @@ let find_source_modules log env = let source_directory = Actions_helpers.test_source_directory env in let specified_modules = List.map Ocaml_filetypes.filetype - ((modules env) @ [(Actions_helpers.testfile env)]) in + ((plugins env) @ (modules env) @ [(Actions_helpers.testfile env)]) in print_module_names log "Specified" specified_modules; let source_modules = List.concatmap @@ -208,87 +289,113 @@ let find_source_modules log env = (String.concat " " (List.map Ocaml_filetypes.make_filename source_modules)) env -let setup_compiler_build_env compiler log env = +let setup_tool_build_env tool log env = let source_directory = Actions_helpers.test_source_directory env in let testfile = Actions_helpers.testfile env in let testfile_basename = Filename.chop_extension testfile in - let compiler_reference_variable = - compiler.Ocaml_compilers.reference_variable in - let env = - if Environments.is_variable_defined compiler_reference_variable env - then env - else begin - let compiler_reference_prefix = - Filename.make_path [source_directory; testfile_basename] in - let compiler_reference_filename = - Ocaml_compilers.reference_filename - env compiler_reference_prefix compiler in - Environments.add - compiler_reference_variable compiler_reference_filename env - end in + let tool_reference_variable = + tool#reference_variable in + let tool_reference_prefix = + Filename.make_path [source_directory; testfile_basename] in + let tool_reference_file = + tool#reference_file env tool_reference_prefix + in + let env = + Environments.add_if_undefined + tool_reference_variable + tool_reference_file env + in let source_modules = Actions_helpers.words_of_variable env Ocaml_variables.all_modules in - let compiler_directory_suffix = + let tool_directory_suffix = Environments.safe_lookup Ocaml_variables.compiler_directory_suffix env in - let compiler_directory_name = - compiler.Ocaml_compilers.directory ^ compiler_directory_suffix in + let tool_directory_name = + tool#directory ^ tool_directory_suffix in let build_dir = Filename.concat (Environments.safe_lookup Builtin_variables.test_build_directory_prefix env) - compiler_directory_name in - let compiler_output_variable = compiler.Ocaml_compilers.output_variable in - let (env, compiler_output_file) = - (match Environments.lookup compiler_output_variable env with - | Some value -> (env, value) - | None -> - let compiler_output_filename = - Filename.make_filename compiler.Ocaml_compilers.directory "output" in - let file = Filename.make_path [build_dir; compiler_output_filename] in - let env' = Environments.add compiler_output_variable file env in - (env', file)) in - if Sys.file_exists compiler_output_file then - Sys.remove compiler_output_file; - let newenv = + tool_directory_name in + let tool_output_variable = tool#output_variable in + let tool_output_filename = + Filename.make_filename tool#directory "output" in + let tool_output_file = + Filename.make_path [build_dir; tool_output_filename] + in + let env = + Environments.add_if_undefined + tool_output_variable + tool_output_file env + in + Sys.force_remove tool_output_file; + let env = Environments.add Builtin_variables.test_build_directory build_dir env in - Actions_helpers.setup_build_env false source_modules log newenv - -let mk_compiler_env_setup name compiler = + Actions_helpers.setup_build_env false source_modules log env + +let setup_compiler_build_env (compiler : Ocaml_compilers.compiler) log env = + let (r, env) = setup_tool_build_env compiler log env in + if Result.is_pass r then + begin + let prog_var = compiler#program_variable in + let prog_output_var = compiler#program_output_variable in + let default_prog_file = get_program_file compiler#target env in + let env = Environments.add_if_undefined prog_var default_prog_file env in + let prog_file = Environments.safe_lookup prog_var env in + let prog_output_file = prog_file ^ ".output" in + let env = match prog_output_var with + | None -> env + | Some outputvar -> + Environments.add_if_undefined outputvar prog_output_file env + in + (r, env) + end else (r, env) + +let setup_toplevel_build_env (toplevel : Ocaml_toplevels.toplevel) log env = + setup_tool_build_env toplevel log env + +let mk_compiler_env_setup name (compiler : Ocaml_compilers.compiler) = Actions.make name (setup_compiler_build_env compiler) +let mk_toplevel_env_setup name (toplevel : Ocaml_toplevels.toplevel) = + Actions.make name (setup_toplevel_build_env toplevel) + let setup_ocamlc_byte_build_env = mk_compiler_env_setup "setup-ocamlc.byte-build-env" Ocaml_compilers.ocamlc_byte let setup_ocamlc_opt_build_env = - mk_compiler_env_setup - "setup-ocamlc.opt-build-env" - Ocaml_compilers.ocamlc_opt + native_action + (mk_compiler_env_setup + "setup-ocamlc.opt-build-env" + Ocaml_compilers.ocamlc_opt) let setup_ocamlopt_byte_build_env = - mk_compiler_env_setup - "setup-ocamlopt.byte-build-env" - Ocaml_compilers.ocamlopt_byte + native_action + (mk_compiler_env_setup + "setup-ocamlopt.byte-build-env" + Ocaml_compilers.ocamlopt_byte) let setup_ocamlopt_opt_build_env = - mk_compiler_env_setup - "setup-ocamlopt.opt-build-env" - Ocaml_compilers.ocamlopt_opt + native_action + (mk_compiler_env_setup + "setup-ocamlopt.opt-build-env" + Ocaml_compilers.ocamlopt_opt) let setup_ocaml_build_env = - mk_compiler_env_setup + mk_toplevel_env_setup "setup-ocaml-build-env" - Ocaml_compilers.ocaml + Ocaml_toplevels.ocaml let setup_ocamlnat_build_env = - mk_compiler_env_setup - "setup-ocamlnat-build-env" - Ocaml_compilers.ocamlnat + native_action + (mk_toplevel_env_setup + "setup-ocamlnat-build-env" + Ocaml_toplevels.ocamlnat) -let compile program_variable compiler log env = +let compile (compiler : Ocaml_compilers.compiler) log env = let ocamlsrcdir = Ocaml_directories.srcdir () in - match Environments.lookup Ocaml_variables.module_ env with - | None -> compile_program ocamlsrcdir compiler program_variable log env + match Environments.lookup_nonempty Ocaml_variables.module_ env with + | None -> compile_program ocamlsrcdir compiler log env | Some module_ -> compile_module ocamlsrcdir compiler module_ log env (* Compile actions *) @@ -296,29 +403,28 @@ let compile program_variable compiler log env = let ocamlc_byte = Actions.make "ocamlc.byte" - (compile - Builtin_variables.program Ocaml_compilers.ocamlc_byte) + (compile Ocaml_compilers.ocamlc_byte) let ocamlc_opt = - Actions.make - "ocamlc.opt" - (compile - Builtin_variables.program2 Ocaml_compilers.ocamlc_opt) + native_action + (Actions.make + "ocamlc.opt" + (compile Ocaml_compilers.ocamlc_opt)) let ocamlopt_byte = - Actions.make - "ocamlopt.byte" - (compile - Builtin_variables.program Ocaml_compilers.ocamlopt_byte) + native_action + (Actions.make + "ocamlopt.byte" + (compile Ocaml_compilers.ocamlopt_byte)) let ocamlopt_opt = - Actions.make - "ocamlopt.opt" - (compile - Builtin_variables.program2 Ocaml_compilers.ocamlopt_opt) + native_action + (Actions.make + "ocamlopt.opt" + (compile Ocaml_compilers.ocamlopt_opt)) let run_expect_once ocamlsrcdir input_file principal log env = - let expect_flags = try Sys.getenv "EXPECT_FLAGS" with Not_found -> "" in + let expect_flags = Sys.safe_getenv "EXPECT_FLAGS" in let repo_root = "-repo-root " ^ ocamlsrcdir in let principal_flag = if principal then "-principal" else "" in let commandline = @@ -364,24 +470,30 @@ let run_expect log env = let run_expect = Actions.make "run-expect" run_expect -let make_check_compiler_output name compiler = Actions.make +let make_check_tool_output name tool = Actions.make name (Actions_helpers.check_output - "compiler" - compiler.Ocaml_compilers.output_variable - compiler.Ocaml_compilers.reference_variable) + tool#family + tool#output_variable + tool#reference_variable) -let check_ocamlc_byte_output = make_check_compiler_output +let check_ocamlc_byte_output = make_check_tool_output "check-ocamlc.byte-output" Ocaml_compilers.ocamlc_byte -let check_ocamlc_opt_output = make_check_compiler_output - "check-ocamlc.opt-output" Ocaml_compilers.ocamlc_opt +let check_ocamlc_opt_output = + native_action + (make_check_tool_output + "check-ocamlc.opt-output" Ocaml_compilers.ocamlc_opt) -let check_ocamlopt_byte_output = make_check_compiler_output - "check-ocamlopt.byte-output" Ocaml_compilers.ocamlopt_byte +let check_ocamlopt_byte_output = + native_action + (make_check_tool_output + "check-ocamlopt.byte-output" Ocaml_compilers.ocamlopt_byte) -let check_ocamlopt_opt_output = make_check_compiler_output - "check-ocamlopt.opt-output" Ocaml_compilers.ocamlopt_opt +let check_ocamlopt_opt_output = + native_action + (make_check_tool_output + "check-ocamlopt.opt-output" Ocaml_compilers.ocamlopt_opt) let really_compare_programs backend comparison_tool log env = let program = Environments.safe_lookup Builtin_variables.program env in @@ -412,7 +524,7 @@ let really_compare_programs backend comparison_tool log env = (Sys.os_type="Win32" || Sys.os_type="Cygwin") then let bytes_to_ignore = 512 (* comparison_start_address program *) in - Filecompare.make_cmp_tool bytes_to_ignore + Filecompare.(make_cmp_tool ~ignore:{bytes=bytes_to_ignore; lines=0}) else comparison_tool in match Filecompare.compare_files ~tool:comparison_tool files with | Filecompare.Same -> (Result.pass, env) @@ -449,22 +561,26 @@ let compare_bytecode_programs_code log env = compare_programs Ocaml_backends.Bytecode bytecode_programs_comparison_tool log env -let compare_bytecode_programs = Actions.make - "compare-bytecode-programs" - compare_bytecode_programs_code +let compare_bytecode_programs = + native_action + (Actions.make + "compare-bytecode-programs" + compare_bytecode_programs_code) -let compare_native_programs = Actions.make - "compare-native-programs" - (compare_programs Ocaml_backends.Native native_programs_comparison_tool) +let compare_native_programs = + native_action + (Actions.make + "compare-native-programs" + (compare_programs Ocaml_backends.Native native_programs_comparison_tool)) let compile_module ocamlsrcdir compiler compilername compileroutput log env (module_basename, module_filetype) = - let backend = compiler.Ocaml_compilers.backend in + let backend = compiler#target in let filename = Ocaml_filetypes.make_filename (module_basename, module_filetype) in let expected_exit_status = - Ocaml_compilers.expected_exit_status env compiler in + Ocaml_tools.expected_exit_status env (compiler :> Ocaml_tools.tool) in let what = Printf.sprintf "%s for file %s (expected exit status: %d)" (Ocaml_filetypes.action_of_filetype module_filetype) filename (expected_exit_status) in @@ -538,39 +654,36 @@ let compile_modules else (result, newenv)) in compile_mods initial_env modules_with_filetypes -let run_test_program_in_toplevel toplevel log env = +let run_test_program_in_toplevel (toplevel : Ocaml_toplevels.toplevel) log env = let testfile = Actions_helpers.testfile env in let expected_exit_status = - Ocaml_compilers.expected_exit_status env toplevel in - let compiler_output_variable = toplevel.Ocaml_compilers.output_variable in + Ocaml_tools.expected_exit_status env (toplevel :> Ocaml_tools.tool) in + let compiler_output_variable = toplevel#output_variable in let ocamlsrcdir = Ocaml_directories.srcdir () in - let compiler = match toplevel.Ocaml_compilers.backend with - | Ocaml_backends.Native -> Ocaml_compilers.ocamlopt_byte - | Ocaml_backends.Bytecode -> Ocaml_compilers.ocamlc_byte in - let compiler_name = compiler.Ocaml_compilers.name ocamlsrcdir in + let compiler = toplevel#compiler in + let compiler_name = compiler#name ocamlsrcdir in let modules_with_filetypes = List.map Ocaml_filetypes.filetype (modules env) in - let (modules_result, modules_env) = compile_modules + let (result, env) = compile_modules ocamlsrcdir compiler compiler_name compiler_output_variable modules_with_filetypes log env in - if Result.is_pass modules_result then begin + if Result.is_pass result then begin let what = Printf.sprintf "Running %s in %s toplevel (expected exit status: %d)" testfile - (Ocaml_backends.string_of_backend toplevel.Ocaml_compilers.backend) + (Ocaml_backends.string_of_backend toplevel#backend) expected_exit_status in Printf.fprintf log "%s\n%!" what; - let toplevel_name = toplevel.Ocaml_compilers.name ocamlsrcdir in - let toplevel_default_flags = "-noinit -no-version -noprompt" in + let toplevel_name = toplevel#name ocamlsrcdir in let commandline = [ toplevel_name; - toplevel_default_flags; - toplevel.Ocaml_compilers.flags; + Ocaml_flags.toplevel_default_flags; + toplevel#flags; Ocaml_flags.stdlib ocamlsrcdir; - directory_flags modules_env; + directory_flags env; Ocaml_flags.include_toplevel_directory ocamlsrcdir; - flags modules_env; + flags env; ] in let exit_status = Actions_helpers.run_cmd @@ -578,30 +691,34 @@ let run_test_program_in_toplevel toplevel log env = ~stdin_variable:Builtin_variables.test_file ~stdout_variable:compiler_output_variable ~stderr_variable:compiler_output_variable - log modules_env commandline in + log env commandline in if exit_status=expected_exit_status - then (Result.pass, modules_env) + then (Result.pass, env) else begin let reason = (Actions_helpers.mkreason what (String.concat " " commandline) exit_status) in - (Result.fail_with_reason reason, modules_env) + (Result.fail_with_reason reason, env) end - end else (modules_result, modules_env) + end else (result, env) let ocaml = Actions.make "ocaml" - (run_test_program_in_toplevel Ocaml_compilers.ocaml) + (run_test_program_in_toplevel Ocaml_toplevels.ocaml) -let ocamlnat = Actions.make - "ocamlnat" - (run_test_program_in_toplevel Ocaml_compilers.ocamlnat) +let ocamlnat = + native_action + (Actions.make + "ocamlnat" + (run_test_program_in_toplevel Ocaml_toplevels.ocamlnat)) -let check_ocaml_output = make_check_compiler_output - "check-ocaml-output" Ocaml_compilers.ocaml +let check_ocaml_output = make_check_tool_output + "check-ocaml-output" Ocaml_toplevels.ocaml -let check_ocamlnat_output = make_check_compiler_output - "check-ocamlnat-output" Ocaml_compilers.ocamlnat +let check_ocamlnat_output = + native_action + (make_check_tool_output + "check-ocamlnat-output" Ocaml_toplevels.ocamlnat) let config_variables _log env = Environments.add_bindings [ @@ -610,6 +727,7 @@ let config_variables _log env = Environments.add_bindings Ocamltest_config.ocamlc_default_flags; Ocaml_variables.ocamlopt_default_flags, Ocamltest_config.ocamlopt_default_flags; + Ocaml_variables.ocamlrunparam, Sys.safe_getenv "OCAMLRUNPARAM"; Ocaml_variables.ocamlsrcdir, Ocaml_directories.srcdir(); Ocaml_variables.os_type, Sys.os_type; ] env @@ -617,14 +735,14 @@ let config_variables _log env = Environments.add_bindings let flat_float_array = Actions.make "flat-float-array" (Actions_helpers.pass_or_skip Ocamltest_config.flat_float_array - "The flat-float-array action succeeds.\n" - "Compiler configured with -no-flat-float-array.") + "compiler configured with -flat-float-array" + "compiler configured with -no-flat-float-array") let no_flat_float_array = make "no-flat-float-array" (Actions_helpers.pass_or_skip (not Ocamltest_config.flat_float_array) - "The no-flat-float-array action succeeds.\n" - "The compiler has been configured with -flat-float-array.") + "compiler configured with -no-flat-float-array" + "compiler configured with -flat-float-array") let flambda = Actions.make "flambda" @@ -662,11 +780,169 @@ let native_compiler = Actions.make "native compiler available" "native compiler not available") -let afl_support = Actions.make - "afl-support" - (Actions_helpers.pass_or_skip Ocamltest_config.afl_support - "support for AFL instrumentation enabled" - "support for AFL instrumentation disabled") +let afl_instrument = Actions.make + "afl-instrument" + (Actions_helpers.pass_or_skip Ocamltest_config.afl_instrument + "AFL instrumentation enabled" + "AFL instrumentation disabled") + +let no_afl_instrument = Actions.make + "no-afl-instrument" + (Actions_helpers.pass_or_skip (not Ocamltest_config.afl_instrument) + "AFL instrumentation disabled" + "AFL instrumentation enabled") + +let ocamldoc = Ocaml_tools.ocamldoc + +let ocamldoc_output_file env prefix = + let backend = + Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in + let suffix = match backend with + | "latex" -> ".tex" + | "html" -> ".html" + | "man" -> ".3o" + | _ -> ".result" in + prefix ^ suffix + +let check_ocamldoc_output = make_check_tool_output + "check-ocamldoc-output" ocamldoc + +let ocamldoc_flags env = + Environments.safe_lookup Ocaml_variables.ocamldoc_flags env + +let compiled_doc_name input = input ^ ".odoc" + +(* The compiler used for compiling both cmi file + and plugins *) +let compiler_for_ocamldoc ocamlsrcdir = + let compiler = Ocaml_compilers.ocamlc_byte in + compile_modules ocamlsrcdir compiler (compiler#name ocamlsrcdir) + compiler#output_variable + +(* Within ocamldoc tests, + modules="a.ml b.ml" is interpreted as a list of + secondaries documentation modules that need to be + compiled into cmi files and odoc file (serialized ocamldoc information) + before the main documentation is generated *) +let compile_ocamldoc ocamlsrcdir (basename,filetype as module_) log env = + let expected_exit_status = + Ocaml_tools.expected_exit_status env (ocamldoc :> Ocaml_tools.tool) in + let what = Printf.sprintf "Compiling documentation for module %s" basename in + Printf.fprintf log "%s\n%!" what; + let filename = + Ocaml_filetypes.make_filename (basename, filetype) in + let (r,env) = compiler_for_ocamldoc ocamlsrcdir [module_] log env in + if not (Result.is_pass r) then (r,env) else + let commandline = + (* currently, we are ignoring the global ocamldoc_flags, since we + don't have per-module flags *) + [ + Ocaml_commands.ocamlrun_ocamldoc ocamlsrcdir; + Ocaml_flags.stdlib ocamlsrcdir; + "-dump " ^ compiled_doc_name basename; + filename; + ] in + let exit_status = + Actions_helpers.run_cmd + ~environment:(Environments.to_system_env env) + ~stdout_variable:ocamldoc#output_variable + ~stderr_variable:ocamldoc#output_variable + ~append:true + log env commandline in + if exit_status=expected_exit_status + then (Result.pass, env) + else begin + let reason = + (Actions_helpers.mkreason + what (String.concat " " commandline) exit_status) in + (Result.fail_with_reason reason, env) + end + +let rec ocamldoc_compile_all ocamlsrcdir log env = function + | [] -> (Result.pass, env) + | a :: q -> + let (r,env) = compile_ocamldoc ocamlsrcdir a log env in + if Result.is_pass r then + ocamldoc_compile_all ocamlsrcdir log env q + else + (r,env) + +let setup_ocamldoc_build_env = + Actions.make "setup_ocamldoc_build_env" @@ fun log env -> + let (r,env) = setup_tool_build_env ocamldoc log env in + if not (Result.is_pass r) then (r,env) else + let source_directory = Actions_helpers.test_source_directory env in + let root_file = Filename.chop_extension (Actions_helpers.testfile env) in + let reference_prefix = Filename.make_path [source_directory; root_file] in + let output = ocamldoc_output_file env root_file in + let reference= reference_prefix ^ ocamldoc#reference_filename_suffix env in + let backend = Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in + let env = + Environments.apply_modifiers env Ocaml_modifiers.(str @ unix) + |> Environments.add Builtin_variables.reference reference + |> Environments.add Builtin_variables.output output in + let env = + if backend = "man" then Environments.add_if_undefined + Builtin_variables.skip_header_lines "1" env + else env in + Result.pass, env + +let ocamldoc_plugin name = name ^ ".cmo" + +let ocamldoc_backend_flag env = + let backend = Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in + if backend = "" then "" else "-" ^ backend + +let ocamldoc_o_flag env = + let output = Environments.safe_lookup Builtin_variables.output env in + match Environments.safe_lookup Ocaml_variables.ocamldoc_backend env with + | "html" | "manual" -> "index" + | _ -> output + +let run_ocamldoc = + Actions.make "ocamldoc" @@ fun log env -> + (* modules corresponds to secondaries modules of which the + documentation and cmi files need to be build before the main + module documentation *) + let modules = List.map Ocaml_filetypes.filetype @@ modules env in + (* plugins are used for custom documentation generators *) + let plugins = List.map Ocaml_filetypes.filetype @@ plugins env in + let ocamlsrcdir = Ocaml_directories.srcdir () in + let (r,env) = compiler_for_ocamldoc ocamlsrcdir plugins log env in + if not (Result.is_pass r) then r, env else + let (r,env) = ocamldoc_compile_all ocamlsrcdir log env modules in + if not (Result.is_pass r) then r, env else + let input_file = Actions_helpers.testfile env in + Printf.fprintf log "Generating documentation for %s\n%!" input_file; + let load_all = + List.map (fun name -> "-load " ^ compiled_doc_name (fst name)) + @@ (* sort module in alphabetical order *) + List.sort Pervasives.compare modules in + let with_plugins = + List.map (fun name -> "-g " ^ ocamldoc_plugin (fst name)) plugins in + let commandline = + [ + Ocaml_commands.ocamlrun_ocamldoc ocamlsrcdir; + ocamldoc_backend_flag env; + Ocaml_flags.stdlib ocamlsrcdir; + ocamldoc_flags env] + @ load_all @ with_plugins @ + [ input_file; + "-o"; ocamldoc_o_flag env + ] in + let exit_status = + Actions_helpers.run_cmd ~environment:(Environments.to_system_env env) + ~stdout_variable:ocamldoc#output_variable + ~stderr_variable:ocamldoc#output_variable + ~append:true + log env commandline in + if exit_status=0 then + (Result.pass, env) + else begin + let reason = (Actions_helpers.mkreason + "ocamldoc" (String.concat " " commandline) exit_status) in + (Result.fail_with_reason reason, env) + end let _ = Environments.register_initializer "find_source_modules" find_source_modules; @@ -702,5 +978,9 @@ let _ = no_spacetime; shared_libraries; native_compiler; - afl_support; + afl_instrument; + no_afl_instrument; + setup_ocamldoc_build_env; + run_ocamldoc; + check_ocamldoc_output ] diff --git a/ocamltest/ocaml_actions.mli b/ocamltest/ocaml_actions.mli index 5b70c33d99..ab4d302ae3 100644 --- a/ocamltest/ocaml_actions.mli +++ b/ocamltest/ocaml_actions.mli @@ -37,6 +37,10 @@ val setup_ocamlnat_build_env : Actions.t val ocamlnat : Actions.t val check_ocamlnat_output : Actions.t +val setup_ocamldoc_build_env : Actions.t +val run_ocamldoc: Actions.t +val check_ocamldoc_output: Actions.t + val flat_float_array : Actions.t val no_flat_float_array : Actions.t @@ -44,4 +48,5 @@ val shared_libraries : Actions.t val native_compiler : Actions.t -val afl_support : Actions.t +val afl_instrument : Actions.t +val no_afl_instrument : Actions.t diff --git a/ocamltest/ocaml_backends.ml b/ocamltest/ocaml_backends.ml index 5522206368..71e75a49eb 100644 --- a/ocamltest/ocaml_backends.ml +++ b/ocamltest/ocaml_backends.ml @@ -17,6 +17,10 @@ type t = Native | Bytecode +let is_bytecode t = t=Bytecode + +let is_native t = t=Native + let string_of_backend = function | Native -> "native" | Bytecode -> "bytecode" diff --git a/ocamltest/ocaml_backends.mli b/ocamltest/ocaml_backends.mli index 8b83543034..5cc48e8587 100644 --- a/ocamltest/ocaml_backends.mli +++ b/ocamltest/ocaml_backends.mli @@ -17,6 +17,10 @@ type t = Native | Bytecode +val is_bytecode : t -> bool + +val is_native : t -> bool + val string_of_backend : t -> string val make_backend_function : 'a -> 'a -> t -> 'a diff --git a/ocamltest/ocaml_commands.ml b/ocamltest/ocaml_commands.ml index b3976ffe85..063d07703c 100644 --- a/ocamltest/ocaml_commands.ml +++ b/ocamltest/ocaml_commands.ml @@ -26,3 +26,8 @@ let ocamlrun_ocaml ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocaml let ocamlrun_expect_test ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.expect_test + +let ocamlrun_ocamllex ocamlsrcdir = ocamlrun ocamlsrcdir Ocaml_files.ocamllex + +let ocamlrun_ocamldoc ocamlsrcdir = + ocamlrun ocamlsrcdir Ocaml_files.ocamldoc diff --git a/ocamltest/ocaml_commands.mli b/ocamltest/ocaml_commands.mli index 2c5841a1e8..d27cee2123 100644 --- a/ocamltest/ocaml_commands.mli +++ b/ocamltest/ocaml_commands.mli @@ -22,3 +22,7 @@ val ocamlrun_ocamlopt : string -> string val ocamlrun_ocaml : string -> string val ocamlrun_expect_test : string -> string + +val ocamlrun_ocamllex : string -> string + +val ocamlrun_ocamldoc : string -> string diff --git a/ocamltest/ocaml_compilers.ml b/ocamltest/ocaml_compilers.ml index dcb086e38a..bb3ed6ae4f 100644 --- a/ocamltest/ocaml_compilers.ml +++ b/ocamltest/ocaml_compilers.ml @@ -13,106 +13,89 @@ (* *) (**************************************************************************) -(* Descriptions of the OCaml compilers and toplevels *) +(* Description of the OCaml compilers *) open Ocamltest_stdlib -type t = { - name : string -> string; - flags : string; - directory : string; - backend : Ocaml_backends.t; - exit_status_variabe : Variables.t; - reference_variable : Variables.t; - output_variable : Variables.t -} +class compiler + ~(name : string -> string) + ~(flags : string) + ~(directory : string) + ~(exit_status_variable : Variables.t) + ~(reference_variable : Variables.t) + ~(output_variable : Variables.t) + ~(host : Ocaml_backends.t) + ~(target : Ocaml_backends.t) += object (self) inherit Ocaml_tools.tool + ~name:name + ~family:"compiler" + ~flags:flags + ~directory:directory + ~exit_status_variable:exit_status_variable + ~reference_variable:reference_variable + ~output_variable:output_variable + as tool -(* Compilers compiling byte-code programs *) + method host = host + method target = target -let ocamlc_byte = -{ - name = Ocaml_commands.ocamlrun_ocamlc; - flags = ""; - directory = "ocamlc.byte"; - backend = Ocaml_backends.Bytecode; - exit_status_variabe = Ocaml_variables.ocamlc_byte_exit_status; - reference_variable = Ocaml_variables.compiler_reference; - output_variable = Ocaml_variables.compiler_output; -} + method program_variable = + if Ocaml_backends.is_native host + then Builtin_variables.program2 + else Builtin_variables.program -let ocamlc_opt = -{ - name = Ocaml_files.ocamlc_dot_opt; - flags = ""; - directory = "ocamlc.opt"; - backend = Ocaml_backends.Bytecode; - exit_status_variabe = Ocaml_variables.ocamlc_opt_exit_status; - reference_variable = Ocaml_variables.compiler_reference2; - output_variable = Ocaml_variables.compiler_output2; -} + method program_output_variable = + if Ocaml_backends.is_native host + then None + else Some Builtin_variables.output -(* Compilers compiling native-code programs *) + method ! reference_file env prefix = + let default = tool#reference_file env prefix in + if Sys.file_exists default then default else + let suffix = self#reference_filename_suffix env in + let mk s = (Filename.make_filename prefix s) ^ suffix in + let filename = mk + (Ocaml_backends.string_of_backend target) in + if Sys.file_exists filename then filename else + mk "compilers" +end -let ocamlopt_byte = -{ - name = Ocaml_commands.ocamlrun_ocamlopt; - flags = ""; - directory = "ocamlopt.byte"; - backend = Ocaml_backends.Native; - exit_status_variabe = Ocaml_variables.ocamlopt_byte_exit_status; - reference_variable = Ocaml_variables.compiler_reference; - output_variable = Ocaml_variables.compiler_output; -} +let ocamlc_byte = new compiler + ~name: Ocaml_commands.ocamlrun_ocamlc + ~flags: "" + ~directory: "ocamlc.byte" + ~exit_status_variable: Ocaml_variables.ocamlc_byte_exit_status + ~reference_variable: Ocaml_variables.compiler_reference + ~output_variable: Ocaml_variables.compiler_output + ~host: Ocaml_backends.Bytecode + ~target: Ocaml_backends.Bytecode -let ocamlopt_opt = -{ - name = Ocaml_files.ocamlopt_dot_opt; - flags = ""; - directory = "ocamlopt.opt"; - backend = Ocaml_backends.Native; - exit_status_variabe = Ocaml_variables.ocamlopt_opt_exit_status; - reference_variable = Ocaml_variables.compiler_reference2; - output_variable = Ocaml_variables.compiler_output2; -} +let ocamlc_opt = new compiler + ~name: Ocaml_files.ocamlc_dot_opt + ~flags: "" + ~directory: "ocamlc.opt" + ~exit_status_variable: Ocaml_variables.ocamlc_opt_exit_status + ~reference_variable: Ocaml_variables.compiler_reference2 + ~output_variable: Ocaml_variables.compiler_output2 + ~host: Ocaml_backends.Native + ~target: Ocaml_backends.Bytecode -(* Top-levels *) +let ocamlopt_byte = new compiler + ~name: Ocaml_commands.ocamlrun_ocamlopt + ~flags: "" + ~directory: "ocamlopt.byte" + ~exit_status_variable: Ocaml_variables.ocamlopt_byte_exit_status + ~reference_variable: Ocaml_variables.compiler_reference + ~output_variable: Ocaml_variables.compiler_output + ~host: Ocaml_backends.Bytecode + ~target: Ocaml_backends.Native -let ocaml = { - name = Ocaml_commands.ocamlrun_ocaml; - flags = ""; - directory = "ocaml"; - backend = Ocaml_backends.Bytecode; - exit_status_variabe = Ocaml_variables.ocaml_exit_status; - reference_variable = Ocaml_variables.compiler_reference; - output_variable = Ocaml_variables.compiler_output; -} - -let ocamlnat = { - name = Ocaml_files.ocamlnat; - flags = "-S"; (* Keep intermediate assembly files *) - directory = "ocamlnat"; - backend = Ocaml_backends.Native; - exit_status_variabe = Ocaml_variables.ocamlnat_exit_status; - reference_variable = Ocaml_variables.compiler_reference2; - output_variable = Ocaml_variables.compiler_output2; -} - -let expected_exit_status env compiler = - try int_of_string - (Environments.safe_lookup compiler.exit_status_variabe env) - with _ -> 0 - -let reference_filename env prefix compiler = - let compiler_reference_suffix = - Environments.safe_lookup Ocaml_variables.compiler_reference_suffix env in - let suffix = - if compiler_reference_suffix<>"" - then compiler_reference_suffix ^ ".reference" - else ".reference" in - let mk s = (Filename.make_filename prefix s) ^ suffix in - let filename = mk compiler.directory in - if Sys.file_exists filename then filename else - let filename = mk - (Ocaml_backends.string_of_backend compiler.backend) in - if Sys.file_exists filename then filename else - mk "compilers" +let ocamlopt_opt = new compiler + ~name: Ocaml_files.ocamlopt_dot_opt + ~flags: "" + ~directory: "ocamlopt.opt" + ~exit_status_variable: Ocaml_variables.ocamlopt_opt_exit_status + ~reference_variable: Ocaml_variables.compiler_reference2 + ~output_variable: Ocaml_variables.compiler_output2 + ~host: Ocaml_backends.Native + ~target: Ocaml_backends.Native diff --git a/ocamltest/ocaml_compilers.mli b/ocamltest/ocaml_compilers.mli index d004f1781f..e4eb638e38 100644 --- a/ocamltest/ocaml_compilers.mli +++ b/ocamltest/ocaml_compilers.mli @@ -13,30 +13,28 @@ (* *) (**************************************************************************) -(* Descriptions of the OCaml compilers and toplevels *) - -type t = { - name : string -> string; - flags : string; - directory : string; - backend : Ocaml_backends.t; - exit_status_variabe : Variables.t; - reference_variable : Variables.t; - output_variable : Variables.t -} - -val ocamlc_byte : t - -val ocamlc_opt : t - -val ocamlopt_byte : t - -val ocamlopt_opt : t - -val ocaml : t - -val ocamlnat : t - -val expected_exit_status : Environments.t -> t -> int - -val reference_filename : Environments.t -> string -> t -> string +(* Descriptions of the OCaml compilers *) + +class compiler : + name : (string -> string) -> + flags : string -> + directory : string -> + exit_status_variable : Variables.t -> + reference_variable : Variables.t -> + output_variable : Variables.t -> + host : Ocaml_backends.t -> + target : Ocaml_backends.t -> +object inherit Ocaml_tools.tool + method host : Ocaml_backends.t + method target : Ocaml_backends.t + method program_variable : Variables.t + method program_output_variable : Variables.t option +end + +val ocamlc_byte : compiler + +val ocamlc_opt : compiler + +val ocamlopt_byte : compiler + +val ocamlopt_opt : compiler diff --git a/ocamltest/ocaml_directories.ml b/ocamltest/ocaml_directories.ml index 064fd57cbb..9b59687029 100644 --- a/ocamltest/ocaml_directories.ml +++ b/ocamltest/ocaml_directories.ml @@ -18,8 +18,7 @@ open Ocamltest_stdlib let srcdir () = - try Sys.getenv "OCAMLSRCDIR" - with Not_found -> Ocamltest_config.ocamlsrcdir + Sys.getenv_with_default_value "OCAMLSRCDIR" Ocamltest_config.ocamlsrcdir let stdlib ocamlsrcdir = Filename.make_path [ocamlsrcdir; "stdlib"] @@ -29,3 +28,9 @@ let toplevel ocamlsrcdir = let runtime ocamlsrcdir = Filename.make_path [ocamlsrcdir; "byterun"] + +let runtime_library backend ocamlsrcdir = + let backend_lib_dir = match backend with + | Ocaml_backends.Native -> "asmrun" + | Ocaml_backends.Bytecode -> "byterun" in + Filename.make_path [ocamlsrcdir; backend_lib_dir] diff --git a/ocamltest/ocaml_directories.mli b/ocamltest/ocaml_directories.mli index 2d25d64f50..c7bb5b2df5 100644 --- a/ocamltest/ocaml_directories.mli +++ b/ocamltest/ocaml_directories.mli @@ -22,3 +22,5 @@ val stdlib : string -> string val toplevel : string -> string val runtime : string -> string + +val runtime_library : Ocaml_backends.t -> string -> string diff --git a/ocamltest/ocaml_files.ml b/ocamltest/ocaml_files.ml index e16bcc3456..1ad5a3ce5f 100644 --- a/ocamltest/ocaml_files.ml +++ b/ocamltest/ocaml_files.ml @@ -23,7 +23,7 @@ type runtime_variant = | Instrumented let runtime_variant() = - let use_runtime = try Sys.getenv "USE_RUNTIME" with Not_found -> "" in + let use_runtime = Sys.safe_getenv "USE_RUNTIME" in if use_runtime="d" then Debug else if use_runtime="i" then Instrumented else Normal @@ -60,3 +60,13 @@ let cmpbyt ocamlsrcdir = let expect_test ocamlsrcdir = Filename.make_path [ocamlsrcdir; "testsuite"; "tools"; Filename.mkexe "expect_test"] + +let ocamllex ocamlsrcdir = + Filename.make_path [ocamlsrcdir; "lex"; "ocamllex"] + +let ocamlyacc ocamlsrcdir = + Filename.make_path [ocamlsrcdir; "yacc"; Filename.mkexe "ocamlyacc"] + +let ocamldoc ocamlsrcdir = + Filename.make_path + [ocamlsrcdir; "ocamldoc"; "ocamldoc"] diff --git a/ocamltest/ocaml_files.mli b/ocamltest/ocaml_files.mli index cfa806b89f..77b9602437 100644 --- a/ocamltest/ocaml_files.mli +++ b/ocamltest/ocaml_files.mli @@ -39,3 +39,9 @@ val ocamlnat : string -> string val cmpbyt : string -> string val expect_test : string -> string + +val ocamllex : string -> string + +val ocamlyacc : string -> string + +val ocamldoc : string -> string diff --git a/ocamltest/ocaml_filetypes.ml b/ocamltest/ocaml_filetypes.ml index c766300542..997cc1b744 100644 --- a/ocamltest/ocaml_filetypes.ml +++ b/ocamltest/ocaml_filetypes.ml @@ -26,6 +26,7 @@ type t = | Grammar | Binary_interface | Backend_specific of Ocaml_backends.t * backend_specific + | Text (* used by ocamldoc for text only documentation *) let string_of_backend_specific = function | Object -> "object" @@ -43,6 +44,7 @@ let string_of_filetype = function | Backend_specific (backend, filetype) -> ((Ocaml_backends.string_of_backend backend) ^ " " ^ (string_of_backend_specific filetype)) + | Text -> "text" let extension_of_filetype = function | Implementation -> "ml" @@ -61,6 +63,7 @@ let extension_of_filetype = function | (Ocaml_backends.Bytecode, Library) -> "cma" | (Ocaml_backends.Bytecode, Program) -> "byte" end + | Text -> "txt" let filetype_of_extension = function | "ml" -> Implementation @@ -76,6 +79,7 @@ let filetype_of_extension = function | "cmo" -> Backend_specific (Ocaml_backends.Bytecode, Object) | "cma" -> Backend_specific (Ocaml_backends.Bytecode, Library) | "byte" -> Backend_specific (Ocaml_backends.Bytecode, Program) + | "txt" -> Text | _ -> raise Not_found let split_filename name = diff --git a/ocamltest/ocaml_filetypes.mli b/ocamltest/ocaml_filetypes.mli index 2f0ccb2395..89911d4b26 100644 --- a/ocamltest/ocaml_filetypes.mli +++ b/ocamltest/ocaml_filetypes.mli @@ -26,6 +26,7 @@ type t = | Grammar | Binary_interface | Backend_specific of Ocaml_backends.t * backend_specific + | Text (** text-only documentation file *) val string_of_filetype : t -> string diff --git a/ocamltest/ocaml_flags.ml b/ocamltest/ocaml_flags.ml index 29db3351a2..90ff69d562 100644 --- a/ocamltest/ocaml_flags.ml +++ b/ocamltest/ocaml_flags.ml @@ -15,8 +15,6 @@ (* Flags used in OCaml commands *) -open Ocamltest_stdlib - let stdlib ocamlsrcdir = let stdlib_path = Ocaml_directories.stdlib ocamlsrcdir in "-nostdlib -I " ^ stdlib_path @@ -28,20 +26,24 @@ let c_includes ocamlsrcdir = let dir = Ocaml_directories.runtime ocamlsrcdir in "-ccopt -I" ^ dir -let use_runtime backend ocamlsrcdir = match backend with - | Ocaml_backends.Bytecode -> - let ocamlrun = Ocaml_files.ocamlrun ocamlsrcdir in - "-use-runtime " ^ ocamlrun - | Ocaml_backends.Native -> "" +let runtime_variant_flags () = match Ocaml_files.runtime_variant() with + | Ocaml_files.Normal -> "" + | Ocaml_files.Debug -> " -runtime-variant d" + | Ocaml_files.Instrumented -> " -runtime-variant i" + +let runtime_flags ocamlsrcdir backend c_files = + let runtime_library_flags = "-I " ^ + (Ocaml_directories.runtime_library backend ocamlsrcdir) in + let rt_flags = match backend with + | Ocaml_backends.Native -> runtime_variant_flags () + | Ocaml_backends.Bytecode -> + begin + if c_files then begin (* custom mode *) + "-custom " ^ (runtime_variant_flags ()) + end else begin (* non-custom mode *) + "-use-runtime " ^ (Ocaml_files.ocamlrun ocamlsrcdir) + end + end in + rt_flags ^ " " ^ runtime_library_flags -let runtime_variant backend ocamlsrcdir = - let variant = Ocaml_files.runtime_variant() in - if variant=Ocaml_files.Normal then "" - else begin - let variant_str = if variant=Ocaml_files.Debug then "d" else "i" in - let backend_lib = match backend with - | Ocaml_backends.Bytecode -> "byterun" - | Ocaml_backends.Native -> "asmrun" in - let backend_lib_dir = Filename.make_path [ocamlsrcdir; backend_lib] in - ("-runtime-variant " ^ variant_str ^" -I " ^ backend_lib_dir) - end +let toplevel_default_flags = "-noinit -no-version -noprompt" diff --git a/ocamltest/ocaml_flags.mli b/ocamltest/ocaml_flags.mli index 3e744005f5..c3d512e4a0 100644 --- a/ocamltest/ocaml_flags.mli +++ b/ocamltest/ocaml_flags.mli @@ -21,6 +21,6 @@ val include_toplevel_directory : string -> string val c_includes : string -> string -val use_runtime : Ocaml_backends.t -> string -> string +val runtime_flags : string -> Ocaml_backends.t -> bool -> string -val runtime_variant : Ocaml_backends.t -> string -> string +val toplevel_default_flags : string diff --git a/ocamltest/ocaml_modifiers.ml b/ocamltest/ocaml_modifiers.ml index af253586e6..0e8e93a88e 100644 --- a/ocamltest/ocaml_modifiers.ml +++ b/ocamltest/ocaml_modifiers.ml @@ -25,19 +25,44 @@ let principal = Add (Ocaml_variables.compiler_reference_suffix, ".principal"); ] +let latex = + [ + Add (Ocaml_variables.ocamldoc_backend, "latex"); + Append (Ocaml_variables.ocamldoc_flags, "-latex-type-prefix=TYP "); + Append (Ocaml_variables.ocamldoc_flags, "-latex-module-prefix= "); + Append (Ocaml_variables.ocamldoc_flags, "-latex-value-prefix= "); + Append (Ocaml_variables.ocamldoc_flags, "-latex-module-type-prefix= "); + Append (Ocaml_variables.ocamldoc_flags, "-latextitle=1,subsection* "); + Append (Ocaml_variables.ocamldoc_flags, "-latextitle=2,subsubsection* "); + Append (Ocaml_variables.ocamldoc_flags, "-latextitle=6,subsection* "); + Append (Ocaml_variables.ocamldoc_flags, "-latextitle=7,subsubsection* "); + ] + + +let html = + [ + Add (Ocaml_variables.ocamldoc_backend, "html"); + Append (Ocaml_variables.ocamldoc_flags, "-colorize-code "); + ] + +let man = + [ + Add (Ocaml_variables.ocamldoc_backend, "man"); + ] + let wrap str = (" " ^ str ^ " ") let make_library_modifier library directory = [ Append (Ocaml_variables.directories, (wrap directory)); Append (Ocaml_variables.libraries, (wrap library)); - Append (Builtin_variables.ld_library_path, (wrap directory)); + Append (Ocaml_variables.caml_ld_library_path, (wrap directory)); ] let compiler_subdir subdir = Filename.make_path (Ocamltest_config.ocamlsrcdir :: subdir) -let config = +let config = [ Append (Ocaml_variables.directories, (wrap (compiler_subdir ["utils"]))); ] @@ -82,4 +107,7 @@ let _ = register_modifiers "str" str; register_modifiers "ocamlcommon" ocamlcommon; register_modifiers "systhreads" systhreads; + register_modifiers "latex" latex; + register_modifiers "html" html; + register_modifiers "man" man; () diff --git a/ocamltest/ocaml_modifiers.mli b/ocamltest/ocaml_modifiers.mli index 046f988cf2..a6d2adc2f5 100644 --- a/ocamltest/ocaml_modifiers.mli +++ b/ocamltest/ocaml_modifiers.mli @@ -22,3 +22,7 @@ val testing : Environments.modifiers val unix : Environments.modifiers val str : Environments.modifiers + +val latex: Environments.modifiers +val man: Environments.modifiers +val html: Environments.modifiers diff --git a/ocamltest/ocaml_tests.ml b/ocamltest/ocaml_tests.ml index 9917fc3c08..35cfa75dd3 100644 --- a/ocamltest/ocaml_tests.ml +++ b/ocamltest/ocaml_tests.ml @@ -88,6 +88,23 @@ let expect = ] } +let ocamldoc = +{ + test_name = "ocamldoc"; + test_run_by_default = false; + test_actions = + if Ocamltest_config.ocamldoc then + [ + shared_libraries; + setup_ocamldoc_build_env; + run_ocamldoc; + check_program_output; + check_ocamldoc_output + ] + else + [ skip ] +} + let _ = List.iter register [ @@ -95,4 +112,5 @@ let _ = native; toplevel; expect; + ocamldoc; ] diff --git a/ocamltest/ocaml_tests.mli b/ocamltest/ocaml_tests.mli index 52493f4c66..b9cd02256a 100644 --- a/ocamltest/ocaml_tests.mli +++ b/ocamltest/ocaml_tests.mli @@ -22,3 +22,5 @@ val native : Tests.t val toplevel : Tests.t val expect : Tests.t + +val ocamldoc : Tests.t diff --git a/ocamltest/ocaml_tools.ml b/ocamltest/ocaml_tools.ml new file mode 100644 index 0000000000..4b98bc2d89 --- /dev/null +++ b/ocamltest/ocaml_tools.ml @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2018 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. *) +(* *) +(**************************************************************************) + +(* Descriptions of the OCaml tools *) + +open Ocamltest_stdlib + +class tool + ~(name : string -> string) + ~(family : string) + ~(flags : string) + ~(directory : string) + ~(exit_status_variable : Variables.t) + ~(reference_variable : Variables.t) + ~(output_variable : Variables.t) += object (self) + method name = name + method family = family + method flags = flags + method directory = directory + method exit_status_variable = exit_status_variable + method reference_variable = reference_variable + method output_variable = output_variable + + method reference_filename_suffix env = + let tool_reference_suffix = + Environments.safe_lookup Ocaml_variables.compiler_reference_suffix env + in + if tool_reference_suffix<>"" + then tool_reference_suffix ^ ".reference" + else ".reference" + + method reference_file env prefix = + let suffix = self#reference_filename_suffix env in + (Filename.make_filename prefix directory) ^ suffix +end + +let expected_exit_status env tool = + Actions_helpers.exit_status_of_variable env tool#exit_status_variable + + +let ocamldoc = + object inherit + tool + ~name:Ocaml_files.ocamldoc + ~family:"doc" + ~flags:"" + ~directory:"ocamldoc" + ~exit_status_variable:Ocaml_variables.ocamldoc_exit_status + ~reference_variable:Ocaml_variables.ocamldoc_reference + ~output_variable:Ocaml_variables.ocamldoc_output + + method ! reference_filename_suffix env = + let backend = + Environments.safe_lookup Ocaml_variables.ocamldoc_backend env in + if backend = "" then + ".reference" + else "." ^ backend ^ ".reference" + end diff --git a/ocamltest/ocaml_tools.mli b/ocamltest/ocaml_tools.mli new file mode 100644 index 0000000000..c8acbee36d --- /dev/null +++ b/ocamltest/ocaml_tools.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2018 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. *) +(* *) +(**************************************************************************) + +(* Descriptions of the OCaml tools *) + +class tool : + name : (string -> string) -> + family : string -> + flags : string -> + directory : string -> + exit_status_variable : Variables.t -> + reference_variable : Variables.t -> + output_variable : Variables.t -> +object + method name : string -> string + method family : string + method flags : string + method directory : string + method exit_status_variable : Variables.t + method reference_variable : Variables.t + method output_variable : Variables.t + method reference_filename_suffix : Environments.t -> string + method reference_file : Environments.t -> string -> string +end + +val expected_exit_status : Environments.t -> tool -> int + +val ocamldoc: tool diff --git a/ocamltest/ocaml_toplevels.ml b/ocamltest/ocaml_toplevels.ml new file mode 100644 index 0000000000..9121cc0c13 --- /dev/null +++ b/ocamltest/ocaml_toplevels.ml @@ -0,0 +1,70 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2018 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. *) +(* *) +(**************************************************************************) + +(* Description of the OCaml toplevels *) + +open Ocamltest_stdlib + +class toplevel + ~(name : string -> string) + ~(flags : string) + ~(directory : string) + ~(exit_status_variable : Variables.t) + ~(reference_variable : Variables.t) + ~(output_variable : Variables.t) + ~(backend : Ocaml_backends.t) + ~(compiler : Ocaml_compilers.compiler) += object (self) inherit Ocaml_tools.tool + ~name:name + ~family:"toplevel" + ~flags:flags + ~directory:directory + ~exit_status_variable:exit_status_variable + ~reference_variable:reference_variable + ~output_variable:output_variable + as tool + method backend = backend + method compiler = compiler + method ! reference_file env prefix = + let default = tool#reference_file env prefix in + if Sys.file_exists default then default else + let suffix = self#reference_filename_suffix env in + let mk s = (Filename.make_filename prefix s) ^ suffix in + let filename = mk + (Ocaml_backends.string_of_backend self#backend) in + if Sys.file_exists filename then filename else + mk "compilers" + +end + +let ocaml = new toplevel + ~name: Ocaml_commands.ocamlrun_ocaml + ~flags: "" + ~directory: "ocaml" + ~exit_status_variable: Ocaml_variables.ocaml_exit_status + ~reference_variable: Ocaml_variables.compiler_reference + ~output_variable: Ocaml_variables.compiler_output + ~backend: Ocaml_backends.Bytecode + ~compiler: Ocaml_compilers.ocamlc_byte + +let ocamlnat = new toplevel + ~name: Ocaml_files.ocamlnat + ~flags: "-S" (* Keep intermediate assembly files *) + ~directory: "ocamlnat" + ~exit_status_variable: Ocaml_variables.ocamlnat_exit_status + ~reference_variable: Ocaml_variables.compiler_reference2 + ~output_variable: Ocaml_variables.compiler_output2 + ~backend: Ocaml_backends.Native + ~compiler: Ocaml_compilers.ocamlc_opt diff --git a/ocamltest/ocaml_toplevels.mli b/ocamltest/ocaml_toplevels.mli new file mode 100644 index 0000000000..f29fbac722 --- /dev/null +++ b/ocamltest/ocaml_toplevels.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2018 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. *) +(* *) +(**************************************************************************) + +(* Descriptions of the OCaml toplevels *) + +class toplevel : + name : (string -> string) -> + flags : string -> + directory : string -> + exit_status_variable : Variables.t -> + reference_variable : Variables.t -> + output_variable : Variables.t -> + backend : Ocaml_backends.t -> + compiler : Ocaml_compilers.compiler -> +object inherit Ocaml_tools.tool + method backend : Ocaml_backends.t + method compiler : Ocaml_compilers.compiler +end + +val ocaml : toplevel + +val ocamlnat : toplevel diff --git a/ocamltest/ocaml_variables.ml b/ocamltest/ocaml_variables.ml index f3e54983f4..4af5096a07 100644 --- a/ocamltest/ocaml_variables.ml +++ b/ocamltest/ocaml_variables.ml @@ -22,6 +22,8 @@ should be similar. Is there a way to enforce this? *) +open Ocamltest_stdlib + open Variables (* Should not be necessary with a ppx *) let all_modules = make ("all_modules", @@ -30,6 +32,24 @@ let all_modules = make ("all_modules", let c_preprocessor = make ("c_preprocessor", "Command to use to invoke the C preprocessor") +let caml_ld_library_path_name = "CAML_LD_LIBRARY_PATH" + +let export_caml_ld_library_path value = + let current_value = Sys.safe_getenv caml_ld_library_path_name in + let local_value = + (String.concat Filename.path_sep (String.words value)) in + let new_value = + if local_value="" then current_value else + if current_value="" then local_value else + String.concat Filename.path_sep [local_value; current_value] in + Printf.sprintf "%s=%s" caml_ld_library_path_name new_value + +let caml_ld_library_path = + make_with_exporter + export_caml_ld_library_path + ("ld_library_path", + "List of paths to lookup for loading dynamic libraries") + let compare_programs = make ("compare_programs", "Set to \"false\" to disable program comparison") @@ -51,6 +71,9 @@ let compiler_output = make ("compiler_output", let compiler_output2 = make ("compiler_output2", "Where to log output of native compilers") +let compile_only = make ("compile_only", + "Compile only (do not link)") + let ocamlc_flags = make ("ocamlc_flags", "Flags passed to ocamlc.byte and ocamlc.opt") @@ -72,12 +95,18 @@ let module_ = make ("module", let modules = make ("modules", "Other modules of the test") +let ocamllex_flags = make ("ocamllex_flags", + "Flags passed to ocamllex") + let ocamlopt_flags = make ("ocamlopt_flags", "Flags passed to ocamlopt.byte and ocamlopt.opt") let ocamlopt_default_flags = make ("ocamlopt_default_flags", "Flags passed by default to ocamlopt.byte and ocamlopt.opt") +let ocamlyacc_flags = make ("ocamlyacc_flags", + "Flags passed to ocamlyacc") + let ocaml_exit_status = make ("ocaml_exit_status", "Expected exit status of ocaml") @@ -96,12 +125,42 @@ let ocamlc_opt_exit_status = make ("ocamlc_opt_exit_status", let ocamlopt_opt_exit_status = make ("ocamlopt_opt_exit_status", "Expected exit status of ocamlopt.opt") +let export_ocamlrunparam value = + Printf.sprintf "%s=%s" "OCAMLRUNPARAM" value + +let ocamlrunparam = + make_with_exporter + export_ocamlrunparam + ("ocamlrunparam", + "Equivalent of OCAMLRUNPARAM") + let ocamlsrcdir = make ("ocamlsrcdir", "Where OCaml sources are") let os_type = make ("os_type", "The OS we are running on") +let ocamldoc_flags = Variables.make ("ocamldoc_flags", + "ocamldoc flags") + +let ocamldoc_backend = Variables.make ("ocamldoc_backend", + "ocamldoc backend (html, latex, man, ... )") + +let ocamldoc_exit_status = + Variables.make ( "ocamldoc_exit_status", "expected ocamldoc exit status") + +let ocamldoc_output = + Variables.make ( "ocamldoc_output", "Where to log ocamldoc output") + +let ocamldoc_reference = + Variables.make ( "ocamldoc_reference", + "Where to find expected ocamldoc output") + + +let plugins = + Variables.make ( "plugins", "plugins for ocamlc,ocamlopt or ocamldoc" ) + + let _ = List.iter register_variable [ all_modules; @@ -113,6 +172,7 @@ let _ = List.iter register_variable compiler_reference_suffix; compiler_output; compiler_output2; + compile_only; directories; flags; libraries; @@ -128,5 +188,14 @@ let _ = List.iter register_variable ocamlnat_exit_status; ocamlc_opt_exit_status; ocamlopt_opt_exit_status; + ocamlrunparam; os_type; + ocamllex_flags; + ocamlyacc_flags; + ocamldoc_flags; + ocamldoc_backend; + ocamldoc_output; + ocamldoc_reference; + ocamldoc_exit_status; + plugins ] diff --git a/ocamltest/ocaml_variables.mli b/ocamltest/ocaml_variables.mli index 4173231a68..61b76a7a31 100644 --- a/ocamltest/ocaml_variables.mli +++ b/ocamltest/ocaml_variables.mli @@ -21,6 +21,8 @@ val all_modules : Variables.t val c_preprocessor : Variables.t +val caml_ld_library_path : Variables.t + val compare_programs : Variables.t val compiler_directory_suffix : Variables.t @@ -35,6 +37,8 @@ val compiler_output : Variables.t val compiler_output2 : Variables.t +val compile_only : Variables.t + val directories : Variables.t val flags : Variables.t @@ -48,9 +52,13 @@ val modules : Variables.t val ocamlc_flags : Variables.t val ocamlc_default_flags : Variables.t +val ocamllex_flags : Variables.t + val ocamlopt_flags : Variables.t val ocamlopt_default_flags : Variables.t +val ocamlyacc_flags : Variables.t + val ocaml_exit_status : Variables.t val ocamlc_byte_exit_status : Variables.t @@ -63,6 +71,16 @@ val ocamlc_opt_exit_status : Variables.t val ocamlopt_opt_exit_status : Variables.t +val ocamlrunparam : Variables.t + val ocamlsrcdir : Variables.t val os_type : Variables.t + +val ocamldoc_flags : Variables.t +val ocamldoc_backend : Variables.t +val ocamldoc_exit_status : Variables.t +val ocamldoc_output : Variables.t +val ocamldoc_reference : Variables.t + +val plugins: Variables.t diff --git a/ocamltest/ocamltest_config.ml.in b/ocamltest/ocamltest_config.ml.in index 8c0fab187f..1ddbd204fa 100644 --- a/ocamltest/ocamltest_config.ml.in +++ b/ocamltest/ocamltest_config.ml.in @@ -17,7 +17,7 @@ let arch = "@@ARCH@@" -let afl_support = @@AFL_SUPPORT@@ +let afl_instrument = @@AFL_INSTRUMENT@@ let shared_libraries = @@SHARED_LIBRARIES@@ @@ -39,3 +39,5 @@ let ocamlopt_default_flags = "@@OCAMLOPTDEFAULTFLAGS@@" let safe_string = @@FORCE_SAFE_STRING@@ let flat_float_array = @@FLAT_FLOAT_ARRAY@@ + +let ocamldoc = @@OCAMLDOC@@ diff --git a/ocamltest/ocamltest_config.mli b/ocamltest/ocamltest_config.mli index aabc419ec2..df234c9378 100644 --- a/ocamltest/ocamltest_config.mli +++ b/ocamltest/ocamltest_config.mli @@ -18,7 +18,7 @@ val arch : string (** Architecture for the native compiler, "none" if it is disabled *) -val afl_support : bool +val afl_instrument : bool (** Whether AFL support has been enabled in the compiler *) val shared_libraries : bool @@ -53,3 +53,6 @@ val safe_string : bool val flat_float_array : bool (* Whether the compiler was configured with -flat-float-array *) + +val ocamldoc: bool +(** Whether ocamldoc has been enabled at configure time *) diff --git a/ocamltest/ocamltest_stdlib.ml b/ocamltest/ocamltest_stdlib.ml index a114ecef6a..cabc62db82 100644 --- a/ocamltest/ocamltest_stdlib.ml +++ b/ocamltest/ocamltest_stdlib.ml @@ -155,6 +155,9 @@ module Sys = struct end end + let force_remove file = + if file_exists file then remove file + let with_chdir path f = let oldcwd = Sys.getcwd () in Sys.chdir path; @@ -165,6 +168,10 @@ module Sys = struct | exception e -> Sys.chdir oldcwd; raise e + + let getenv_with_default_value variable default_value = + try Sys.getenv variable with Not_found -> default_value + let safe_getenv variable = getenv_with_default_value variable "" end module StringSet = struct diff --git a/ocamltest/ocamltest_stdlib.mli b/ocamltest/ocamltest_stdlib.mli index e7833d10c8..8fbee1a0b0 100644 --- a/ocamltest/ocamltest_stdlib.mli +++ b/ocamltest/ocamltest_stdlib.mli @@ -50,7 +50,10 @@ module Sys : sig val make_directory : string -> unit val string_of_file : string -> string val copy_file : string -> string -> unit + val force_remove : string -> unit val with_chdir : string -> (unit -> 'a) -> 'a + val getenv_with_default_value : string -> string -> string + val safe_getenv : string -> string end module StringSet : sig diff --git a/ocamltest/variables.ml b/ocamltest/variables.ml index 834b2a5d93..e321bf8432 100644 --- a/ocamltest/variables.ml +++ b/ocamltest/variables.ml @@ -13,11 +13,16 @@ (* *) (**************************************************************************) -(* Definition of environment variabless *) +(* Definition of environment variables *) + +type value = string + +type exporter = value -> string type t = { variable_name : string; - variable_description : string + variable_description : string; + variable_exporter : exporter } let compare v1 v2 = String.compare v1.variable_name v2.variable_name @@ -28,10 +33,20 @@ exception Variable_already_registered exception No_such_variable of string +let default_exporter varname value = Printf.sprintf "%s=%s" varname value + let make (name, description) = if name="" then raise Empty_variable_name else { variable_name = name; - variable_description = description + variable_description = description; + variable_exporter = default_exporter name + } + +let make_with_exporter exporter (name, description) = + if name="" then raise Empty_variable_name else { + variable_name = name; + variable_description = description; + variable_exporter = exporter } let name_of_variable v = v.variable_name @@ -48,3 +63,6 @@ let register_variable variable = let find_variable variable_name = try Some (Hashtbl.find variables variable_name) with Not_found -> None + +let string_of_binding variable value = + variable.variable_exporter value diff --git a/ocamltest/variables.mli b/ocamltest/variables.mli index 17487eef2f..f5a23a930a 100644 --- a/ocamltest/variables.mli +++ b/ocamltest/variables.mli @@ -13,7 +13,11 @@ (* *) (**************************************************************************) -(* Definition of environment variabless *) +(* Definition of environment variables *) + +type value = string + +type exporter = value -> string type t @@ -27,6 +31,8 @@ exception No_such_variable of string val make : string * string -> t +val make_with_exporter : exporter -> string * string -> t + val name_of_variable : t -> string val description_of_variable : t -> string @@ -34,3 +40,5 @@ val description_of_variable : t -> string val register_variable : t -> unit val find_variable : string -> t option + +val string_of_binding : t -> value -> string diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 8c8c3ae47e..ffe26fdcdc 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -43,6 +43,7 @@ COMPILEROBJS=\ ../../utils/arg_helper.cmo ../../utils/clflags.cmo \ ../../utils/tbl.cmo ../../utils/consistbl.cmo \ ../../utils/terminfo.cmo ../../utils/warnings.cmo \ + ../../utils/build_path_prefix_map.cmo \ ../../parsing/asttypes.cmi \ ../../parsing/location.cmo ../../parsing/longident.cmo \ ../../parsing/docstrings.cmo ../../parsing/syntaxerr.cmo \ diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 19b21662ad..a5d295d552 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -24,15 +24,13 @@ marshal.cmx : mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi mutex.cmi : -stdlib.cmo : unix.cmi marshal.cmo stdlib.cmi -stdlib.cmx : unix.cmx marshal.cmx stdlib.cmi -stdlib.cmi : marshal.cmo -thread.cmo : unix.cmi thread.cmi +stdlib.cmo : unix.cmo marshal.cmo +stdlib.cmx : unix.cmx marshal.cmx +thread.cmo : unix.cmo thread.cmi thread.cmx : unix.cmx thread.cmi -thread.cmi : unix.cmi -threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi +thread.cmi : unix.cmo +threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi -threadUnix.cmi : unix.cmi -unix.cmo : unix.cmi -unix.cmx : unix.cmi -unix.cmi : +threadUnix.cmi : unix.cmo +unix.cmo : +unix.cmx : diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 2fdfb75830..ae322e3238 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -107,7 +107,7 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam, break; } caml_gr_handle_event(msg, wParam, lParam); - return DefWindowProc(hwnd, msg, wParam, lParam); + return DefWindowProcA(hwnd, msg, wParam, lParam); } int DoRegisterClass(void) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 31ee17eb9b..32e5f8fcfd 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -19,7 +19,6 @@ open Ast_iterator let err = Syntaxerr.ill_formed_ast let empty_record loc = err loc "Records cannot be empty." -let empty_variant loc = err loc "Variant types cannot be empty." let invalid_tuple loc = err loc "Tuples must have at least 2 components." let no_args loc = err loc "Function application with no argument." let empty_let loc = err loc "Let with no bindings." @@ -41,7 +40,6 @@ let iterator = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_record [] -> empty_record loc - | Ptype_variant [] -> empty_variant loc | _ -> () in let typ self ty = diff --git a/parsing/location.ml b/parsing/location.ml index ad63bfe226..1de9deb011 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -229,9 +229,32 @@ let rec highlight_locations ppf locs = open Format +let rewrite_absolute_path = + let init = ref false in + let map_cache = ref None in + fun path -> + if not !init then begin + init := true; + match Sys.getenv "BUILD_PATH_PREFIX_MAP" with + | exception Not_found -> () + | encoded_map -> + match Build_path_prefix_map.decode_map encoded_map with + | Error err -> + Misc.fatal_errorf + "Invalid value for the environment variable \ + BUILD_PATH_PREFIX_MAP: %s" err + | Ok map -> map_cache := Some map + end; + match !map_cache with + | None -> path + | Some map -> Build_path_prefix_map.rewrite map path + let absolute_path s = (* This function could go into Filename *) let open Filename in - let s = if is_relative s then concat (Sys.getcwd ()) s else s in + let s = + if not (is_relative s) then s + else (rewrite_absolute_path (concat (Sys.getcwd ()) s)) + in (* Now simplify . and .. components *) let rec aux s = let base = basename s in diff --git a/parsing/location.mli b/parsing/location.mli index 516b47de06..bf93f1683c 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -55,6 +55,7 @@ val input_lexbuf: Lexing.lexbuf option ref val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) val print_loc: formatter -> t -> unit +val print_error_prefix: formatter -> unit val print_error: formatter -> t -> unit val print_error_cur_file: formatter -> unit -> unit val print_warning: t -> formatter -> Warnings.t -> unit @@ -88,6 +89,11 @@ val print: formatter -> t -> unit val print_compact: formatter -> t -> unit val print_filename: formatter -> string -> unit +val rewrite_absolute_path: string -> string + (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP + variable (https://reproducible-builds.org/specs/build-path-prefix-map/) + if it is set. *) + val absolute_path: string -> string val show_filename: string -> string diff --git a/parsing/parser.mly b/parsing/parser.mly index d15b5fa120..6e6e3578ab 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -2025,7 +2025,8 @@ type_parameter_list: | type_parameter_list COMMA type_parameter { $3 :: $1 } ; constructor_declarations: - constructor_declaration { [$1] } + | BAR { [ ] } + | constructor_declaration { [$1] } | bar_constructor_declaration { [$1] } | constructor_declarations bar_constructor_declaration { $2 :: $1 } ; diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 7ce5d459e4..1052f631a1 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -409,7 +409,6 @@ and type_declaration = and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) | Ptype_record of label_declaration list (* Invariant: non-empty list *) | Ptype_open diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index f564ba3a0a..91387381da 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1405,8 +1405,10 @@ and type_declaration ctxt f x = in match x.ptype_kind with | Ptype_variant xs -> - pp f "%t%t@\n%a" intro priv - (list ~sep:"@\n" constructor_declaration) xs + let variants fmt xs = + if xs = [] then pp fmt " |" else + pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs + in pp f "%t%t%a" intro priv variants xs | Ptype_abstract -> () | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l diff --git a/stdlib/Makefile b/stdlib/Makefile index 9f897cabdf..572249ed60 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -59,11 +59,11 @@ PREFIXED_OBJS=$(filter stdlib__%.cmo,$(OBJS)) all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur ifeq "$(RUNTIMED)" "true" -all: camlheaderd +all: camlheaderd target_camlheaderd endif ifeq "$(RUNTIMEI)" "true" -all: camlheaderi +all: camlheaderi target_camlheaderi endif ifeq "$(PROFILING)" "true" @@ -161,27 +161,36 @@ else # Windows # TODO: see whether there is a way to further merge the rules below # with those above -camlheader target_camlheader camlheader_ur: headernt.c +camlheader: headernt.c $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \ -DRUNTIME_NAME='"ocamlrun"' $(OUTPUTOBJ)headernt.$(O) $< $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) rm -f camlheader.exe mv tmpheader.exe camlheader + +target_camlheader: camlheader cp camlheader target_camlheader + +camlheader_ur: camlheader cp camlheader camlheader_ur -camlheaderd target_camlheaderd: headernt.c +camlheaderd: headernt.c $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \ - -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headernt.$(O) $< - $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) - mv tmpheader.exe camlheaderd + -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headerntd.$(O) $< + $(MKEXE) -o tmpheaderd.exe headerntd.$(O) $(EXTRALIBS) + mv tmpheaderd.exe camlheaderd + +target_camlheaderd: camlheaderd cp camlheaderd target_camlheaderd camlheaderi: headernt.c $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \ - -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernt.$(O) - $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) - mv tmpheader.exe camlheaderi + -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernti.$(O) $< + $(MKEXE) -o tmpheaderi.exe headernti.$(O) $(EXTRALIBS) + mv tmpheaderi.exe camlheaderi + +target_camlheaderi: camlheaderi + cp camlheaderi target_camlheaderi # TODO: do not call flexlink to build tmpheader.exe (we don't need # the export table) diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index 97ef1fe9ca..4407f8bbbe 100644 --- a/stdlib/stdlib.mli +++ b/stdlib/stdlib.mli @@ -275,9 +275,9 @@ external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" (** {1 Integer arithmetic} *) -(** Integers are 31 bits wide (or 63 bits on 64-bit processors). - All operations are taken modulo 2{^31} (or 2{^63}). - They do not fail on overflow. *) +(** Integers are [Sys.int_size] bits wide. + All operations are taken modulo 2{^[Sys.int_size]}. + They do not fail on overflow. *) external ( ~- ) : int -> int = "%negint" (** Unary negation. You can also write [- e] instead of [~- e]. @@ -358,23 +358,21 @@ val lnot : int -> int external ( lsl ) : int -> int -> int = "%lslint" (** [n lsl m] shifts [n] to the left by [m] bits. - The result is unspecified if [m < 0] or [m >= bitsize], - where [bitsize] is [32] on a 32-bit platform and - [64] on a 64-bit platform. - Right-associative operator at precedence level 8/11. *) + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator at precedence level 8/11. *) external ( lsr ) : int -> int -> int = "%lsrint" (** [n lsr m] shifts [n] to the right by [m] bits. - This is a logical shift: zeroes are inserted regardless of - the sign of [n]. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. *) + This is a logical shift: zeroes are inserted regardless of + the sign of [n]. + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator at precedence level 8/11. *) external ( asr ) : int -> int -> int = "%asrint" (** [n asr m] shifts [n] to the right by [m] bits. - This is an arithmetic shift: the sign bit of [n] is replicated. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. *) + This is an arithmetic shift: the sign bit of [n] is replicated. + The result is unspecified if [m < 0] or [m > Sys.int_size]. + Right-associative operator at precedence level 8/11. *) (** {1 Floating-point arithmetic} diff --git a/stdlib/string.ml b/stdlib/string.ml index 9a4b533fcf..84fd3d22a5 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -101,17 +101,13 @@ let trim s = else s let escaped s = - let rec needs_escape i = - if i >= length s then false else + let rec escape_if_needed s n i = + if i >= n then s else match unsafe_get s i with - | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> true - | ' ' .. '~' -> needs_escape (i+1) - | _ -> true + | '\"' | '\\' | '\000'..'\031' | '\127'.. '\255' -> bts (B.escaped (bos s)) + | _ -> escape_if_needed s n (i+1) in - if needs_escape 0 then - bts (B.escaped (bos s)) - else - s + escape_if_needed s (length s) 0 (* duplicated in bytes.ml *) let rec index_rec s lim i c = diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 3c86a14473..228849501d 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -27,7 +27,10 @@ val argv : string array given to the program. *) val executable_name : string -(** The name of the file containing the executable currently running. *) +(** The name of the file containing the executable currently running. + This name may be absolute or relative to the current directory, depending + on the platform and whether the program was compiled to bytecode or a native + executable. *) external file_exists : string -> bool = "caml_sys_file_exists" (** Test if a file with the given name exists. *) @@ -126,13 +129,12 @@ val cygwin : bool val word_size : int (** Size of one word on the machine currently executing the OCaml - program, in bits: 32 or 64. *) + program, in bits: 32 or 64. *) val int_size : int -(** Size of an int. It is 31 bits (resp. 63 bits) when using the - OCaml compiler on a 32 bits (resp. 64 bits) platform. It may - differ for other compilers, e.g. it is 32 bits when compiling to - JavaScript. +(** Size of [int], in bits. It is 31 (resp. 63) when using OCaml on a + 32-bit (resp. 64-bit) platform. It may differ for other implementations, + e.g. it can be 32 bits when compiling to JavaScript. @since 4.03.0 *) val big_endian : bool diff --git a/testsuite/Makefile b/testsuite/Makefile index 74c3755d8d..09445ae618 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -48,7 +48,7 @@ ocamltest_program := $(or \ $(wildcard $(ocamltest_directory)/ocamltest.opt$(EXE)),\ $(wildcard $(ocamltest_directory)/ocamltest$(EXE))) -ocamltest := $(FLEXLINK_PREFIX) $(ocamltest_program) +ocamltest := $(FLEXLINK_PREFIX) SORT=$(SORT) $(ocamltest_program) .PHONY: default default: diff --git a/testsuite/tests/afl-instrumentation/Makefile b/testsuite/tests/afl-instrumentation/Makefile deleted file mode 100644 index a2dfcd8021..0000000000 --- a/testsuite/tests/afl-instrumentation/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -BASEDIR=../.. - -default: - @printf " ... testing 'afl_instrumentation':" - @if ! which afl-showmap > /dev/null; then \ - echo " => skipped (afl-showmap unavailable)"; \ - elif $(BYTECODE_ONLY); then \ - echo " => skipped (bytecode only)"; \ - else \ - if OCAMLOPT='$(OCAMLOPT)' ./test.sh > /dev/null; then \ - echo " => passed"; \ - else \ - echo " => failed"; \ - fi \ - fi - -include $(BASEDIR)/makefiles/Makefile.common - -clean: defaultclean diff --git a/testsuite/tests/afl-instrumentation/afl-showmap-available b/testsuite/tests/afl-instrumentation/afl-showmap-available new file mode 100644 index 0000000000..27396415ee --- /dev/null +++ b/testsuite/tests/afl-instrumentation/afl-showmap-available @@ -0,0 +1,7 @@ +#!/bin/sh +if ! which afl-showmap > /dev/null 2>&1; then + echo "afl-showmap not available" > ${ocamltest_response} + exit ${TEST_SKIP} +else + exit ${TEST_PASS} +fi diff --git a/testsuite/tests/afl-instrumentation/afltest.ml b/testsuite/tests/afl-instrumentation/afltest.ml new file mode 100644 index 0000000000..fcad800418 --- /dev/null +++ b/testsuite/tests/afl-instrumentation/afltest.ml @@ -0,0 +1,17 @@ +(* TEST (* Just a test-driver *) + * native-compiler + ** no-afl-instrument + *** script + script = "sh ${test_source_directory}/afl-showmap-available" + files = "harness.ml test.ml" + **** setup-ocamlopt.byte-build-env + ***** ocamlopt.byte + module = "test.ml" + flags = "-afl-instrument" + ****** ocamlopt.byte + module = "" + program = "${test_build_directory}/test" + flags = "-afl-inst-ratio 0" + all_modules = "test.cmx harness.ml" + ******* run +*) diff --git a/testsuite/tests/afl-instrumentation/test.sh b/testsuite/tests/afl-instrumentation/afltest.run index 804db5f210..eb49514517 100755 --- a/testsuite/tests/afl-instrumentation/test.sh +++ b/testsuite/tests/afl-instrumentation/afltest.run @@ -2,8 +2,8 @@ set -e -$OCAMLOPT -c -afl-instrument test.ml -$OCAMLOPT -afl-inst-ratio 0 test.cmx harness.ml -o test +output="${program}".output +exec > ${output} 2>&1 NTESTS=`./test len` failures='' @@ -28,6 +28,9 @@ for t in `seq 1 $NTESTS`; do fi done -if [ -z "$failures" ]; then echo "all tests passed"; else exit 1; fi - -rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted} +if [ -z "$failures" ]; then + echo "all tests passed"; + exit ${TEST_PASS} +else + exit ${TEST_FAIL}; +fi diff --git a/testsuite/tests/afl-instrumentation/ocamltests b/testsuite/tests/afl-instrumentation/ocamltests new file mode 100644 index 0000000000..99ac64b6c8 --- /dev/null +++ b/testsuite/tests/afl-instrumentation/ocamltests @@ -0,0 +1 @@ +afltest.ml diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile deleted file mode 100644 index 0eb8e285ba..0000000000 --- a/testsuite/tests/asmcomp/Makefile +++ /dev/null @@ -1,87 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. - -include $(BASEDIR)/../config/Makefile - -default: - @if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \ - $(MAKE) all; \ - fi - -all: - @$(MAKE) tests - -MLCASES=optargs staticalloc bind_tuples is_static register_typing \ - register_typing_switch -ARGS_optargs=-g -ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c -MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 -MLCASES_FLAMBDA_FLOAT=static_float_array_flambda \ - static_float_array_flambda_opaque -ARGS_is_static_flambda=\ - -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml -ARGS_static_float_array_flambda=\ - -I $(OTOPDIR)/byterun is_in_static_data.c simple_float_const.ml -ARGS_static_float_array_flambda_opaque=\ - -I $(OTOPDIR)/byterun is_in_static_data.c -opaque simple_float_const_opaque.ml - -ARGS_staticalloc=-I $(OTOPDIR)/utils config.cmx - -skips: - @for c in $(MLCASES) $(MLCASES_FLAMBDA) $(MLCASES_FLAMBDA_FLOAT); do \ - echo " ... testing '$$c': => skipped"; \ - done - -one_ml: - @$(OCAMLOPT) -I $(OTOPDIR)/byterun $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \ - ./$(NAME).exe && echo " => passed" || echo " => failed" - -one_ml_cond: - @if $(COND); then \ - $(OCAMLOPT) -I $(OTOPDIR)/byterun $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \ - ./$(NAME).exe && echo " => passed" || echo " => failed"; \ - else \ - echo " => skipped"; \ - fi - -clean: defaultclean - -include $(BASEDIR)/makefiles/Makefile.common - -ifeq "$(WITH_SPACETIME)" "true" -# These tests have not been ported for Spacetime -SKIP=true -else -SKIP=false -endif - -tests: - @for c in $(MLCASES); do \ - printf " ... testing '$$c':"; \ - $(MAKE) one_ml NAME=$$c; \ - done - @for c in $(MLCASES_FLAMBDA); do \ - printf " ... testing '$$c':"; \ - $(MAKE) one_ml_cond NAME=$$c COND=$(FLAMBDA); \ - done - @for c in $(MLCASES_FLAMBDA_FLOAT); do \ - printf " ... testing '$$c':"; \ - $(MAKE) one_ml_cond NAME=$$c \ - COND='$(FLAMBDA) && $(FLAT_FLOAT_ARRAY)'; \ - done - -promote: diff --git a/testsuite/tests/asmcomp/bind_tuples.ml b/testsuite/tests/asmcomp/bind_tuples.ml index 01c2f825b5..156b08721e 100755..100644 --- a/testsuite/tests/asmcomp/bind_tuples.ml +++ b/testsuite/tests/asmcomp/bind_tuples.ml @@ -1,3 +1,7 @@ +(* TEST + * native +*) + (* Check the effectiveness of optimized compilation of tuple binding Ref: http://caml.inria.fr/mantis/view.php?id=4800 diff --git a/testsuite/tests/asmcomp/is_static.ml b/testsuite/tests/asmcomp/is_static.ml index bedc033dfe..602636920e 100644 --- a/testsuite/tests/asmcomp/is_static.ml +++ b/testsuite/tests/asmcomp/is_static.ml @@ -1,3 +1,8 @@ +(* TEST + modules = "is_in_static_data.c" + * native +*) + (* Data that should be statically allocated by the compiler (all versions) *) external is_in_static_data : 'a -> bool = "caml_is_in_static_data" diff --git a/testsuite/tests/asmcomp/is_static_flambda.ml b/testsuite/tests/asmcomp/is_static_flambda.ml index 94e0519b2b..de395c6995 100644 --- a/testsuite/tests/asmcomp/is_static_flambda.ml +++ b/testsuite/tests/asmcomp/is_static_flambda.ml @@ -1,3 +1,9 @@ +(* TEST + modules = "is_in_static_data.c is_static_flambda_dep.ml" + * flambda + ** native +*) + (* Data that should be statically allocated by the compiler (flambda only) *) external is_in_static_data : 'a -> bool = "caml_is_in_static_data" @@ -185,7 +191,7 @@ module Int = struct type t = int let compare (a:int) b = compare a b end -module IntMap = (Map.Make [@inlined])(Int) +module IntMap = Map.Make (Int) let () = let f () = diff --git a/testsuite/tests/asmcomp/ocamltests b/testsuite/tests/asmcomp/ocamltests new file mode 100644 index 0000000000..bcd126dfe5 --- /dev/null +++ b/testsuite/tests/asmcomp/ocamltests @@ -0,0 +1,11 @@ +bind_tuples.ml +is_static_flambda.ml +is_static.ml +optargs.ml +register_typing.ml +register_typing_switch.ml +staticalloc.ml +static_float_array_flambda.ml +static_float_array_flambda_opaque.ml +unrolling_flambda2.ml +unrolling_flambda.ml diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml index 92705bd25e..ccc27dcbd9 100644 --- a/testsuite/tests/asmcomp/optargs.ml +++ b/testsuite/tests/asmcomp/optargs.ml @@ -1,14 +1,8 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2014 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(* TEST + flags = "-g" + compare_programs = "false" + * native +*) (* Check the effectiveness of inlining the wrapper which fills in default values for optional arguments. diff --git a/testsuite/tests/asmcomp/register_typing.ml b/testsuite/tests/asmcomp/register_typing.ml index 9d55d29ba0..af8501c196 100644 --- a/testsuite/tests/asmcomp/register_typing.ml +++ b/testsuite/tests/asmcomp/register_typing.ml @@ -1,3 +1,7 @@ +(* TEST + * native +*) + type 'a typ = Int : int typ | Ptr : int list typ let f (type a) (t : a typ) (p : int list) : a = diff --git a/testsuite/tests/asmcomp/register_typing_switch.ml b/testsuite/tests/asmcomp/register_typing_switch.ml index 18c4416de4..a5cfe3f8c0 100644 --- a/testsuite/tests/asmcomp/register_typing_switch.ml +++ b/testsuite/tests/asmcomp/register_typing_switch.ml @@ -1,3 +1,7 @@ +(* TEST + * native +*) + type 'a typ = Int : int typ | Ptr : int list typ | Int2 : int typ let f (type a) (t : a typ) (p : int list) : a = diff --git a/testsuite/tests/asmcomp/static_float_array_flambda.ml b/testsuite/tests/asmcomp/static_float_array_flambda.ml index f60e530aa1..8401ca1eed 100644 --- a/testsuite/tests/asmcomp/static_float_array_flambda.ml +++ b/testsuite/tests/asmcomp/static_float_array_flambda.ml @@ -1,3 +1,10 @@ +(* TEST + modules = "is_in_static_data.c simple_float_const.ml" + * flambda + ** flat-float-array + *** native +*) + external is_in_static_data : 'a -> bool = "caml_is_in_static_data" let a = [|0.; 1.|] diff --git a/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml index 518f48bc01..63c08c1b0d 100644 --- a/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml +++ b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml @@ -1,3 +1,11 @@ +(* TEST + modules = "is_in_static_data.c simple_float_const_opaque.ml" + flags = "-opaque" + * flambda + ** flat-float-array + *** native +*) + external is_in_static_data : 'a -> bool = "caml_is_in_static_data" let a = [|0.; 1.|] diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml index 0d5956f332..2092ecc694 100644 --- a/testsuite/tests/asmcomp/staticalloc.ml +++ b/testsuite/tests/asmcomp/staticalloc.ml @@ -1,14 +1,8 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2014 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(* TEST + include config + * native + flags = "config.cmx" +*) (* Check the effectiveness of structured constant propagation and static allocation. diff --git a/testsuite/tests/asmcomp/unrolling_flambda.ml b/testsuite/tests/asmcomp/unrolling_flambda.ml index 59dfa2a98a..dcfcb03303 100644 --- a/testsuite/tests/asmcomp/unrolling_flambda.ml +++ b/testsuite/tests/asmcomp/unrolling_flambda.ml @@ -1,3 +1,7 @@ +(* TEST + * flambda + ** native +*) let rec f x = if x > 0 then f (x - 1) diff --git a/testsuite/tests/asmcomp/unrolling_flambda2.ml b/testsuite/tests/asmcomp/unrolling_flambda2.ml index cccda47d86..3079b7327e 100644 --- a/testsuite/tests/asmcomp/unrolling_flambda2.ml +++ b/testsuite/tests/asmcomp/unrolling_flambda2.ml @@ -1,3 +1,7 @@ +(* TEST + * flambda + ** native +*) type t = { fn : t -> t -> int -> unit -> unit } diff --git a/testsuite/tests/asmgen/lexcmm.mll b/testsuite/tests/asmgen/lexcmm.mll index 6c705413b7..889cc8bd0c 100644 --- a/testsuite/tests/asmgen/lexcmm.mll +++ b/testsuite/tests/asmgen/lexcmm.mll @@ -164,6 +164,10 @@ rule token = parse | "!=a" { NEA } | "!=f" { NEF } | "!=" { NEI } + | "!>=f" { NGEF } + | "!>f" { NGTF } + | "!<=f" { NLEF } + | "!<f" { NLTF } | "]" { RBRACKET } | ")" { RPAREN } | "-f" { SUBF } diff --git a/testsuite/tests/asmgen/parsecmm.mly b/testsuite/tests/asmgen/parsecmm.mly index 548d5ceff5..f3d3fdbd84 100644 --- a/testsuite/tests/asmgen/parsecmm.mly +++ b/testsuite/tests/asmgen/parsecmm.mly @@ -100,6 +100,10 @@ let access_array base numelt size = %token NEA %token NEF %token NEI +%token NGEF +%token NGTF +%token NLEF +%token NLTF %token OR %token <int> POINTER %token PROJ @@ -293,12 +297,16 @@ binaryop: | ADDF { Caddf } | MULF { Cmulf } | DIVF { Cdivf } - | EQF { Ccmpf Ceq } - | NEF { Ccmpf Cne } - | LTF { Ccmpf Clt } - | LEF { Ccmpf Cle } - | GTF { Ccmpf Cgt } - | GEF { Ccmpf Cge } + | EQF { Ccmpf CFeq } + | NEF { Ccmpf CFneq } + | LTF { Ccmpf CFlt } + | NLTF { Ccmpf CFnlt } + | LEF { Ccmpf CFle } + | NLEF { Ccmpf CFnle } + | GTF { Ccmpf CFgt } + | NGTF { Ccmpf CFngt } + | GEF { Ccmpf CFge } + | NGEF { Ccmpf CFnge } | CHECKBOUND { Ccheckbound } | MULH { Cmulhi } ; diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile deleted file mode 100644 index b398c0c2c9..0000000000 --- a/testsuite/tests/backtrace/Makefile +++ /dev/null @@ -1,156 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -EXECNAME=program$(EXE) - -ABCDFILES=backtrace.ml -OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \ - backtrace_deprecated.ml backtrace_slots.ml backtrace_effects.ml \ - backtrace_effects_nested.ml -INLININGFILES=inline_test.ml inline_traversal_test.ml -OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml -OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml - -# Keep only filenames, lines and character ranges -LOCATIONFILTER=grep -oE \ - '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+' - -default: - @$(MAKE) byte - @if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi - -.PHONY: byte -byte: - @for file in $(ABCDFILES); do \ - rm -f program program.exe; \ - $(OCAMLC) -g -o $(EXECNAME) $$file; \ - for arg in a b c d ''; do \ - printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - $(OCAMLRUN) $(EXECNAME) $$arg || true) \ - >$$F.$$arg.byte.result 2>&1; \ - $(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; \ - done - @for file in $(OTHERFILES) $(OTHERFILESNOINLINING); do \ - rm -f program program.exe; \ - $(OCAMLC) -g -o $(EXECNAME) $$file; \ - printf " ... testing '$$file' with ocamlc:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - $(OCAMLRUN) $(EXECNAME) $$arg || true) \ - >$$F.byte.result 2>&1; \ - $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; - @for file in $(INLININGFILES); \ - do \ - rm -f program program.exe; \ - $(OCAMLC) -g -o $(EXECNAME) $$file; \ - printf " ... testing '$$file' with ocamlc:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - $(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \ - | $(LOCATIONFILTER) >$$F.byte.result 2>&1; \ - $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done - -.PHONY: skip -skip: - @for file in $(ABCDFILES); do \ - for arg in a b c d ''; do \ - echo " ... testing '$$file' with ocamlopt and argument '$$arg': \ - => skipped"; \ - done; \ - done - @for file in $(OTHERFILES) $(OTHERFILESNOINLINING) \ - $(OTHERFILESNOINLINING_NATIVE) $(INLININGFILES); do \ - echo " ... testing '$$file' with ocamlopt: => skipped"; \ - done - -.PHONY: native -native: - @for file in $(ABCDFILES); do \ - rm -f program program.exe; \ - $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ - for arg in a b c d ''; do \ - printf " ... testing '$$file' with ocamlopt and argument '$$arg':";\ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - ./$(EXECNAME) $$arg || true) \ - >$$F.$$arg.native.result 2>&1; \ - $(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result \ - >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; \ - done - @for file in $(OTHERFILES); do \ - rm -f program program.exe; \ - $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ - printf " ... testing '$$file' with ocamlopt:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - ./$(EXECNAME) $$arg || true) \ - >$$F.native.result 2>&1; \ - $(DIFF) $$F.native.reference $$F.native.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; - @for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \ - do \ - rm -f program program.exe; \ - $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ - printf " ... testing '$$file' with ocamlopt:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - ./$(EXECNAME) $$arg || true) \ - >$$F.native.result 2>&1; \ - $(DIFF) $$F.native.reference $$F.native.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; - @for file in $(INLININGFILES); \ - do \ - rm -f program program.exe; \ - $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ - printf " ... testing '$$file' with ocamlopt:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - ./$(EXECNAME) $$arg 2>&1 || true) \ - | $(LOCATIONFILTER) >$$F.native.result; \ - $(DIFF) $$F.native.reference $$F.native.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - rm -f program program.exe; \ - $(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \ - printf " ... testing '$$file' with ocamlopt -O3:"; \ - F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ - ./$(EXECNAME) $$arg 2>&1 || true) \ - | $(LOCATIONFILTER) >$$F.O3.result; \ - $(DIFF) $$F.native.reference $$F.O3.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done - - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result program program.exe - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/backtrace/backtrace..byte.reference b/testsuite/tests/backtrace/backtrace..byte.reference deleted file mode 100644 index d2d693377e..0000000000 --- a/testsuite/tests/backtrace/backtrace..byte.reference +++ /dev/null @@ -1,2 +0,0 @@ -Fatal error: exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24 diff --git a/testsuite/tests/backtrace/backtrace..native.reference b/testsuite/tests/backtrace/backtrace..native.reference deleted file mode 100644 index d2d693377e..0000000000 --- a/testsuite/tests/backtrace/backtrace..native.reference +++ /dev/null @@ -1,2 +0,0 @@ -Fatal error: exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24 diff --git a/testsuite/tests/backtrace/backtrace.a.byte.reference b/testsuite/tests/backtrace/backtrace.a.byte.reference deleted file mode 100644 index 7898192261..0000000000 --- a/testsuite/tests/backtrace/backtrace.a.byte.reference +++ /dev/null @@ -1 +0,0 @@ -a diff --git a/testsuite/tests/backtrace/backtrace.a.native.reference b/testsuite/tests/backtrace/backtrace.a.native.reference deleted file mode 100644 index 7898192261..0000000000 --- a/testsuite/tests/backtrace/backtrace.a.native.reference +++ /dev/null @@ -1 +0,0 @@ -a diff --git a/testsuite/tests/backtrace/backtrace.b.byte.reference b/testsuite/tests/backtrace/backtrace.b.byte.reference deleted file mode 100644 index 4737589602..0000000000 --- a/testsuite/tests/backtrace/backtrace.b.byte.reference +++ /dev/null @@ -1,11 +0,0 @@ -b -Fatal error: exception Backtrace.Error("b") -Raised at file "backtrace.ml", line 7, characters 21-32 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 11, characters 4-11 -Re-raised at file "backtrace.ml", line 13, characters 68-71 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.b.native.reference b/testsuite/tests/backtrace/backtrace.b.native.reference deleted file mode 100644 index f1e8da8744..0000000000 --- a/testsuite/tests/backtrace/backtrace.b.native.reference +++ /dev/null @@ -1,11 +0,0 @@ -b -Fatal error: exception Backtrace.Error("b") -Raised at file "backtrace.ml", line 7, characters 16-32 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 11, characters 4-11 -Re-raised at file "backtrace.ml", line 13, characters 62-71 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.byte.reference b/testsuite/tests/backtrace/backtrace.byte.reference new file mode 100644 index 0000000000..224f5fd916 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace.byte.reference @@ -0,0 +1,26 @@ +a +b +Fatal error: exception Backtrace.Error("b") +Raised at file "backtrace.ml", line 16, characters 21-32 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 20, characters 4-11 +Re-raised at file "backtrace.ml", line 22, characters 68-71 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Backtrace.Error("c") +Raised at file "backtrace.ml", line 23, characters 26-37 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Backtrace.Error("d") +Raised at file "backtrace.ml", line 16, characters 21-32 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 20, characters 4-11 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace.ml", line 27, characters 12-24 diff --git a/testsuite/tests/backtrace/backtrace.c.byte.reference b/testsuite/tests/backtrace/backtrace.c.byte.reference deleted file mode 100644 index 33cac47427..0000000000 --- a/testsuite/tests/backtrace/backtrace.c.byte.reference +++ /dev/null @@ -1,3 +0,0 @@ -Fatal error: exception Backtrace.Error("c") -Raised at file "backtrace.ml", line 14, characters 26-37 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.c.native.reference b/testsuite/tests/backtrace/backtrace.c.native.reference deleted file mode 100644 index 431cd54668..0000000000 --- a/testsuite/tests/backtrace/backtrace.c.native.reference +++ /dev/null @@ -1,3 +0,0 @@ -Fatal error: exception Backtrace.Error("c") -Raised at file "backtrace.ml", line 14, characters 20-37 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.d.byte.reference b/testsuite/tests/backtrace/backtrace.d.byte.reference deleted file mode 100644 index 9ba4682482..0000000000 --- a/testsuite/tests/backtrace/backtrace.d.byte.reference +++ /dev/null @@ -1,9 +0,0 @@ -Fatal error: exception Backtrace.Error("d") -Raised at file "backtrace.ml", line 7, characters 21-32 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 11, characters 4-11 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.d.native.reference b/testsuite/tests/backtrace/backtrace.d.native.reference deleted file mode 100644 index d074040c45..0000000000 --- a/testsuite/tests/backtrace/backtrace.d.native.reference +++ /dev/null @@ -1,9 +0,0 @@ -Fatal error: exception Backtrace.Error("d") -Raised at file "backtrace.ml", line 7, characters 16-32 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 7, characters 42-53 -Called from file "backtrace.ml", line 11, characters 4-11 -Called from file "backtrace.ml", line 18, characters 9-25 diff --git a/testsuite/tests/backtrace/backtrace.ml b/testsuite/tests/backtrace/backtrace.ml index ca4423e99d..6ef8b37c96 100644 --- a/testsuite/tests/backtrace/backtrace.ml +++ b/testsuite/tests/backtrace/backtrace.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/backtrace.byte.reference" + * native + reference = "${test_source_directory}/backtrace.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) diff --git a/testsuite/tests/backtrace/backtrace.opt.reference b/testsuite/tests/backtrace/backtrace.opt.reference new file mode 100644 index 0000000000..42ed766246 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace.opt.reference @@ -0,0 +1,26 @@ +a +b +Fatal error: exception Backtrace.Error("b") +Raised at file "backtrace.ml", line 16, characters 16-32 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 20, characters 4-11 +Re-raised at file "backtrace.ml", line 22, characters 62-71 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Backtrace.Error("c") +Raised at file "backtrace.ml", line 23, characters 20-37 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Backtrace.Error("d") +Raised at file "backtrace.ml", line 16, characters 16-32 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 16, characters 42-53 +Called from file "backtrace.ml", line 20, characters 4-11 +Called from file "backtrace.ml", line 27, characters 9-25 +Fatal error: exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace.ml", line 27, characters 12-24 diff --git a/testsuite/tests/backtrace/backtrace.run b/testsuite/tests/backtrace/backtrace.run new file mode 100644 index 0000000000..a1bbd91ced --- /dev/null +++ b/testsuite/tests/backtrace/backtrace.run @@ -0,0 +1,8 @@ +#!/bin/sh +# Run the backtrace test + +exec > "${output}" 2>&1 + +for arg in a b c d ''; do + "${program}" ${arg} || true +done diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference index dbf1c1e98b..231e7e6097 100644 --- a/testsuite/tests/backtrace/backtrace2.byte.reference +++ b/testsuite/tests/backtrace/backtrace2.byte.reference @@ -2,57 +2,57 @@ a No exception b Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 8, characters 23-34 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 13, characters 4-11 -Re-raised at file "backtrace2.ml", line 15, characters 68-71 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 17, characters 23-34 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 22, characters 4-11 +Re-raised at file "backtrace2.ml", line 24, characters 68-71 +Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 16, characters 26-37 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 25, characters 26-37 +Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 8, characters 23-34 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 13, characters 4-11 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 17, characters 23-34 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 22, characters 4-11 +Called from file "backtrace2.ml", line 67, characters 11-23 e Uncaught exception Backtrace2.Error("e") -Raised at file "backtrace2.ml", line 22, characters 56-59 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 31, characters 56-59 +Called from file "backtrace2.ml", line 67, characters 11-23 f Uncaught exception Backtrace2.Error("f") -Raised at file "backtrace2.ml", line 28, characters 68-71 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 37, characters 68-71 +Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22 +Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22 test_Not_found Uncaught exception Not_found Raised at file "hashtbl.ml", line 194, characters 19-28 -Called from file "backtrace2.ml", line 39, characters 9-42 -Re-raised at file "backtrace2.ml", line 39, characters 67-70 -Called from file "backtrace2.ml", line 58, characters 11-23 +Called from file "backtrace2.ml", line 48, characters 9-42 +Re-raised at file "backtrace2.ml", line 48, characters 67-70 +Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Not_found -Raised at file "backtrace2.ml", line 43, characters 24-33 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "camlinternalLazy.ml", line 40, characters 19-29 -Re-raised at file "camlinternalLazy.ml", line 46, characters 12-13 -Called from file "backtrace2.ml", line 58, characters 11-23 +Raised at file "backtrace2.ml", line 52, characters 24-33 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "camlinternalLazy.ml", line 27, characters 17-27 +Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11 +Called from file "backtrace2.ml", line 67, characters 11-23 Uncaught exception Not_found Raised at file "hashtbl.ml", line 194, characters 19-28 -Called from file "backtrace2.ml", line 46, characters 8-41 -Re-raised at file "camlinternalLazy.ml", line 44, characters 51-52 -Called from file "camlinternalLazy.ml", line 40, characters 19-29 -Re-raised at file "camlinternalLazy.ml", line 46, characters 12-13 -Called from file "backtrace2.ml", line 58, characters 11-23 +Called from file "backtrace2.ml", line 55, characters 8-41 +Re-raised at file "camlinternalLazy.ml", line 33, characters 62-63 +Called from file "camlinternalLazy.ml", line 27, characters 17-27 +Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11 +Called from file "backtrace2.ml", line 67, characters 11-23 diff --git a/testsuite/tests/backtrace/backtrace2.ml b/testsuite/tests/backtrace/backtrace2.ml index 07cf5ccc86..13c85f426c 100644 --- a/testsuite/tests/backtrace/backtrace2.ml +++ b/testsuite/tests/backtrace/backtrace2.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/backtrace2.byte.reference" + * native + reference = "${test_source_directory}/backtrace2.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) diff --git a/testsuite/tests/backtrace/backtrace2.native.reference b/testsuite/tests/backtrace/backtrace2.native.reference deleted file mode 100644 index e766933b09..0000000000 --- a/testsuite/tests/backtrace/backtrace2.native.reference +++ /dev/null @@ -1,58 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 8, characters 18-34 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 13, characters 4-11 -Re-raised at file "backtrace2.ml", line 15, characters 62-71 -Called from file "backtrace2.ml", line 58, characters 11-23 -Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 16, characters 20-37 -Called from file "backtrace2.ml", line 58, characters 11-23 -Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 8, characters 18-34 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 8, characters 44-55 -Called from file "backtrace2.ml", line 13, characters 4-11 -Called from file "backtrace2.ml", line 58, characters 11-23 -e -Uncaught exception Backtrace2.Error("e") -Raised at file "backtrace2.ml", line 22, characters 50-59 -Called from file "backtrace2.ml", line 58, characters 11-23 -f -Uncaught exception Backtrace2.Error("f") -Raised at file "backtrace2.ml", line 28, characters 62-71 -Called from file "backtrace2.ml", line 58, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22 -test_Not_found -Uncaught exception Not_found -Raised at file "hashtbl.ml", line 194, characters 13-28 -Called from file "backtrace2.ml", line 39, characters 9-42 -Re-raised at file "backtrace2.ml", line 39, characters 61-70 -Called from file "backtrace2.ml", line 58, characters 11-23 -Uncaught exception Not_found -Raised at file "backtrace2.ml", line 43, characters 18-33 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "backtrace2.ml", line 43, characters 43-52 -Called from file "camlinternalLazy.ml", line 40, characters 19-29 -Re-raised at file "camlinternalLazy.ml", line 46, characters 6-13 -Called from file "backtrace2.ml", line 58, characters 11-23 -Uncaught exception Not_found -Raised at file "hashtbl.ml", line 194, characters 13-28 -Called from file "backtrace2.ml", line 46, characters 8-41 -Re-raised at file "camlinternalLazy.ml", line 44, characters 45-52 -Called from file "camlinternalLazy.ml", line 40, characters 19-29 -Re-raised at file "camlinternalLazy.ml", line 46, characters 6-13 -Called from file "backtrace2.ml", line 58, characters 11-23 diff --git a/testsuite/tests/backtrace/backtrace2.opt.reference b/testsuite/tests/backtrace/backtrace2.opt.reference new file mode 100644 index 0000000000..cc110b6d34 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace2.opt.reference @@ -0,0 +1,58 @@ +a +No exception +b +Uncaught exception Backtrace2.Error("b") +Raised at file "backtrace2.ml", line 17, characters 18-34 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 22, characters 4-11 +Re-raised at file "backtrace2.ml", line 24, characters 62-71 +Called from file "backtrace2.ml", line 67, characters 11-23 +Uncaught exception Backtrace2.Error("c") +Raised at file "backtrace2.ml", line 25, characters 20-37 +Called from file "backtrace2.ml", line 67, characters 11-23 +Uncaught exception Backtrace2.Error("d") +Raised at file "backtrace2.ml", line 17, characters 18-34 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 17, characters 44-55 +Called from file "backtrace2.ml", line 22, characters 4-11 +Called from file "backtrace2.ml", line 67, characters 11-23 +e +Uncaught exception Backtrace2.Error("e") +Raised at file "backtrace2.ml", line 31, characters 50-59 +Called from file "backtrace2.ml", line 67, characters 11-23 +f +Uncaught exception Backtrace2.Error("f") +Raised at file "backtrace2.ml", line 37, characters 62-71 +Called from file "backtrace2.ml", line 67, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22 +test_Not_found +Uncaught exception Not_found +Raised at file "hashtbl.ml", line 194, characters 13-28 +Called from file "backtrace2.ml", line 48, characters 9-42 +Re-raised at file "backtrace2.ml", line 48, characters 61-70 +Called from file "backtrace2.ml", line 67, characters 11-23 +Uncaught exception Not_found +Raised at file "backtrace2.ml", line 52, characters 18-33 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "backtrace2.ml", line 52, characters 43-52 +Called from file "camlinternalLazy.ml", line 27, characters 17-27 +Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11 +Called from file "backtrace2.ml", line 67, characters 11-23 +Uncaught exception Not_found +Raised at file "hashtbl.ml", line 194, characters 13-28 +Called from file "backtrace2.ml", line 55, characters 8-41 +Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63 +Called from file "camlinternalLazy.ml", line 27, characters 17-27 +Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11 +Called from file "backtrace2.ml", line 67, characters 11-23 diff --git a/testsuite/tests/backtrace/backtrace3.byte.reference b/testsuite/tests/backtrace/backtrace3.byte.reference index 5081640aae..c667cacbb2 100644 --- a/testsuite/tests/backtrace/backtrace3.byte.reference +++ b/testsuite/tests/backtrace/backtrace3.byte.reference @@ -2,26 +2,65 @@ a No exception b Uncaught exception Backtrace3.Error("b") -Raised at file "backtrace3.ml", line 7, characters 21-32 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 11, characters 4-11 -Re-raised at file "backtrace3.ml", line 20, characters 47-50 -Called from file "backtrace3.ml", line 28, characters 11-23 +Raised at file "backtrace3.ml", line 16, characters 21-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 29, characters 47-50 +Called from file "backtrace3.ml", line 54, characters 11-23 +c Uncaught exception Backtrace3.Error("c") -Raised at file "backtrace3.ml", line 24, characters 12-23 -Called from file "backtrace3.ml", line 28, characters 11-23 +Raised at file "backtrace3.ml", line 33, characters 47-58 +Called from file "backtrace3.ml", line 54, characters 11-23 +d Uncaught exception Backtrace3.Error("d") -Raised at file "backtrace3.ml", line 7, characters 21-32 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 11, characters 4-11 -Called from file "backtrace3.ml", line 28, characters 11-23 +Raised at file "backtrace3.ml", line 16, characters 21-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 36, characters 47-50 +Called from file "backtrace3.ml", line 54, characters 11-23 +e +Uncaught exception Backtrace3.Error("e") +Raised at file "backtrace3.ml", line 16, characters 21-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 39, characters 47-51 +Called from file "backtrace3.ml", line 54, characters 11-23 +f +Uncaught exception Backtrace3.Error("f") +Raised at file "backtrace3.ml", line 16, characters 21-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 44, characters 51-54 +Called from file "backtrace3.ml", line 54, characters 11-23 +g +Uncaught exception Backtrace3.Error("g") +Raised at file "backtrace3.ml", line 16, characters 21-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 47, characters 51-55 +Called from file "backtrace3.ml", line 54, characters 11-23 +Uncaught exception Backtrace3.Error("h") +Raised at file "backtrace3.ml", line 50, characters 16-17 +Called from file "backtrace3.ml", line 54, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22 +Raised by primitive operation at file "backtrace3.ml", line 54, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace3.ml b/testsuite/tests/backtrace/backtrace3.ml index 7e51aa6813..14b7d33dcc 100644 --- a/testsuite/tests/backtrace/backtrace3.ml +++ b/testsuite/tests/backtrace/backtrace3.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/backtrace3.byte.reference" + * native + reference = "${test_source_directory}/backtrace3.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) @@ -21,7 +30,24 @@ let g msg = | exception (Error "c") -> (* according to the current re-raise policy (a static condition), this does not re-raise *) - raise (Error "c") + print_string "c"; print_newline(); raise (Error "c") + | exception (Error "d" as exn as _exn2) -> + (* this should Re-raise, appending to the current backtrace *) + print_string "d"; print_newline(); raise exn + | exception (Error "e" as _exn as exn2) -> + (* this should Re-raise, appending to the current backtrace *) + print_string "e"; print_newline(); raise exn2 + | exception (exn as exn2) -> + match exn with + | Error "f" -> + (* this should Re-raise, appending to the current backtrace *) + print_string "f"; print_newline(); raise exn + | Error "g" -> + (* this should Re-raise, appending to the current backtrace *) + print_string "g"; print_newline(); raise exn2 + | x -> + (* this should *not* Re-raise *) + raise x let run args = try @@ -36,4 +62,8 @@ let _ = run [| "b" |]; run [| "c" |]; run [| "d" |]; + run [| "e" |]; + run [| "f" |]; + run [| "g" |]; + run [| "h" |]; run [| |] diff --git a/testsuite/tests/backtrace/backtrace3.native.reference b/testsuite/tests/backtrace/backtrace3.native.reference deleted file mode 100644 index c38a51e7f1..0000000000 --- a/testsuite/tests/backtrace/backtrace3.native.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace3.Error("b") -Raised at file "backtrace3.ml", line 7, characters 16-32 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 11, characters 4-11 -Re-raised at file "backtrace3.ml", line 20, characters 41-50 -Called from file "backtrace3.ml", line 28, characters 11-23 -Uncaught exception Backtrace3.Error("c") -Raised at file "backtrace3.ml", line 24, characters 6-23 -Called from file "backtrace3.ml", line 28, characters 11-23 -Uncaught exception Backtrace3.Error("d") -Raised at file "backtrace3.ml", line 7, characters 16-32 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 7, characters 42-53 -Called from file "backtrace3.ml", line 11, characters 4-11 -Called from file "backtrace3.ml", line 28, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace3.opt.reference b/testsuite/tests/backtrace/backtrace3.opt.reference new file mode 100644 index 0000000000..87740918e8 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace3.opt.reference @@ -0,0 +1,66 @@ +a +No exception +b +Uncaught exception Backtrace3.Error("b") +Raised at file "backtrace3.ml", line 16, characters 16-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 29, characters 41-50 +Called from file "backtrace3.ml", line 54, characters 11-23 +c +Uncaught exception Backtrace3.Error("c") +Raised at file "backtrace3.ml", line 33, characters 41-58 +Called from file "backtrace3.ml", line 54, characters 11-23 +d +Uncaught exception Backtrace3.Error("d") +Raised at file "backtrace3.ml", line 16, characters 16-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 36, characters 41-50 +Called from file "backtrace3.ml", line 54, characters 11-23 +e +Uncaught exception Backtrace3.Error("e") +Raised at file "backtrace3.ml", line 16, characters 16-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 39, characters 41-51 +Called from file "backtrace3.ml", line 54, characters 11-23 +f +Uncaught exception Backtrace3.Error("f") +Raised at file "backtrace3.ml", line 16, characters 16-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 44, characters 45-54 +Called from file "backtrace3.ml", line 54, characters 11-23 +g +Uncaught exception Backtrace3.Error("g") +Raised at file "backtrace3.ml", line 16, characters 16-32 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 16, characters 42-53 +Called from file "backtrace3.ml", line 20, characters 4-11 +Re-raised at file "backtrace3.ml", line 47, characters 45-55 +Called from file "backtrace3.ml", line 54, characters 11-23 +Uncaught exception Backtrace3.Error("h") +Raised at file "backtrace3.ml", line 50, characters 10-17 +Called from file "backtrace3.ml", line 54, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace3.ml", line 54, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_deprecated.byte.reference b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference index e3eee3d6a2..57158d35ce 100644 --- a/testsuite/tests/backtrace/backtrace_deprecated.byte.reference +++ b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference @@ -2,26 +2,26 @@ a No exception b Uncaught exception Backtrace_deprecated.Error("b") -Raised at file "backtrace_deprecated.ml", line 10, characters 21-32 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 14, characters 4-11 -Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 +Raised at file "backtrace_deprecated.ml", line 19, characters 21-32 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 23, characters 4-11 +Re-raised at file "backtrace_deprecated.ml", line 25, characters 68-71 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 Uncaught exception Backtrace_deprecated.Error("c") -Raised at file "backtrace_deprecated.ml", line 17, characters 26-37 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 +Raised at file "backtrace_deprecated.ml", line 26, characters 26-37 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 Uncaught exception Backtrace_deprecated.Error("d") -Raised at file "backtrace_deprecated.ml", line 10, characters 21-32 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 14, characters 4-11 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 +Raised at file "backtrace_deprecated.ml", line 19, characters 21-32 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 23, characters 4-11 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22 +Raised by primitive operation at file "backtrace_deprecated.ml", line 30, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_deprecated.ml b/testsuite/tests/backtrace/backtrace_deprecated.ml index 945d77302c..8d34b6cf18 100644 --- a/testsuite/tests/backtrace/backtrace_deprecated.ml +++ b/testsuite/tests/backtrace/backtrace_deprecated.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/backtrace_deprecated.byte.reference" + * native + reference = "${test_source_directory}/backtrace_deprecated.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) diff --git a/testsuite/tests/backtrace/backtrace_deprecated.native.reference b/testsuite/tests/backtrace/backtrace_deprecated.native.reference deleted file mode 100644 index 8d6826ec81..0000000000 --- a/testsuite/tests/backtrace/backtrace_deprecated.native.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace_deprecated.Error("b") -Raised at file "backtrace_deprecated.ml", line 10, characters 16-32 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 14, characters 4-11 -Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 -Uncaught exception Backtrace_deprecated.Error("c") -Raised at file "backtrace_deprecated.ml", line 17, characters 20-37 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 -Uncaught exception Backtrace_deprecated.Error("d") -Raised at file "backtrace_deprecated.ml", line 10, characters 16-32 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 10, characters 42-53 -Called from file "backtrace_deprecated.ml", line 14, characters 4-11 -Called from file "backtrace_deprecated.ml", line 21, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_deprecated.opt.reference b/testsuite/tests/backtrace/backtrace_deprecated.opt.reference new file mode 100644 index 0000000000..61c47df2c6 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.opt.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_deprecated.Error("b") +Raised at file "backtrace_deprecated.ml", line 19, characters 16-32 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 23, characters 4-11 +Re-raised at file "backtrace_deprecated.ml", line 25, characters 62-71 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("c") +Raised at file "backtrace_deprecated.ml", line 26, characters 20-37 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("d") +Raised at file "backtrace_deprecated.ml", line 19, characters 16-32 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 19, characters 42-53 +Called from file "backtrace_deprecated.ml", line 23, characters 4-11 +Called from file "backtrace_deprecated.ml", line 30, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_deprecated.ml", line 30, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.byte.reference b/testsuite/tests/backtrace/backtrace_slots.byte.reference index bfd8f5f44f..ce4358b564 100644 --- a/testsuite/tests/backtrace/backtrace_slots.byte.reference +++ b/testsuite/tests/backtrace/backtrace_slots.byte.reference @@ -2,26 +2,26 @@ a No exception b Uncaught exception Backtrace_slots.Error("b") -Raised at file "backtrace_slots.ml", line 36, characters 21-32 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 40, characters 4-11 -Re-raised at file "backtrace_slots.ml", line 42, characters 68-71 -Called from file "backtrace_slots.ml", line 47, characters 11-23 +Raised at file "backtrace_slots.ml", line 45, characters 21-32 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 49, characters 4-11 +Re-raised at file "backtrace_slots.ml", line 51, characters 68-71 +Called from file "backtrace_slots.ml", line 56, characters 11-23 Uncaught exception Backtrace_slots.Error("c") -Raised at file "backtrace_slots.ml", line 43, characters 26-37 -Called from file "backtrace_slots.ml", line 47, characters 11-23 +Raised at file "backtrace_slots.ml", line 52, characters 26-37 +Called from file "backtrace_slots.ml", line 56, characters 11-23 Uncaught exception Backtrace_slots.Error("d") -Raised at file "backtrace_slots.ml", line 36, characters 21-32 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 40, characters 4-11 -Called from file "backtrace_slots.ml", line 47, characters 11-23 +Raised at file "backtrace_slots.ml", line 45, characters 21-32 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 49, characters 4-11 +Called from file "backtrace_slots.ml", line 56, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22 +Raised by primitive operation at file "backtrace_slots.ml", line 56, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.ml b/testsuite/tests/backtrace/backtrace_slots.ml index 877f8a5acd..ef68b3fdef 100644 --- a/testsuite/tests/backtrace/backtrace_slots.ml +++ b/testsuite/tests/backtrace/backtrace_slots.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/backtrace_slots.byte.reference" + * native + reference = "${test_source_directory}/backtrace_slots.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) diff --git a/testsuite/tests/backtrace/backtrace_slots.native.reference b/testsuite/tests/backtrace/backtrace_slots.native.reference deleted file mode 100644 index dd47e69d4f..0000000000 --- a/testsuite/tests/backtrace/backtrace_slots.native.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace_slots.Error("b") -Raised at file "backtrace_slots.ml", line 36, characters 16-32 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 40, characters 4-11 -Re-raised at file "backtrace_slots.ml", line 42, characters 62-71 -Called from file "backtrace_slots.ml", line 47, characters 11-23 -Uncaught exception Backtrace_slots.Error("c") -Raised at file "backtrace_slots.ml", line 43, characters 20-37 -Called from file "backtrace_slots.ml", line 47, characters 11-23 -Uncaught exception Backtrace_slots.Error("d") -Raised at file "backtrace_slots.ml", line 36, characters 16-32 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 36, characters 42-53 -Called from file "backtrace_slots.ml", line 40, characters 4-11 -Called from file "backtrace_slots.ml", line 47, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.opt.reference b/testsuite/tests/backtrace/backtrace_slots.opt.reference new file mode 100644 index 0000000000..2d3c55fb61 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.opt.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_slots.Error("b") +Raised at file "backtrace_slots.ml", line 45, characters 16-32 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 49, characters 4-11 +Re-raised at file "backtrace_slots.ml", line 51, characters 62-71 +Called from file "backtrace_slots.ml", line 56, characters 11-23 +Uncaught exception Backtrace_slots.Error("c") +Raised at file "backtrace_slots.ml", line 52, characters 20-37 +Called from file "backtrace_slots.ml", line 56, characters 11-23 +Uncaught exception Backtrace_slots.Error("d") +Raised at file "backtrace_slots.ml", line 45, characters 16-32 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 45, characters 42-53 +Called from file "backtrace_slots.ml", line 49, characters 4-11 +Called from file "backtrace_slots.ml", line 56, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_slots.ml", line 56, characters 14-22 diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml index 9edf7afb52..8ea69593be 100644 --- a/testsuite/tests/backtrace/backtraces_and_finalizers.ml +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml @@ -1,3 +1,9 @@ +(* TEST + flags = "-g -inline 0" + ocamlrunparam += ",b=1" + compare_programs = "false" + * native +*) let () = Printexc.record_backtrace true diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference deleted file mode 100644 index 9766475a41..0000000000 --- a/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/testsuite/tests/backtrace/filter-locations b/testsuite/tests/backtrace/filter-locations new file mode 100755 index 0000000000..6d9757f491 --- /dev/null +++ b/testsuite/tests/backtrace/filter-locations @@ -0,0 +1,2 @@ +#!/bin/sh +grep -oE '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+' diff --git a/testsuite/tests/backtrace/inline_test.byte.reference b/testsuite/tests/backtrace/inline_test.byte.reference index 0cda2efd4d..ba14898eab 100644 --- a/testsuite/tests/backtrace/inline_test.byte.reference +++ b/testsuite/tests/backtrace/inline_test.byte.reference @@ -1,15 +1,15 @@ inline_test.ml -line 5 +line 19 characters 8-24 inline_test.ml -line 8 +line 22 characters 2-5 inline_test.ml -line 11 +line 25 characters 12-17 inline_test.ml -line 14 +line 28 characters 5-8 inline_test.ml -line 18 +line 32 characters 2-6 diff --git a/testsuite/tests/backtrace/inline_test.ml b/testsuite/tests/backtrace/inline_test.ml index ae64e2cd36..83f06bf689 100644 --- a/testsuite/tests/backtrace/inline_test.ml +++ b/testsuite/tests/backtrace/inline_test.ml @@ -1,3 +1,17 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/inline_test.byte.reference" + * native + reference = "${test_source_directory}/inline_test.opt.reference" + compare_programs = "false" + * native + ocamlopt_flags = "-O3" + compiler_directory_suffix = ".O3" + reference = "${test_source_directory}/inline_test.opt.reference" + compare_programs = "false" +*) (* A test for inlined stack backtraces *) diff --git a/testsuite/tests/backtrace/inline_test.native.reference b/testsuite/tests/backtrace/inline_test.opt.reference index 644987b9ae..2ee096e0cf 100644 --- a/testsuite/tests/backtrace/inline_test.native.reference +++ b/testsuite/tests/backtrace/inline_test.opt.reference @@ -1,15 +1,15 @@ inline_test.ml -line 5 +line 19 characters 2-24 inline_test.ml -line 8 +line 22 characters 2-5 inline_test.ml -line 11 +line 25 characters 12-17 inline_test.ml -line 14 +line 28 characters 5-8 inline_test.ml -line 18 +line 32 characters 2-6 diff --git a/testsuite/tests/backtrace/inline_test.run b/testsuite/tests/backtrace/inline_test.run new file mode 100755 index 0000000000..068f3f19a7 --- /dev/null +++ b/testsuite/tests/backtrace/inline_test.run @@ -0,0 +1,3 @@ +#!/bin/sh +(${program} 2>&1 || true) | \ + ${test_source_directory}/filter-locations > ${output} diff --git a/testsuite/tests/backtrace/inline_traversal_test.byte.reference b/testsuite/tests/backtrace/inline_traversal_test.byte.reference index bcb98c343b..dfb7c0d6f6 100644 --- a/testsuite/tests/backtrace/inline_traversal_test.byte.reference +++ b/testsuite/tests/backtrace/inline_traversal_test.byte.reference @@ -1,5 +1,5 @@ -inline_traversal_test.ml:5 -inline_traversal_test.ml:8 -inline_traversal_test.ml:11 -inline_traversal_test.ml:14 inline_traversal_test.ml:19 +inline_traversal_test.ml:22 +inline_traversal_test.ml:25 +inline_traversal_test.ml:28 +inline_traversal_test.ml:33 diff --git a/testsuite/tests/backtrace/inline_traversal_test.ml b/testsuite/tests/backtrace/inline_traversal_test.ml index 1d91844636..1bbcb357ab 100644 --- a/testsuite/tests/backtrace/inline_traversal_test.ml +++ b/testsuite/tests/backtrace/inline_traversal_test.ml @@ -1,3 +1,17 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/inline_traversal_test.byte.reference" + * native + reference = "${test_source_directory}/inline_traversal_test.opt.reference" + compare_programs = "false" + * native + ocamlopt_flags = "-O3" + compiler_directory_suffix = ".O3" + reference = "${test_source_directory}/inline_traversal_test.opt.reference" + compare_programs = "false" +*) (* A test for inlined stack backtraces *) diff --git a/testsuite/tests/backtrace/inline_traversal_test.native.reference b/testsuite/tests/backtrace/inline_traversal_test.native.reference deleted file mode 100644 index bcb98c343b..0000000000 --- a/testsuite/tests/backtrace/inline_traversal_test.native.reference +++ /dev/null @@ -1,5 +0,0 @@ -inline_traversal_test.ml:5 -inline_traversal_test.ml:8 -inline_traversal_test.ml:11 -inline_traversal_test.ml:14 -inline_traversal_test.ml:19 diff --git a/testsuite/tests/backtrace/inline_traversal_test.opt.reference b/testsuite/tests/backtrace/inline_traversal_test.opt.reference new file mode 100644 index 0000000000..dfb7c0d6f6 --- /dev/null +++ b/testsuite/tests/backtrace/inline_traversal_test.opt.reference @@ -0,0 +1,5 @@ +inline_traversal_test.ml:19 +inline_traversal_test.ml:22 +inline_traversal_test.ml:25 +inline_traversal_test.ml:28 +inline_traversal_test.ml:33 diff --git a/testsuite/tests/backtrace/inline_traversal_test.run b/testsuite/tests/backtrace/inline_traversal_test.run new file mode 100755 index 0000000000..068f3f19a7 --- /dev/null +++ b/testsuite/tests/backtrace/inline_traversal_test.run @@ -0,0 +1,3 @@ +#!/bin/sh +(${program} 2>&1 || true) | \ + ${test_source_directory}/filter-locations > ${output} diff --git a/testsuite/tests/backtrace/ocamltests b/testsuite/tests/backtrace/ocamltests new file mode 100644 index 0000000000..166dcd7cc7 --- /dev/null +++ b/testsuite/tests/backtrace/ocamltests @@ -0,0 +1,11 @@ +backtrace.ml +backtrace2.ml +backtrace3.ml +backtrace_deprecated.ml +backtrace_slots.ml +backtraces_and_finalizers.ml +inline_test.ml +inline_traversal_test.ml +pr6920_why_at.ml +pr6920_why_swallow.ml +raw_backtrace.ml diff --git a/testsuite/tests/backtrace/pr6920_why_at.byte.reference b/testsuite/tests/backtrace/pr6920_why_at.byte.reference index 02acac165e..4428595567 100644 --- a/testsuite/tests/backtrace/pr6920_why_at.byte.reference +++ b/testsuite/tests/backtrace/pr6920_why_at.byte.reference @@ -1,4 +1,4 @@ Fatal error: exception Stdlib.Pervasives.Exit -Raised at file "pr6920_why_at.ml", line 1, characters 41-45 -Called from file "pr6920_why_at.ml", line 3, characters 2-11 -Called from file "pr6920_why_at.ml", line 9, characters 2-6 +Raised at file "pr6920_why_at.ml", line 13, characters 41-45 +Called from file "pr6920_why_at.ml", line 15, characters 2-11 +Called from file "pr6920_why_at.ml", line 21, characters 2-6 diff --git a/testsuite/tests/backtrace/pr6920_why_at.ml b/testsuite/tests/backtrace/pr6920_why_at.ml index 0cd9f73dda..83e78475aa 100644 --- a/testsuite/tests/backtrace/pr6920_why_at.ml +++ b/testsuite/tests/backtrace/pr6920_why_at.ml @@ -1,3 +1,15 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + ocamlopt_flags = "-inline 0" + exit_status = "2" + * bytecode + reference = "${test_source_directory}/pr6920_why_at.byte.reference" + * native + reference = "${test_source_directory}/pr6920_why_at.opt.reference" + compare_programs = "false" +*) + let why : unit -> unit = fun () -> raise Exit [@@inline never] let f () = why @@ (); diff --git a/testsuite/tests/backtrace/pr6920_why_at.native.reference b/testsuite/tests/backtrace/pr6920_why_at.native.reference deleted file mode 100644 index 00ac4b40ae..0000000000 --- a/testsuite/tests/backtrace/pr6920_why_at.native.reference +++ /dev/null @@ -1,4 +0,0 @@ -Fatal error: exception Stdlib.Pervasives.Exit -Raised at file "pr6920_why_at.ml", line 1, characters 35-45 -Called from file "pr6920_why_at.ml", line 3, characters 2-11 -Called from file "pr6920_why_at.ml", line 9, characters 2-6 diff --git a/testsuite/tests/backtrace/pr6920_why_at.opt.reference b/testsuite/tests/backtrace/pr6920_why_at.opt.reference new file mode 100644 index 0000000000..62a0ef9622 --- /dev/null +++ b/testsuite/tests/backtrace/pr6920_why_at.opt.reference @@ -0,0 +1,4 @@ +Fatal error: exception Stdlib.Pervasives.Exit +Raised at file "pr6920_why_at.ml", line 13, characters 35-45 +Called from file "pr6920_why_at.ml", line 15, characters 2-11 +Called from file "pr6920_why_at.ml", line 21, characters 2-6 diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference index b50fc7f6c9..c262211d50 100644 --- a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference +++ b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference @@ -1,4 +1,4 @@ Fatal error: exception Stdlib.Pervasives.Exit -Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45 -Called from file "pr6920_why_swallow.ml", line 4, characters 4-13 -Called from file "pr6920_why_swallow.ml", line 11, characters 2-6 +Raised at file "pr6920_why_swallow.ml", line 13, characters 41-45 +Called from file "pr6920_why_swallow.ml", line 16, characters 4-13 +Called from file "pr6920_why_swallow.ml", line 23, characters 2-6 diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.ml b/testsuite/tests/backtrace/pr6920_why_swallow.ml index def1d48542..11b5badb73 100644 --- a/testsuite/tests/backtrace/pr6920_why_swallow.ml +++ b/testsuite/tests/backtrace/pr6920_why_swallow.ml @@ -1,3 +1,15 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + ocamlopt_flags = "-inline 0" + exit_status = "2" + * bytecode + reference = "${test_source_directory}/pr6920_why_swallow.byte.reference" + * native + reference = "${test_source_directory}/pr6920_why_swallow.opt.reference" + compare_programs = "false" +*) + let why : unit -> unit = fun () -> raise Exit [@@inline never] let f () = for i = 1 to 10 do diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference deleted file mode 100644 index c845d0fdb9..0000000000 --- a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference +++ /dev/null @@ -1,4 +0,0 @@ -Fatal error: exception Stdlib.Pervasives.Exit -Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45 -Called from file "pr6920_why_swallow.ml", line 4, characters 4-13 -Called from file "pr6920_why_swallow.ml", line 11, characters 2-6 diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.opt.reference b/testsuite/tests/backtrace/pr6920_why_swallow.opt.reference new file mode 100644 index 0000000000..b842cee048 --- /dev/null +++ b/testsuite/tests/backtrace/pr6920_why_swallow.opt.reference @@ -0,0 +1,4 @@ +Fatal error: exception Stdlib.Pervasives.Exit +Raised at file "pr6920_why_swallow.ml", line 13, characters 35-45 +Called from file "pr6920_why_swallow.ml", line 16, characters 4-13 +Called from file "pr6920_why_swallow.ml", line 23, characters 2-6 diff --git a/testsuite/tests/backtrace/raw_backtrace.byte.reference b/testsuite/tests/backtrace/raw_backtrace.byte.reference index ba437e3311..59c565cd76 100644 --- a/testsuite/tests/backtrace/raw_backtrace.byte.reference +++ b/testsuite/tests/backtrace/raw_backtrace.byte.reference @@ -2,48 +2,48 @@ a No exception b Uncaught exception Raw_backtrace.Error("b") -Raised at file "raw_backtrace.ml", line 7, characters 21-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 18, characters 68-71 -Called from file "raw_backtrace.ml", line 33, characters 11-23 +Raised at file "raw_backtrace.ml", line 16, characters 21-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 27, characters 68-71 +Called from file "raw_backtrace.ml", line 42, characters 11-23 Uncaught exception Raw_backtrace.Error("c") -Raised at file "raw_backtrace.ml", line 19, characters 26-37 -Called from file "raw_backtrace.ml", line 33, characters 11-23 +Raised at file "raw_backtrace.ml", line 28, characters 26-37 +Called from file "raw_backtrace.ml", line 42, characters 11-23 Uncaught exception Raw_backtrace.Error("d") -Raised at file "raw_backtrace.ml", line 7, characters 21-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Called from file "raw_backtrace.ml", line 33, characters 11-23 +Raised at file "raw_backtrace.ml", line 16, characters 21-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Called from file "raw_backtrace.ml", line 42, characters 11-23 e Uncaught exception Raw_backtrace.Error("e") -Raised at file "raw_backtrace.ml", line 7, characters 21-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 25, characters 39-42 -Called from file "raw_backtrace.ml", line 33, characters 11-23 +Raised at file "raw_backtrace.ml", line 16, characters 21-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 34, characters 39-42 +Called from file "raw_backtrace.ml", line 42, characters 11-23 f Uncaught exception Raw_backtrace.Localized(_) -Raised at file "raw_backtrace.ml", line 7, characters 21-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 29, characters 39-54 -Called from file "raw_backtrace.ml", line 33, characters 11-23 +Raised at file "raw_backtrace.ml", line 16, characters 21-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 38, characters 39-54 +Called from file "raw_backtrace.ml", line 42, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22 +Raised by primitive operation at file "raw_backtrace.ml", line 42, characters 14-22 diff --git a/testsuite/tests/backtrace/raw_backtrace.ml b/testsuite/tests/backtrace/raw_backtrace.ml index 45822751fb..824447e744 100644 --- a/testsuite/tests/backtrace/raw_backtrace.ml +++ b/testsuite/tests/backtrace/raw_backtrace.ml @@ -1,3 +1,12 @@ +(* TEST + flags = "-g" + ocamlrunparam += ",b=1" + * bytecode + reference = "${test_source_directory}/raw_backtrace.byte.reference" + * native + reference = "${test_source_directory}/raw_backtrace.opt.reference" + compare_programs = "false" +*) (* A test for stack backtraces *) diff --git a/testsuite/tests/backtrace/raw_backtrace.native.reference b/testsuite/tests/backtrace/raw_backtrace.native.reference deleted file mode 100644 index 06f4f164bf..0000000000 --- a/testsuite/tests/backtrace/raw_backtrace.native.reference +++ /dev/null @@ -1,49 +0,0 @@ -a -No exception -b -Uncaught exception Raw_backtrace.Error("b") -Raised at file "raw_backtrace.ml", line 7, characters 16-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 18, characters 62-71 -Called from file "raw_backtrace.ml", line 33, characters 11-23 -Uncaught exception Raw_backtrace.Error("c") -Raised at file "raw_backtrace.ml", line 19, characters 20-37 -Called from file "raw_backtrace.ml", line 33, characters 11-23 -Uncaught exception Raw_backtrace.Error("d") -Raised at file "raw_backtrace.ml", line 7, characters 16-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Called from file "raw_backtrace.ml", line 33, characters 11-23 -e -Uncaught exception Raw_backtrace.Error("e") -Raised at file "raw_backtrace.ml", line 7, characters 16-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 25, characters 9-45 -Called from file "raw_backtrace.ml", line 33, characters 11-23 -f -Uncaught exception Raw_backtrace.Localized(_) -Raised at file "raw_backtrace.ml", line 7, characters 16-32 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 7, characters 42-53 -Called from file "raw_backtrace.ml", line 16, characters 4-11 -Re-raised at file "raw_backtrace.ml", line 29, characters 9-57 -Called from file "raw_backtrace.ml", line 33, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22 diff --git a/testsuite/tests/backtrace/raw_backtrace.opt.reference b/testsuite/tests/backtrace/raw_backtrace.opt.reference new file mode 100644 index 0000000000..e170838c62 --- /dev/null +++ b/testsuite/tests/backtrace/raw_backtrace.opt.reference @@ -0,0 +1,49 @@ +a +No exception +b +Uncaught exception Raw_backtrace.Error("b") +Raised at file "raw_backtrace.ml", line 16, characters 16-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 27, characters 62-71 +Called from file "raw_backtrace.ml", line 42, characters 11-23 +Uncaught exception Raw_backtrace.Error("c") +Raised at file "raw_backtrace.ml", line 28, characters 20-37 +Called from file "raw_backtrace.ml", line 42, characters 11-23 +Uncaught exception Raw_backtrace.Error("d") +Raised at file "raw_backtrace.ml", line 16, characters 16-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Called from file "raw_backtrace.ml", line 42, characters 11-23 +e +Uncaught exception Raw_backtrace.Error("e") +Raised at file "raw_backtrace.ml", line 16, characters 16-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 34, characters 9-45 +Called from file "raw_backtrace.ml", line 42, characters 11-23 +f +Uncaught exception Raw_backtrace.Localized(_) +Raised at file "raw_backtrace.ml", line 16, characters 16-32 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 16, characters 42-53 +Called from file "raw_backtrace.ml", line 25, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 38, characters 9-57 +Called from file "raw_backtrace.ml", line 42, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "raw_backtrace.ml", line 42, characters 14-22 diff --git a/testsuite/tests/basic-float/float_compare.ml b/testsuite/tests/basic-float/float_compare.ml index d5b7a9a103..1c9faf3966 100644 --- a/testsuite/tests/basic-float/float_compare.ml +++ b/testsuite/tests/basic-float/float_compare.ml @@ -1,6 +1,112 @@ -let compare_nan () = - not (nan < 0.0) +let equal (x : float) (y : float) = + x, "=", y, (x = y) [@@inline never] -let x = print_endline (string_of_bool (compare_nan ())) +let not_equal (x : float) (y : float) = + x, "!=", y, (x <> y) +[@@inline never] + +let less_than (x : float) (y : float) = + x, "<", y, (x < y) +[@@inline never] + +let not_less_than (x : float) (y : float) = + x, "!<", y, not (x < y) +[@@inline never] + +let less_equal (x : float) (y : float) = + x, "<=", y, (x <= y) +[@@inline never] + +let not_less_equal (x : float) (y : float) = + x, "!<=", y, not (x <= y) +[@@inline never] + +let greater_than (x : float) (y : float) = + x, ">", y, (x > y) +[@@inline never] + +let not_greater_than (x : float) (y : float) = + x, "!>", y, not (x > y) +[@@inline never] + +let greater_equal (x : float) (y : float) = + x, ">=", y, (x >= y) +[@@inline never] + +let not_greater_equal (x : float) (y : float) = + x, "!>=", y, not (x >= y) +[@@inline never] + +let show (x, op, y, b) = + print_float x; + print_string " "; + print_string op; + print_string " "; + print_float y; + print_string ": "; + print_endline (string_of_bool b) + +let print_line () = + print_endline "------------------" + +let () = show (equal 1.0 2.0) +let () = show (equal 1.0 1.0) +let () = show (equal 2.0 1.0) +let () = show (equal 1.0 nan) +let () = print_line () + +let () = show (not_equal 1.0 2.0) +let () = show (not_equal 1.0 1.0) +let () = show (not_equal 2.0 1.0) +let () = show (not_equal 1.0 nan) +let () = print_line () + +let () = show (less_than 1.0 2.0) +let () = show (less_than 1.0 1.0) +let () = show (less_than 2.0 1.0) +let () = show (less_than 1.0 nan) +let () = print_line () + +let () = show (not_less_than 1.0 2.0) +let () = show (not_less_than 1.0 1.0) +let () = show (not_less_than 2.0 1.0) +let () = show (not_less_than 1.0 nan) +let () = print_line () + +let () = show (less_equal 1.0 2.0) +let () = show (less_equal 1.0 1.0) +let () = show (less_equal 2.0 1.0) +let () = show (less_equal 1.0 nan) +let () = print_line () + +let () = show (not_less_equal 1.0 2.0) +let () = show (not_less_equal 1.0 1.0) +let () = show (not_less_equal 2.0 1.0) +let () = show (not_less_equal 1.0 nan) +let () = print_line () + +let () = show (greater_than 1.0 2.0) +let () = show (greater_than 1.0 1.0) +let () = show (greater_than 2.0 1.0) +let () = show (greater_than 1.0 nan) +let () = print_line () + +let () = show (not_greater_than 1.0 2.0) +let () = show (not_greater_than 1.0 1.0) +let () = show (not_greater_than 2.0 1.0) +let () = show (not_greater_than 1.0 nan) +let () = print_line () + +let () = show (greater_equal 1.0 2.0) +let () = show (greater_equal 1.0 1.0) +let () = show (greater_equal 2.0 1.0) +let () = show (greater_equal 1.0 nan) +let () = print_line () + +let () = show (not_greater_equal 1.0 2.0) +let () = show (not_greater_equal 1.0 1.0) +let () = show (not_greater_equal 2.0 1.0) +let () = show (not_greater_equal 1.0 nan) +let () = print_line () diff --git a/testsuite/tests/basic-float/float_compare.reference b/testsuite/tests/basic-float/float_compare.reference index 27ba77ddaf..52efc29ad9 100644 --- a/testsuite/tests/basic-float/float_compare.reference +++ b/testsuite/tests/basic-float/float_compare.reference @@ -1 +1,50 @@ -true +1. = 2.: false +1. = 1.: true +2. = 1.: false +1. = nan: false +------------------ +1. != 2.: true +1. != 1.: false +2. != 1.: true +1. != nan: true +------------------ +1. < 2.: true +1. < 1.: false +2. < 1.: false +1. < nan: false +------------------ +1. !< 2.: false +1. !< 1.: true +2. !< 1.: true +1. !< nan: true +------------------ +1. <= 2.: true +1. <= 1.: true +2. <= 1.: false +1. <= nan: false +------------------ +1. !<= 2.: false +1. !<= 1.: false +2. !<= 1.: true +1. !<= nan: true +------------------ +1. > 2.: false +1. > 1.: false +2. > 1.: true +1. > nan: false +------------------ +1. !> 2.: true +1. !> 1.: true +2. !> 1.: false +1. !> nan: true +------------------ +1. >= 2.: false +1. >= 1.: true +2. >= 1.: true +1. >= nan: false +------------------ +1. !>= 2.: true +1. !>= 1.: false +2. !>= 1.: false +1. !>= nan: true +------------------ diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile deleted file mode 100644 index 563d9979e2..0000000000 --- a/testsuite/tests/callback/Makefile +++ /dev/null @@ -1,74 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. - -COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix -LD_PATH=$(TOPDIR)/otherlibs/unix - -.PHONY: default -default: - @case " $(OTHERLIBRARIES) " in \ - *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte; \ - $(SET_LD_PATH) $(MAKE) run-opt;; \ - *) $(MAKE) skip;; \ - esac - -.PHONY: common -common: - @$(CC) -c $(CFLAGS) $(CPPFLAGS) -I$(CTOPDIR)/byterun callbackprim.c - -.PHONY: skip -skip: - @for c in bytecode native; do \ - echo " ... testing '$$c': => skipped" ; \ - done - -.PHONY: run-byte -run-byte: - @for f in *.ml; do \ - F=`basename $$f .ml`; \ - printf " ... testing '$$F.byte$(EXE)':"; \ - $(CC) -I $(CTOPDIR)/byterun -c $$F.c; \ - $(OCAMLC) $(COMPFLAGS) -c $$F.mli; \ - $(OCAMLC) $(COMPFLAGS) -c $$F.ml; \ - $(OCAMLC) $(COMPFLAGS) -o ./$$F.byte$(EXE) -custom unix.cma $$F.$(O) $$F.cmo; \ - ./$$F.byte$(EXE) > $$F.byte.result; \ - $(DIFF) $$F.reference $$F.byte.result && echo " => passed" || echo " => failed"; \ - done - -.PHONY: run-opt -run-opt: - @if $(BYTECODE_ONLY); then : ; else \ - for f in *.ml; do \ - F=`basename $$f .ml`; \ - printf " ... testing '$$F.native$(EXE)':"; \ - $(CC) -I $(CTOPDIR)/byterun -c $$F.c; \ - mv $$F.$(O) $$F.c.$(O); \ - $(OCAMLOPT) $(COMPFLAGS) -c $$F.mli; \ - $(OCAMLOPT) $(COMPFLAGS) -o ./$$F.native$(EXE) unix.cmxa $$F.c.$(O) $$F.ml; \ - ./$$F.native$(EXE) > $$F.native.result; \ - $(DIFF) $$F.reference $$F.native.result && echo " => passed" || echo " => failed"; \ - done; \ - fi - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result *.byte$(EXE) *.native$(EXE) - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/callback/ocamltests b/testsuite/tests/callback/ocamltests new file mode 100644 index 0000000000..0484d5ecf3 --- /dev/null +++ b/testsuite/tests/callback/ocamltests @@ -0,0 +1 @@ +tcallback.ml diff --git a/testsuite/tests/callback/tcallback.reference b/testsuite/tests/callback/tcallback.reference new file mode 100644 index 0000000000..b35993aa2c --- /dev/null +++ b/testsuite/tests/callback/tcallback.reference @@ -0,0 +1,8 @@ +7 +7 +7 +7 +7 +aaaaa +aaaaa +bbbbb diff --git a/testsuite/tests/callback/test1.ml b/testsuite/tests/callback/test1.ml index 121d3c570e..9e4e09f5c6 100644 --- a/testsuite/tests/callback/test1.ml +++ b/testsuite/tests/callback/test1.ml @@ -1,3 +1,11 @@ +(* TEST + include unix + modules = "callbackprim.c" + * libunix + ** bytecode + ** native +*) + (**************************************************************************) external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1" diff --git a/testsuite/tests/functors/Makefile b/testsuite/tests/functors/Makefile deleted file mode 100644 index c4223d4522..0000000000 --- a/testsuite/tests/functors/Makefile +++ /dev/null @@ -1,4 +0,0 @@ -BASEDIR=../.. -TOPFLAGS+=-dlambda -include $(BASEDIR)/makefiles/Makefile.dlambda -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/functors/functors.compilers.reference b/testsuite/tests/functors/functors.compilers.reference new file mode 100644 index 0000000000..d0dc017d41 --- /dev/null +++ b/testsuite/tests/functors/functors.compilers.reference @@ -0,0 +1,52 @@ +(setglobal Functors! + (let + (O = + (module-defn(O) functors.ml(12):184-279 + (function X is_a_functor always_inline + (let + (cow = + (function x (apply (field_imm 0 X) x)) + sheep = (function x (+ 1 (apply cow x)))) + (makeblock 0 cow sheep)))) + F = + (module-defn(F) functors.ml(17):281-392 + (function X Y is_a_functor always_inline + (let + (cow = (function x (apply (field 0 Y) (apply (field 0 X) x))) + sheep = (function x (+ 1 (apply cow x)))) + (makeblock 0 cow sheep)))) + F1 = + (module-defn(F1) functors.ml(31):516-632 + (function X Y is_a_functor always_inline + (let + (cow = (function x (apply (field 0 Y) (apply (field 0 X) x))) + sheep = (function x (+ 1 (apply cow x)))) + (makeblock 0 sheep)))) + F2 = + (module-defn(F2) functors.ml(36):634-784 + (function X Y is_a_functor always_inline + (let + (X =a (makeblock 0 (field 1 X)) + Y =a (makeblock 0 (field 1 Y)) + cow = (function x (apply (field 0 Y) (apply (field 0 X) x))) + sheep = (function x (+ 1 (apply cow x)))) + (makeblock 0 sheep)))) + M = + (module-defn(M) functors.ml(41):786-970 + (let + (F = + (module-defn(F) functors.ml(44):849-966 + (function X Y is_a_functor always_inline + (let + (cow = + (function x (apply (field 0 Y) (apply (field 0 X) x))) + sheep = (function x (+ 1 (apply cow x)))) + (makeblock 0 cow sheep))))) + (makeblock 0 + (function funarg funarg is_a_functor stub + (let + (let = + (apply F (makeblock 0 (field 1 funarg)) + (makeblock 0 (field 1 funarg)))) + (makeblock 0 (field 1 let)))))))) + (makeblock 0 O F F1 F2 M))) diff --git a/testsuite/tests/functors/functors.ml b/testsuite/tests/functors/functors.ml index 32541699e1..3e40fc6147 100644 --- a/testsuite/tests/functors/functors.ml +++ b/testsuite/tests/functors/functors.ml @@ -1,3 +1,10 @@ +(* TEST + * setup-ocamlc.byte-build-env + ** ocamlc.byte + flags = "-dlambda -dno-unique-ids" + *** check-ocamlc.byte-output +*) + module type S = sig val foo : int -> int end diff --git a/testsuite/tests/functors/functors.ml.reference b/testsuite/tests/functors/functors.ml.reference deleted file mode 100644 index 765ae48725..0000000000 --- a/testsuite/tests/functors/functors.ml.reference +++ /dev/null @@ -1,64 +0,0 @@ -(setglobal Functors! - (let - (O = - (module-defn(O) functors.ml(5):48-143 - (function X is_a_functor always_inline - (let - (cow = - (function x (apply (field_imm 0 X) x)) - sheep = (function x (+ 1 (apply cow x)))) - (makeblock 0 cow sheep)))) - F = - (module-defn(F) functors.ml(10):145-256 - (function X Y is_a_functor always_inline - (let - (cow = - (function x - (apply (field_imm 0 Y) - (apply (field_imm 0 X) x))) - sheep = (function x (+ 1 (apply cow x)))) - (makeblock 0 cow sheep)))) - F1/1022 = - (module-defn(F1/1022) functors.ml(24):380-496 - (function X Y is_a_functor always_inline - (let - (cow = - (function x - (apply (field_imm 0 Y) - (apply (field_imm 0 X) x))) - sheep = (function x (+ 1 (apply cow x)))) - (makeblock 0 sheep)))) - F2/1029 = - (module-defn(F2/1029) functors.ml(29):498-648 - (function X Y is_a_functor always_inline - (let - (X =a (makeblock 0 (field_mut 1 X)) - Y =a (makeblock 0 (field_mut 1 Y)) - cow = - (function x - (apply (field_imm 0 Y) - (apply (field_imm 0 X) x))) - sheep = (function x (+ 1 (apply cow x)))) - (makeblock 0 sheep)))) - M = - (module-defn(M) functors.ml(34):650-834 - (let - (F = - (module-defn(F) functors.ml(37):713-830 - (function X Y is_a_functor always_inline - (let - (cow = - (function x - (apply (field_imm 0 Y) - (apply (field_imm 0 X) x))) - sheep = - (function x (+ 1 (apply cow x)))) - (makeblock 0 cow sheep))))) - (makeblock 0 - (function funarg funarg is_a_functor stub - (let - (let = - (apply F (makeblock 0 (field_mut 1 funarg)) - (makeblock 0 (field_mut 1 funarg)))) - (makeblock 0 (field_mut 1 let)))))))) - (makeblock 0 O F F1/1022 F2/1029 M))) diff --git a/testsuite/tests/functors/ocamltests b/testsuite/tests/functors/ocamltests new file mode 100644 index 0000000000..d5835c07b1 --- /dev/null +++ b/testsuite/tests/functors/ocamltests @@ -0,0 +1 @@ +functors.ml diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile deleted file mode 100644 index baee1d59e9..0000000000 --- a/testsuite/tests/lib-scanf-2/Makefile +++ /dev/null @@ -1,63 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. - -COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix - -MYRUNTIME=`if [ -z "$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi` - -.PHONY: default -default: - @$(MAKE) compile - @$(SET_LD_PATH) $(MAKE) run - -.PHONY: compile -compile: tscanf2_io.cmo - @rm -f master.byte master.native master.native.exe - @rm -f slave.byte slave.native slave.native.exe - @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml - @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml - @if $(BYTECODE_ONLY); then : ; else \ - $(MAKE) tscanf2_io.cmx; \ - $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native$(EXE) \ - tscanf2_master.ml; \ - $(OCAMLOPT) tscanf2_io.cmx -o slave.native$(EXE) tscanf2_slave.ml; \ - fi - -run: - @printf " ... testing with ocamlc" - @$(MYRUNTIME) ./master.byte "$(OTOPDIR)/boot/ocamlrun$(EXE) \ - `$(CYGPATH) ./slave.byte`" \ - >result.byte 2>&1 - @$(DIFF) reference result.byte >/dev/null \ - && if $(BYTECODE_ONLY); then : ; else \ - printf " ocamlopt"; \ - ./master.native$(EXE) "`$(CYGPATH) ./slave.native`" \ - >result.native 2>&1; \ - $(DIFF) reference result.native >/dev/null; \ - fi \ - && echo " => passed" || echo " => failed" - -.PHONY: promote -promote: - @cp result.byte reference - -.PHONY: clean -clean: defaultclean - @rm -f master.* slave.* result.* - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-scanf-2/ocamltests b/testsuite/tests/lib-scanf-2/ocamltests new file mode 100644 index 0000000000..0260373ec8 --- /dev/null +++ b/testsuite/tests/lib-scanf-2/ocamltests @@ -0,0 +1 @@ +tscanf2_master.ml diff --git a/testsuite/tests/lib-scanf-2/tscanf2_master.ml b/testsuite/tests/lib-scanf-2/tscanf2_master.ml index 2dd91bc0c8..988c8a5222 100644 --- a/testsuite/tests/lib-scanf-2/tscanf2_master.ml +++ b/testsuite/tests/lib-scanf-2/tscanf2_master.ml @@ -1,3 +1,60 @@ +(* TEST + +include unix +modules = "tscanf2_io.ml" +files = "tscanf2_slave.ml" +reference = "${test_source_directory}/reference" + +(* The bytcode test *) + +* setup-ocamlc.byte-build-env + +program = "${test_build_directory}/master.byte" + +** ocamlc.byte (* Compiles the master *) + +*** ocamlc.byte (* Compiles the slave *) + +all_modules = "tscanf2_io.cmo tscanf2_slave.ml" + +program = "${test_build_directory}/slave.byte" + +**** check-ocamlc.byte-output + +***** run + +program = "${test_build_directory}/master.byte" + +arguments = "${test_build_directory}/slave.byte" + +****** check-program-output + +(* The native test *) + +* setup-ocamlopt.byte-build-env + +program = "${test_build_directory}/master.opt" + +** ocamlopt.byte (* Compiles the master *) + +*** ocamlopt.byte (* Compiles the slave *) + +all_modules = "tscanf2_io.cmx tscanf2_slave.ml" + +program = "${test_build_directory}/slave.opt" + +**** check-ocamlopt.byte-output + +***** run + +program = "${test_build_directory}/master.opt" + +arguments = "${test_build_directory}/slave.opt" + +****** check-program-output + +*) + (* A very simple master: - first launch a slave process, - then repeat a random number of times: diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile deleted file mode 100644 index 8288dfdc4c..0000000000 --- a/testsuite/tests/lib-threads/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -LIBRARIES=unix threads -ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \ - -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix -LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix - -default: - @$(if $(filter msvc mingw,$(TOOLCHAIN)),$(MAKE) sigint.exe,true) - @$(SET_LD_PATH) $(MAKE) run-all - -include $(BASEDIR)/makefiles/Makefile.several -include $(BASEDIR)/makefiles/Makefile.common - -sigint.exe: sigint.$(O) - @$(CC) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$@,-o $@) $^ - -%.obj: %.c - @$(CC) -c $*.c > /dev/null diff --git a/testsuite/tests/lib-threads/backtrace_threads.ml b/testsuite/tests/lib-threads/backtrace_threads.ml index 79dc8c5b5a..8044af3b54 100644 --- a/testsuite/tests/lib-threads/backtrace_threads.ml +++ b/testsuite/tests/lib-threads/backtrace_threads.ml @@ -1,3 +1,8 @@ +(* TEST + +include systhreads + +*) let () = Printexc.record_backtrace true diff --git a/testsuite/tests/lib-threads/backtrace_threads.reference b/testsuite/tests/lib-threads/backtrace_threads.reference deleted file mode 100644 index e69de29bb2..0000000000 --- a/testsuite/tests/lib-threads/backtrace_threads.reference +++ /dev/null diff --git a/testsuite/tests/lib-threads/bank.ml b/testsuite/tests/lib-threads/bank.ml index 800d332a95..cf00a71705 100644 --- a/testsuite/tests/lib-threads/bank.ml +++ b/testsuite/tests/lib-threads/bank.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* The bank account example, using events and channels *) open Printf diff --git a/testsuite/tests/lib-threads/beat.ml b/testsuite/tests/lib-threads/beat.ml index afc8166a2f..a09980be89 100644 --- a/testsuite/tests/lib-threads/beat.ml +++ b/testsuite/tests/lib-threads/beat.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* Test Thread.delay and its scheduling *) open Printf diff --git a/testsuite/tests/lib-threads/bufchan.ml b/testsuite/tests/lib-threads/bufchan.ml index b8ac55c2f7..4c243c6cf7 100644 --- a/testsuite/tests/lib-threads/bufchan.ml +++ b/testsuite/tests/lib-threads/bufchan.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + open Event type 'a buffer_channel = { diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml index bba0286cb8..5f8918a385 100644 --- a/testsuite/tests/lib-threads/close.ml +++ b/testsuite/tests/lib-threads/close.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + let main () = let (rd, wr) = Unix.pipe() in let t = Thread.create diff --git a/testsuite/tests/lib-threads/fileio.ml b/testsuite/tests/lib-threads/fileio.ml index 5c02aebddc..d380917a38 100644 --- a/testsuite/tests/lib-threads/fileio.ml +++ b/testsuite/tests/lib-threads/fileio.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* Test a file copy function *) let test msg producer consumer src dst = diff --git a/testsuite/tests/lib-threads/ocamltests b/testsuite/tests/lib-threads/ocamltests new file mode 100644 index 0000000000..1df74eb523 --- /dev/null +++ b/testsuite/tests/lib-threads/ocamltests @@ -0,0 +1,17 @@ +backtrace_threads.ml +bank.ml +beat.ml +bufchan.ml +close.ml +fileio.ml +pr4466.ml +pr5325.ml +pr7638.ml +prodcons.ml +prodcons2.ml +sieve.ml +signal.ml +sockets.ml +swapchan.ml +tls.ml +torture.ml diff --git a/testsuite/tests/lib-threads/pr4466.ml b/testsuite/tests/lib-threads/pr4466.ml index 0598a54e13..a05989d7a7 100644 --- a/testsuite/tests/lib-threads/pr4466.ml +++ b/testsuite/tests/lib-threads/pr4466.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + open Printf (* Regression test for PR#4466: select timeout with simultaneous read diff --git a/testsuite/tests/lib-threads/pr5325.ml b/testsuite/tests/lib-threads/pr5325.ml index 884a9a3ec9..b96ccb5121 100644 --- a/testsuite/tests/lib-threads/pr5325.ml +++ b/testsuite/tests/lib-threads/pr5325.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + open Printf (* Regression test for PR#5325: simultaneous read and write on socket diff --git a/testsuite/tests/lib-threads/pr7638.ml b/testsuite/tests/lib-threads/pr7638.ml index 953711123a..07e1a81ca0 100644 --- a/testsuite/tests/lib-threads/pr7638.ml +++ b/testsuite/tests/lib-threads/pr7638.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* MPR#7638 repro case *) let crashme v = diff --git a/testsuite/tests/lib-threads/prodcons.ml b/testsuite/tests/lib-threads/prodcons.ml index 81e3ff1854..808da43abe 100644 --- a/testsuite/tests/lib-threads/prodcons.ml +++ b/testsuite/tests/lib-threads/prodcons.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* Classic producer-consumer *) type 'a prodcons = diff --git a/testsuite/tests/lib-threads/prodcons2.ml b/testsuite/tests/lib-threads/prodcons2.ml index 0b80f5e227..8f3c5b2597 100644 --- a/testsuite/tests/lib-threads/prodcons2.ml +++ b/testsuite/tests/lib-threads/prodcons2.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* Producer-consumer with events and multiple producers *) open Event diff --git a/testsuite/tests/lib-threads/sieve.ml b/testsuite/tests/lib-threads/sieve.ml index 13c494cd29..9c6414b8c4 100644 --- a/testsuite/tests/lib-threads/sieve.ml +++ b/testsuite/tests/lib-threads/sieve.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + let sieve primes = Event.sync (Event.send primes 2); let integers = Event.new_channel () in diff --git a/testsuite/tests/lib-threads/sigint.c b/testsuite/tests/lib-threads/sigint.c index a975949add..aa6df5e6ae 100644 --- a/testsuite/tests/lib-threads/sigint.c +++ b/testsuite/tests/lib-threads/sigint.c @@ -1,10 +1,21 @@ #include <stdio.h> -#include <windows.h> + +#ifdef _WIN32 + #include <windows.h> +#else + #include <stdlib.h> + #include <sys/types.h> + #include <signal.h> +#endif int main(int argc, char** argv) { +#ifdef _WIN32 DWORD pid; HANDLE hProcess; +#else + pid_t pid; +#endif if (argc != 2) { printf("Usage: %s pid\n", argv[0]); @@ -12,6 +23,7 @@ int main(int argc, char** argv) } pid = atoi(argv[1]); +#ifdef _WIN32 hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid); if (!hProcess) { @@ -32,6 +44,12 @@ int main(int argc, char** argv) WaitForSingleObject(hProcess, INFINITE); CloseHandle(hProcess); FreeConsole(); +#else + if (kill(pid,SIGINT)) { + perror("kill"); + return 1; + } +#endif return 0; } diff --git a/testsuite/tests/lib-threads/signal.check-program-output b/testsuite/tests/lib-threads/signal.check-program-output new file mode 100644 index 0000000000..48c0d0e3d4 --- /dev/null +++ b/testsuite/tests/lib-threads/signal.check-program-output @@ -0,0 +1,6 @@ +if sed -e 1q ${output} | grep -q '^[ab]*Got ctrl-C, exiting$'; +then + exit ${TEST_PASS} +else + exit ${TEST_FAIL}; +fi diff --git a/testsuite/tests/lib-threads/signal.checker b/testsuite/tests/lib-threads/signal.checker deleted file mode 100644 index 7e3fee2776..0000000000 --- a/testsuite/tests/lib-threads/signal.checker +++ /dev/null @@ -1,16 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -sed -e 1q signal.result | grep -q '^[ab]*Got ctrl-C, exiting$' diff --git a/testsuite/tests/lib-threads/signal.ml b/testsuite/tests/lib-threads/signal.ml index 1c87d0aeae..2db8fe4432 100644 --- a/testsuite/tests/lib-threads/signal.ml +++ b/testsuite/tests/lib-threads/signal.ml @@ -1,10 +1,59 @@ +(* TEST + +include systhreads + +files = "sigint.c" + +* libunix (* excludes mingw32/64 and msvc32/64 *) + +** setup-ocamlc.byte-build-env + +program = "${test_build_directory}/signal.byte" + +*** ocamlc.byte + +program = "sigint" +all_modules = "sigint.c" + +**** ocamlc.byte + +program = "${test_build_directory}/signal.byte" +all_modules = "signal.ml" + +***** check-ocamlc.byte-output +****** run +******* check-program-output + +** setup-ocamlopt.byte-build-env + +program = "${test_build_directory}/signal.opt" + +*** ocamlopt.byte + +program = "sigint" +all_modules = "sigint.c" + +**** ocamlc.byte + +program = "${test_build_directory}/signal.opt" +all_modules = "signal.ml" + +***** check-ocamlopt.byte-output +****** run +******* check-program-output + +*) + let signaled = ref false +let counter = ref 0 + let sighandler _ = signaled := true let print_message delay c = - while not !signaled do + while (not !signaled) && (!counter <= 20) do + incr counter; print_char c; flush stdout; Thread.delay delay done diff --git a/testsuite/tests/lib-threads/signal.precheck b/testsuite/tests/lib-threads/signal.precheck deleted file mode 100644 index d04af9a431..0000000000 --- a/testsuite/tests/lib-threads/signal.precheck +++ /dev/null @@ -1 +0,0 @@ -test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw" diff --git a/testsuite/tests/lib-threads/signal.run b/testsuite/tests/lib-threads/signal.run new file mode 100644 index 0000000000..1611435d38 --- /dev/null +++ b/testsuite/tests/lib-threads/signal.run @@ -0,0 +1,5 @@ +${program} > ${output} & +pid=$! +sleep 2 +./sigint $pid +wait diff --git a/testsuite/tests/lib-threads/signal.runner b/testsuite/tests/lib-threads/signal.runner deleted file mode 100644 index ad20ad81a5..0000000000 --- a/testsuite/tests/lib-threads/signal.runner +++ /dev/null @@ -1,20 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -$RUNTIME ./program >signal.result & -pid=$! -sleep 2 -test -e ./sigint.exe && ./sigint $pid || kill -INT $pid -wait diff --git a/testsuite/tests/lib-threads/sockets.ml b/testsuite/tests/lib-threads/sockets.ml index 160446f604..93d16affce 100644 --- a/testsuite/tests/lib-threads/sockets.ml +++ b/testsuite/tests/lib-threads/sockets.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + open Printf (* Threads and sockets *) diff --git a/testsuite/tests/lib-threads/socketsbuf.ml b/testsuite/tests/lib-threads/socketsbuf.ml deleted file mode 100644 index 7eafb1bdb6..0000000000 --- a/testsuite/tests/lib-threads/socketsbuf.ml +++ /dev/null @@ -1,40 +0,0 @@ -open Printf - -(* Threads, sockets, and buffered I/O channels *) -(* Serves as a regression test for PR#5578 *) - -let serve_connection s = - let ic = Unix.in_channel_of_descr s - and oc = Unix.out_channel_of_descr s in - let l = input_line ic in - fprintf oc ">>%s\n" l; - close_out oc - -let server sock = - while true do - let (s, _) = Unix.accept sock in - ignore(Thread.create serve_connection s) - done - -let client (addr, msg) = - let sock = - Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in - Unix.connect sock addr; - let ic = Unix.in_channel_of_descr sock - and oc = Unix.out_channel_of_descr sock in - output_string oc msg; flush oc; - let l = input_line ic in - printf "%s\n%!" l - -let _ = - let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in - let sock = - Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in - Unix.setsockopt sock Unix.SO_REUSEADDR true; - Unix.bind sock addr; - let addr = Unix.getsockname sock in - Unix.listen sock 5; - ignore (Thread.create server sock); - ignore (Thread.create client (addr, "Client #1\n")); - Thread.delay 0.5; - client (addr, "Client #2\n") diff --git a/testsuite/tests/lib-threads/socketsbuf.reference b/testsuite/tests/lib-threads/socketsbuf.reference deleted file mode 100644 index a3f7067dff..0000000000 --- a/testsuite/tests/lib-threads/socketsbuf.reference +++ /dev/null @@ -1,2 +0,0 @@ ->>Client #1 ->>Client #2 diff --git a/testsuite/tests/lib-threads/swapchan.checker b/testsuite/tests/lib-threads/swapchan.checker deleted file mode 100644 index bf957adda6..0000000000 --- a/testsuite/tests/lib-threads/swapchan.checker +++ /dev/null @@ -1,16 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Damien Doligez, Projet Gallium, INRIA Rocquencourt * -#* * -#* Copyright 2015 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. * -#* * -#************************************************************************** - -$SORT swapchan.result | $DIFF swapchan.reference - >/dev/null diff --git a/testsuite/tests/lib-threads/swapchan.ml b/testsuite/tests/lib-threads/swapchan.ml index 1f80beb8f8..8d7f7522b0 100644 --- a/testsuite/tests/lib-threads/swapchan.ml +++ b/testsuite/tests/lib-threads/swapchan.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + open Event type 'a swap_chan = ('a * 'a channel) channel diff --git a/testsuite/tests/lib-threads/swapchan.run b/testsuite/tests/lib-threads/swapchan.run new file mode 100644 index 0000000000..1e3ecbb365 --- /dev/null +++ b/testsuite/tests/lib-threads/swapchan.run @@ -0,0 +1 @@ +${program} | ${SORT} > ${output} 2>&1 diff --git a/testsuite/tests/lib-threads/tls.checker b/testsuite/tests/lib-threads/tls.checker deleted file mode 100644 index b1d036b0ad..0000000000 --- a/testsuite/tests/lib-threads/tls.checker +++ /dev/null @@ -1,16 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -LC_ALL=C $SORT tls.result | $DIFF tls.reference - diff --git a/testsuite/tests/lib-threads/tls.ml b/testsuite/tests/lib-threads/tls.ml index 6db93fa902..c69db3885a 100644 --- a/testsuite/tests/lib-threads/tls.ml +++ b/testsuite/tests/lib-threads/tls.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t) let private_data_lock = Mutex.create() let output_lock = Mutex.create() diff --git a/testsuite/tests/lib-threads/tls.run b/testsuite/tests/lib-threads/tls.run new file mode 100644 index 0000000000..4b586e8fe5 --- /dev/null +++ b/testsuite/tests/lib-threads/tls.run @@ -0,0 +1 @@ +${program} | LC_ALL=C ${SORT} > ${output} 2>&1 diff --git a/testsuite/tests/lib-threads/token1.reference b/testsuite/tests/lib-threads/token1.reference deleted file mode 100644 index e69de29bb2..0000000000 --- a/testsuite/tests/lib-threads/token1.reference +++ /dev/null diff --git a/testsuite/tests/lib-threads/token2.reference b/testsuite/tests/lib-threads/token2.reference deleted file mode 100644 index e69de29bb2..0000000000 --- a/testsuite/tests/lib-threads/token2.reference +++ /dev/null diff --git a/testsuite/tests/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml index 9dba8addcd..9c4a84754f 100644 --- a/testsuite/tests/lib-threads/torture.ml +++ b/testsuite/tests/lib-threads/torture.ml @@ -1,3 +1,9 @@ +(* TEST + +include systhreads + +*) + (* Torture test - I/O interspersed with lots of GC *) let finished = ref false diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index 28fb4a4041..97103dd383 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7340,3 +7340,5 @@ module Indexop = struct h.Def.%{"three"} <- 3 let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"}) end + +type t = | diff --git a/testsuite/tests/parsing/Makefile b/testsuite/tests/parsing/Makefile deleted file mode 100644 index eac3f24604..0000000000 --- a/testsuite/tests/parsing/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Jeremie Dimino, Jane Street Europe * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -TOPFLAGS+=-dparsetree -include $(BASEDIR)/makefiles/Makefile.dparsetree -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/parsing/attributes.compilers.reference b/testsuite/tests/parsing/attributes.compilers.reference new file mode 100644 index 0000000000..bc3967be20 --- /dev/null +++ b/testsuite/tests/parsing/attributes.compilers.reference @@ -0,0 +1,153 @@ +[ + structure_item (attributes.ml[8,120+0]..[8,120+8]) + Pstr_attribute "foo" + [] + structure_item (attributes.ml[10,130+0]..[11,169+9]) + Pstr_value Nonrec + [ + <def> + attribute "foo" + [] + pattern (attributes.ml[10,130+4]..[10,130+38]) ghost + Ppat_constraint + pattern (attributes.ml[10,130+4]..[10,130+13]) + attribute "foo" + [] + Ppat_var "x" (attributes.ml[10,130+5]..[10,130+6]) + core_type (attributes.ml[10,130+16]..[10,130+20]) + attribute "foo" + [] + Ptyp_constr "unit" (attributes.ml[10,130+16]..[10,130+20]) + [] + expression (attributes.ml[10,130+30]..[10,130+32]) + attribute "foo" + [] + Pexp_construct "()" (attributes.ml[10,130+30]..[10,130+32]) + None + ] + structure_item (attributes.ml[13,180+0]..[15,217+7]) + Pstr_type Rec + [ + type_declaration "t" (attributes.ml[13,180+5]..[13,180+6]) (attributes.ml[13,180+0]..[15,217+7]) + attribute "foo" + [] + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_variant + [ + (attributes.ml[14,189+2]..[14,189+27]) + "Foo" (attributes.ml[14,189+4]..[14,189+7]) + attribute "foo" + [] + [ + core_type (attributes.ml[14,189+12]..[14,189+13]) + attribute "foo" + [] + Ptyp_constr "t" (attributes.ml[14,189+12]..[14,189+13]) + [] + ] + None + ] + ptype_private = Public + ptype_manifest = + None + ] + structure_item (attributes.ml[17,226+0]..[17,226+8]) + Pstr_attribute "foo" + [] + structure_item (attributes.ml[20,237+0]..[29,344+7]) + Pstr_module + "M" (attributes.ml[20,237+7]..[20,237+8]) + attribute "foo" + [] + module_expr (attributes.ml[20,237+11]..[28,334+3]) + attribute "foo" + [] + Pmod_structure + [ + structure_item (attributes.ml[21,255+2]..[25,310+11]) + Pstr_type Rec + [ + type_declaration "t" (attributes.ml[21,255+7]..[21,255+8]) (attributes.ml[21,255+2]..[25,310+11]) + attribute "foo" + [] + attribute "foo" + [] + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_record + [ + (attributes.ml[22,268+4]..[22,268+25]) + attribute "foo" + [] + Immutable + "l" (attributes.ml[22,268+4]..[22,268+5]) core_type (attributes.ml[22,268+9]..[22,268+10]) + attribute "foo" + [] + Ptyp_constr "t" (attributes.ml[22,268+9]..[22,268+10]) + [] + ] + ptype_private = Public + ptype_manifest = + None + ] + structure_item (attributes.ml[27,323+2]..[27,323+10]) + Pstr_attribute "foo" + [] + ] + structure_item (attributes.ml[31,353+0]..[39,477+7]) + Pstr_modtype "S" (attributes.ml[31,353+12]..[31,353+13]) + attribute "foo" + [] + module_type (attributes.ml[31,353+16]..[38,467+3]) + attribute "foo" + [] + Pmty_signature + [ + signature_item (attributes.ml[33,374+2]..[34,442+11]) + Psig_include + module_type (attributes.ml[33,374+10]..[33,374+61]) + attribute "foo" + [] + Pmty_with + module_type (attributes.ml[33,374+11]..[33,374+35]) + attribute "foo" + [] + Pmty_typeof + module_expr (attributes.ml[33,374+27]..[33,374+28]) + attribute "foo" + [] + Pmod_ident "M" (attributes.ml[33,374+27]..[33,374+28]) + [ + Pwith_typesubst "t" (attributes.ml[33,374+53]..[33,374+54]) + type_declaration "t" (attributes.ml[33,374+53]..[33,374+54]) (attributes.ml[33,374+48]..[33,374+61]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (attributes.ml[33,374+58]..[33,374+61]) + Ptyp_constr "M.t" (attributes.ml[33,374+58]..[33,374+61]) + [] + ] + attribute "foo" + [] + signature_item (attributes.ml[36,455+2]..[36,455+10]) + Psig_attribute "foo" + [] + ] + structure_item (attributes.ml[41,486+0]..[41,486+8]) + Pstr_attribute "foo" + [] +] + diff --git a/testsuite/tests/parsing/attributes.ml b/testsuite/tests/parsing/attributes.ml index 8276380e77..8bee64d670 100644 --- a/testsuite/tests/parsing/attributes.ml +++ b/testsuite/tests/parsing/attributes.ml @@ -1,3 +1,10 @@ +(* TEST + flags = "-dparsetree" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + [@@@foo] let (x[@foo]) : unit [@foo] = ()[@foo] diff --git a/testsuite/tests/parsing/attributes.ml.reference b/testsuite/tests/parsing/attributes.ml.reference deleted file mode 100644 index 5a39357fd9..0000000000 --- a/testsuite/tests/parsing/attributes.ml.reference +++ /dev/null @@ -1,153 +0,0 @@ -[ - structure_item (attributes.ml[1,0+0]..[1,0+8]) - Pstr_attribute "foo" - [] - structure_item (attributes.ml[3,10+0]..[4,49+9]) - Pstr_value Nonrec - [ - <def> - attribute "foo" - [] - pattern (attributes.ml[3,10+4]..[3,10+38]) ghost - Ppat_constraint - pattern (attributes.ml[3,10+4]..[3,10+13]) - attribute "foo" - [] - Ppat_var "x" (attributes.ml[3,10+5]..[3,10+6]) - core_type (attributes.ml[3,10+16]..[3,10+20]) - attribute "foo" - [] - Ptyp_constr "unit" (attributes.ml[3,10+16]..[3,10+20]) - [] - expression (attributes.ml[3,10+30]..[3,10+32]) - attribute "foo" - [] - Pexp_construct "()" (attributes.ml[3,10+30]..[3,10+32]) - None - ] - structure_item (attributes.ml[6,60+0]..[8,97+7]) - Pstr_type Rec - [ - type_declaration "t" (attributes.ml[6,60+5]..[6,60+6]) (attributes.ml[6,60+0]..[8,97+7]) - attribute "foo" - [] - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_variant - [ - (attributes.ml[7,69+2]..[7,69+27]) - "Foo" (attributes.ml[7,69+4]..[7,69+7]) - attribute "foo" - [] - [ - core_type (attributes.ml[7,69+12]..[7,69+13]) - attribute "foo" - [] - Ptyp_constr "t" (attributes.ml[7,69+12]..[7,69+13]) - [] - ] - None - ] - ptype_private = Public - ptype_manifest = - None - ] - structure_item (attributes.ml[10,106+0]..[10,106+8]) - Pstr_attribute "foo" - [] - structure_item (attributes.ml[13,117+0]..[22,224+7]) - Pstr_module - "M" (attributes.ml[13,117+7]..[13,117+8]) - attribute "foo" - [] - module_expr (attributes.ml[13,117+11]..[21,214+3]) - attribute "foo" - [] - Pmod_structure - [ - structure_item (attributes.ml[14,135+2]..[18,190+11]) - Pstr_type Rec - [ - type_declaration "t" (attributes.ml[14,135+7]..[14,135+8]) (attributes.ml[14,135+2]..[18,190+11]) - attribute "foo" - [] - attribute "foo" - [] - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_record - [ - (attributes.ml[15,148+4]..[15,148+25]) - attribute "foo" - [] - Immutable - "l" (attributes.ml[15,148+4]..[15,148+5]) core_type (attributes.ml[15,148+9]..[15,148+10]) - attribute "foo" - [] - Ptyp_constr "t" (attributes.ml[15,148+9]..[15,148+10]) - [] - ] - ptype_private = Public - ptype_manifest = - None - ] - structure_item (attributes.ml[20,203+2]..[20,203+10]) - Pstr_attribute "foo" - [] - ] - structure_item (attributes.ml[24,233+0]..[32,357+7]) - Pstr_modtype "S" (attributes.ml[24,233+12]..[24,233+13]) - attribute "foo" - [] - module_type (attributes.ml[24,233+16]..[31,347+3]) - attribute "foo" - [] - Pmty_signature - [ - signature_item (attributes.ml[26,254+2]..[27,322+11]) - Psig_include - module_type (attributes.ml[26,254+10]..[26,254+61]) - attribute "foo" - [] - Pmty_with - module_type (attributes.ml[26,254+11]..[26,254+35]) - attribute "foo" - [] - Pmty_typeof - module_expr (attributes.ml[26,254+27]..[26,254+28]) - attribute "foo" - [] - Pmod_ident "M" (attributes.ml[26,254+27]..[26,254+28]) - [ - Pwith_typesubst "t" (attributes.ml[26,254+53]..[26,254+54]) - type_declaration "t" (attributes.ml[26,254+53]..[26,254+54]) (attributes.ml[26,254+48]..[26,254+61]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (attributes.ml[26,254+58]..[26,254+61]) - Ptyp_constr "M.t" (attributes.ml[26,254+58]..[26,254+61]) - [] - ] - attribute "foo" - [] - signature_item (attributes.ml[29,335+2]..[29,335+10]) - Psig_attribute "foo" - [] - ] - structure_item (attributes.ml[34,366+0]..[34,366+8]) - Pstr_attribute "foo" - [] -] - diff --git a/testsuite/tests/parsing/docstrings.compilers.reference b/testsuite/tests/parsing/docstrings.compilers.reference new file mode 100644 index 0000000000..579d98793f --- /dev/null +++ b/testsuite/tests/parsing/docstrings.compilers.reference @@ -0,0 +1,146 @@ +[ + structure_item (docstrings.ml[8,120+0]..[11,225+7]) + Pstr_type Rec + [ + type_declaration "with_default" (docstrings.ml[8,120+8]..[8,120+20]) (docstrings.ml[8,120+0]..[11,225+7]) + ptype_params = + [ + core_type (docstrings.ml[8,120+5]..[8,120+7]) + Ptyp_var a + ] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (docstrings.ml[9,141+5]..[11,225+7]) + Ptyp_arrow + Optional "size" + core_type (docstrings.ml[9,141+11]..[9,141+14]) + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[9,141+21]..[9,141+40]) + Pstr_eval + expression (docstrings.ml[9,141+21]..[9,141+40]) + Pexp_constant PConst_string(" default [42] ",None) + ] + Ptyp_constr "int" (docstrings.ml[9,141+11]..[9,141+14]) + [] + core_type (docstrings.ml[10,182+5]..[11,225+7]) + Ptyp_arrow + Optional "resizable" + core_type (docstrings.ml[10,182+16]..[10,182+20]) + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[10,182+21]..[10,182+42]) + Pstr_eval + expression (docstrings.ml[10,182+21]..[10,182+42]) + Pexp_constant PConst_string(" default [true] ",None) + ] + Ptyp_constr "bool" (docstrings.ml[10,182+16]..[10,182+20]) + [] + core_type (docstrings.ml[11,225+5]..[11,225+7]) + Ptyp_var a + ] + structure_item (docstrings.ml[13,234+0]..[18,328+1]) + Pstr_type Rec + [ + type_declaration "obj" (docstrings.ml[13,234+5]..[13,234+8]) (docstrings.ml[13,234+0]..[18,328+1]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (docstrings.ml[13,234+11]..[18,328+1]) + Ptyp_object Closed + method meth1 + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[15,269+2]..[15,269+17]) + Pstr_eval + expression (docstrings.ml[15,269+2]..[15,269+17]) + Pexp_constant PConst_string(" method 1 ",None) + ] + core_type (docstrings.ml[14,247+10]..[14,247+20]) + Ptyp_arrow + Nolabel + core_type (docstrings.ml[14,247+10]..[14,247+13]) + Ptyp_constr "int" (docstrings.ml[14,247+10]..[14,247+13]) + [] + core_type (docstrings.ml[14,247+17]..[14,247+20]) + Ptyp_constr "int" (docstrings.ml[14,247+17]..[14,247+20]) + [] + method meth2 + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[17,288+23]..[17,288+38]) + Pstr_eval + expression (docstrings.ml[17,288+23]..[17,288+38]) + Pexp_constant PConst_string(" method 2 ",None) + ] + core_type (docstrings.ml[17,288+9]..[17,288+22]) + Ptyp_arrow + Nolabel + core_type (docstrings.ml[17,288+9]..[17,288+13]) + Ptyp_constr "unit" (docstrings.ml[17,288+9]..[17,288+13]) + [] + core_type (docstrings.ml[17,288+17]..[17,288+22]) + Ptyp_constr "float" (docstrings.ml[17,288+17]..[17,288+22]) + [] + ] + structure_item (docstrings.ml[20,331+0]..[23,400+1]) + Pstr_type Rec + [ + type_declaration "var" (docstrings.ml[20,331+5]..[20,331+8]) (docstrings.ml[20,331+0]..[23,400+1]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (docstrings.ml[20,331+11]..[23,400+1]) + Ptyp_variant closed=Closed + [ + Rtag "Foo" true + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[21,344+9]..[21,344+19]) + Pstr_eval + expression (docstrings.ml[21,344+9]..[21,344+19]) + Pexp_constant PConst_string(" foo ",None) + ] + [] + Rtag "Bar" false + attribute "ocaml.doc" + [ + structure_item (docstrings.ml[22,364+25]..[22,364+35]) + Pstr_eval + expression (docstrings.ml[22,364+25]..[22,364+35]) + Pexp_constant PConst_string(" bar ",None) + ] + [ + core_type (docstrings.ml[22,364+12]..[22,364+24]) + Ptyp_tuple + [ + core_type (docstrings.ml[22,364+12]..[22,364+15]) + Ptyp_constr "int" (docstrings.ml[22,364+12]..[22,364+15]) + [] + core_type (docstrings.ml[22,364+18]..[22,364+24]) + Ptyp_constr "string" (docstrings.ml[22,364+18]..[22,364+24]) + [] + ] + ] + ] + None + ] +] + diff --git a/testsuite/tests/parsing/docstrings.ml b/testsuite/tests/parsing/docstrings.ml index ea8471133b..ef35d52fad 100644 --- a/testsuite/tests/parsing/docstrings.ml +++ b/testsuite/tests/parsing/docstrings.ml @@ -1,3 +1,10 @@ +(* TEST + flags = "-dparsetree" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + type 'a with_default = ?size:int (** default [42] *) -> ?resizable:bool (** default [true] *) diff --git a/testsuite/tests/parsing/docstrings.ml.reference b/testsuite/tests/parsing/docstrings.ml.reference deleted file mode 100644 index da40ede715..0000000000 --- a/testsuite/tests/parsing/docstrings.ml.reference +++ /dev/null @@ -1,146 +0,0 @@ -[ - structure_item (docstrings.ml[1,0+0]..[4,105+7]) - Pstr_type Rec - [ - type_declaration "with_default" (docstrings.ml[1,0+8]..[1,0+20]) (docstrings.ml[1,0+0]..[4,105+7]) - ptype_params = - [ - core_type (docstrings.ml[1,0+5]..[1,0+7]) - Ptyp_var a - ] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (docstrings.ml[2,21+5]..[4,105+7]) - Ptyp_arrow - Optional "size" - core_type (docstrings.ml[2,21+11]..[2,21+14]) - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[2,21+21]..[2,21+40]) - Pstr_eval - expression (docstrings.ml[2,21+21]..[2,21+40]) - Pexp_constant PConst_string(" default [42] ",None) - ] - Ptyp_constr "int" (docstrings.ml[2,21+11]..[2,21+14]) - [] - core_type (docstrings.ml[3,62+5]..[4,105+7]) - Ptyp_arrow - Optional "resizable" - core_type (docstrings.ml[3,62+16]..[3,62+20]) - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[3,62+21]..[3,62+42]) - Pstr_eval - expression (docstrings.ml[3,62+21]..[3,62+42]) - Pexp_constant PConst_string(" default [true] ",None) - ] - Ptyp_constr "bool" (docstrings.ml[3,62+16]..[3,62+20]) - [] - core_type (docstrings.ml[4,105+5]..[4,105+7]) - Ptyp_var a - ] - structure_item (docstrings.ml[6,114+0]..[11,208+1]) - Pstr_type Rec - [ - type_declaration "obj" (docstrings.ml[6,114+5]..[6,114+8]) (docstrings.ml[6,114+0]..[11,208+1]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (docstrings.ml[6,114+11]..[11,208+1]) - Ptyp_object Closed - method meth1 - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[8,149+2]..[8,149+17]) - Pstr_eval - expression (docstrings.ml[8,149+2]..[8,149+17]) - Pexp_constant PConst_string(" method 1 ",None) - ] - core_type (docstrings.ml[7,127+10]..[7,127+20]) - Ptyp_arrow - Nolabel - core_type (docstrings.ml[7,127+10]..[7,127+13]) - Ptyp_constr "int" (docstrings.ml[7,127+10]..[7,127+13]) - [] - core_type (docstrings.ml[7,127+17]..[7,127+20]) - Ptyp_constr "int" (docstrings.ml[7,127+17]..[7,127+20]) - [] - method meth2 - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[10,168+23]..[10,168+38]) - Pstr_eval - expression (docstrings.ml[10,168+23]..[10,168+38]) - Pexp_constant PConst_string(" method 2 ",None) - ] - core_type (docstrings.ml[10,168+9]..[10,168+22]) - Ptyp_arrow - Nolabel - core_type (docstrings.ml[10,168+9]..[10,168+13]) - Ptyp_constr "unit" (docstrings.ml[10,168+9]..[10,168+13]) - [] - core_type (docstrings.ml[10,168+17]..[10,168+22]) - Ptyp_constr "float" (docstrings.ml[10,168+17]..[10,168+22]) - [] - ] - structure_item (docstrings.ml[13,211+0]..[16,280+1]) - Pstr_type Rec - [ - type_declaration "var" (docstrings.ml[13,211+5]..[13,211+8]) (docstrings.ml[13,211+0]..[16,280+1]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (docstrings.ml[13,211+11]..[16,280+1]) - Ptyp_variant closed=Closed - [ - Rtag "Foo" true - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[14,224+9]..[14,224+19]) - Pstr_eval - expression (docstrings.ml[14,224+9]..[14,224+19]) - Pexp_constant PConst_string(" foo ",None) - ] - [] - Rtag "Bar" false - attribute "ocaml.doc" - [ - structure_item (docstrings.ml[15,244+25]..[15,244+35]) - Pstr_eval - expression (docstrings.ml[15,244+25]..[15,244+35]) - Pexp_constant PConst_string(" bar ",None) - ] - [ - core_type (docstrings.ml[15,244+12]..[15,244+24]) - Ptyp_tuple - [ - core_type (docstrings.ml[15,244+12]..[15,244+15]) - Ptyp_constr "int" (docstrings.ml[15,244+12]..[15,244+15]) - [] - core_type (docstrings.ml[15,244+18]..[15,244+24]) - Ptyp_constr "string" (docstrings.ml[15,244+18]..[15,244+24]) - [] - ] - ] - ] - None - ] -] - diff --git a/testsuite/tests/parsing/extended_indexoperators.compilers.reference b/testsuite/tests/parsing/extended_indexoperators.compilers.reference new file mode 100644 index 0000000000..64517ccb11 --- /dev/null +++ b/testsuite/tests/parsing/extended_indexoperators.compilers.reference @@ -0,0 +1,391 @@ +[ + structure_item (extended_indexoperators.ml[8,120+0]..[8,120+29]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[8,120+4]..[8,120+10]) + Ppat_var ".?[]" (extended_indexoperators.ml[8,120+4]..[8,120+10]) + expression (extended_indexoperators.ml[8,120+13]..[8,120+29]) + Pexp_ident "Hashtbl.find_opt" (extended_indexoperators.ml[8,120+13]..[8,120+29]) + ] + structure_item (extended_indexoperators.ml[9,150+0]..[9,150+25]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[9,150+4]..[9,150+10]) + Ppat_var ".@[]" (extended_indexoperators.ml[9,150+4]..[9,150+10]) + expression (extended_indexoperators.ml[9,150+13]..[9,150+25]) + Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[9,150+13]..[9,150+25]) + ] + structure_item (extended_indexoperators.ml[10,176+0]..[10,176+28]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[10,176+4]..[10,176+14]) + Ppat_var ".@[]<-" (extended_indexoperators.ml[10,176+4]..[10,176+14]) + expression (extended_indexoperators.ml[10,176+17]..[10,176+28]) + Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[10,176+17]..[10,176+28]) + ] + structure_item (extended_indexoperators.ml[11,205+0]..[11,205+25]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[11,205+4]..[11,205+10]) + Ppat_var ".@{}" (extended_indexoperators.ml[11,205+4]..[11,205+10]) + expression (extended_indexoperators.ml[11,205+13]..[11,205+25]) + Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[11,205+13]..[11,205+25]) + ] + structure_item (extended_indexoperators.ml[12,231+0]..[12,231+28]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[12,231+4]..[12,231+14]) + Ppat_var ".@{}<-" (extended_indexoperators.ml[12,231+4]..[12,231+14]) + expression (extended_indexoperators.ml[12,231+17]..[12,231+28]) + Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[12,231+17]..[12,231+28]) + ] + structure_item (extended_indexoperators.ml[13,260+0]..[13,260+25]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[13,260+4]..[13,260+10]) + Ppat_var ".@()" (extended_indexoperators.ml[13,260+4]..[13,260+10]) + expression (extended_indexoperators.ml[13,260+13]..[13,260+25]) + Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[13,260+13]..[13,260+25]) + ] + structure_item (extended_indexoperators.ml[14,286+0]..[14,286+28]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[14,286+4]..[14,286+14]) + Ppat_var ".@()<-" (extended_indexoperators.ml[14,286+4]..[14,286+14]) + expression (extended_indexoperators.ml[14,286+17]..[14,286+28]) + Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[14,286+17]..[14,286+28]) + ] + structure_item (extended_indexoperators.ml[16,316+0]..[16,316+25]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[16,316+4]..[16,316+5]) + Ppat_var "h" (extended_indexoperators.ml[16,316+4]..[16,316+5]) + expression (extended_indexoperators.ml[16,316+8]..[16,316+25]) + Pexp_apply + expression (extended_indexoperators.ml[16,316+8]..[16,316+22]) + Pexp_ident "Hashtbl.create" (extended_indexoperators.ml[16,316+8]..[16,316+22]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[16,316+23]..[16,316+25]) + Pexp_constant PConst_int (17,None) + ] + ] + structure_item (extended_indexoperators.ml[19,346+2]..[22,413+28]) + Pstr_eval + expression (extended_indexoperators.ml[19,346+2]..[22,413+28]) + Pexp_sequence + expression (extended_indexoperators.ml[19,346+2]..[19,346+17]) + Pexp_apply + expression (extended_indexoperators.ml[19,346+2]..[19,346+17]) + Pexp_ident ".@()<-" (extended_indexoperators.ml[19,346+2]..[19,346+17]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[19,346+2]..[19,346+3]) + Pexp_ident "h" (extended_indexoperators.ml[19,346+2]..[19,346+3]) + <arg> + Nolabel + expression (extended_indexoperators.ml[19,346+6]..[19,346+11]) + Pexp_constant PConst_string("One",None) + <arg> + Nolabel + expression (extended_indexoperators.ml[19,346+16]..[19,346+17]) + Pexp_constant PConst_int (1,None) + ] + expression (extended_indexoperators.ml[20,364+2]..[22,413+28]) + Pexp_sequence + expression (extended_indexoperators.ml[20,364+2]..[20,364+25]) + Pexp_assert + expression (extended_indexoperators.ml[20,364+9]..[20,364+25]) + Pexp_apply + expression (extended_indexoperators.ml[20,364+21]..[20,364+22]) + Pexp_ident "=" (extended_indexoperators.ml[20,364+21]..[20,364+22]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[20,364+10]..[20,364+20]) + Pexp_apply + expression (extended_indexoperators.ml[20,364+10]..[20,364+20]) + Pexp_ident ".@{}" (extended_indexoperators.ml[20,364+10]..[20,364+20]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[20,364+10]..[20,364+11]) + Pexp_ident "h" (extended_indexoperators.ml[20,364+10]..[20,364+11]) + <arg> + Nolabel + expression (extended_indexoperators.ml[20,364+14]..[20,364+19]) + Pexp_constant PConst_string("One",None) + ] + <arg> + Nolabel + expression (extended_indexoperators.ml[20,364+23]..[20,364+24]) + Pexp_constant PConst_int (1,None) + ] + expression (extended_indexoperators.ml[21,390+2]..[22,413+28]) + Pexp_sequence + expression (extended_indexoperators.ml[21,390+2]..[21,390+22]) + Pexp_apply + expression (extended_indexoperators.ml[21,390+2]..[21,390+11]) + Pexp_ident "print_int" (extended_indexoperators.ml[21,390+2]..[21,390+11]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[21,390+12]..[21,390+22]) + Pexp_apply + expression (extended_indexoperators.ml[21,390+12]..[21,390+22]) + Pexp_ident ".@{}" (extended_indexoperators.ml[21,390+12]..[21,390+22]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[21,390+12]..[21,390+13]) + Pexp_ident "h" (extended_indexoperators.ml[21,390+12]..[21,390+13]) + <arg> + Nolabel + expression (extended_indexoperators.ml[21,390+16]..[21,390+21]) + Pexp_constant PConst_string("One",None) + ] + ] + expression (extended_indexoperators.ml[22,413+2]..[22,413+28]) + Pexp_assert + expression (extended_indexoperators.ml[22,413+9]..[22,413+28]) + Pexp_apply + expression (extended_indexoperators.ml[22,413+21]..[22,413+22]) + Pexp_ident "=" (extended_indexoperators.ml[22,413+21]..[22,413+22]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[22,413+10]..[22,413+20]) + Pexp_apply + expression (extended_indexoperators.ml[22,413+10]..[22,413+20]) + Pexp_ident ".?[]" (extended_indexoperators.ml[22,413+10]..[22,413+20]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[22,413+10]..[22,413+11]) + Pexp_ident "h" (extended_indexoperators.ml[22,413+10]..[22,413+11]) + <arg> + Nolabel + expression (extended_indexoperators.ml[22,413+14]..[22,413+19]) + Pexp_constant PConst_string("Two",None) + ] + <arg> + Nolabel + expression (extended_indexoperators.ml[22,413+23]..[22,413+27]) + Pexp_construct "None" (extended_indexoperators.ml[22,413+23]..[22,413+27]) + None + ] + structure_item (extended_indexoperators.ml[26,464+0]..[26,464+23]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[26,464+4]..[26,464+10]) + Ppat_var "#?" (extended_indexoperators.ml[26,464+4]..[26,464+10]) + expression (extended_indexoperators.ml[26,464+11]..[26,464+23]) ghost + Pexp_fun + Nolabel + None + pattern (extended_indexoperators.ml[26,464+11]..[26,464+12]) + Ppat_var "x" (extended_indexoperators.ml[26,464+11]..[26,464+12]) + expression (extended_indexoperators.ml[26,464+13]..[26,464+23]) ghost + Pexp_fun + Nolabel + None + pattern (extended_indexoperators.ml[26,464+13]..[26,464+14]) + Ppat_var "y" (extended_indexoperators.ml[26,464+13]..[26,464+14]) + expression (extended_indexoperators.ml[26,464+17]..[26,464+23]) + Pexp_tuple + [ + expression (extended_indexoperators.ml[26,464+18]..[26,464+19]) + Pexp_ident "x" (extended_indexoperators.ml[26,464+18]..[26,464+19]) + expression (extended_indexoperators.ml[26,464+21]..[26,464+22]) + Pexp_ident "y" (extended_indexoperators.ml[26,464+21]..[26,464+22]) + ] + ] + structure_item (extended_indexoperators.ml[27,490+0]..[27,490+24]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[27,490+4]..[27,490+12]) + Ppat_var ".%()" (extended_indexoperators.ml[27,490+4]..[27,490+12]) + expression (extended_indexoperators.ml[27,490+13]..[27,490+24]) ghost + Pexp_fun + Nolabel + None + pattern (extended_indexoperators.ml[27,490+13]..[27,490+14]) + Ppat_var "x" (extended_indexoperators.ml[27,490+13]..[27,490+14]) + expression (extended_indexoperators.ml[27,490+15]..[27,490+24]) ghost + Pexp_fun + Nolabel + None + pattern (extended_indexoperators.ml[27,490+15]..[27,490+16]) + Ppat_var "y" (extended_indexoperators.ml[27,490+15]..[27,490+16]) + expression (extended_indexoperators.ml[27,490+19]..[27,490+24]) + Pexp_apply + expression (extended_indexoperators.ml[27,490+19]..[27,490+24]) ghost + Pexp_ident "Array.get" (extended_indexoperators.ml[27,490+19]..[27,490+24]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[27,490+19]..[27,490+20]) + Pexp_ident "x" (extended_indexoperators.ml[27,490+19]..[27,490+20]) + <arg> + Nolabel + expression (extended_indexoperators.ml[27,490+22]..[27,490+23]) + Pexp_ident "y" (extended_indexoperators.ml[27,490+22]..[27,490+23]) + ] + ] + structure_item (extended_indexoperators.ml[28,517+0]..[28,517+15]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[28,517+4]..[28,517+5]) + Ppat_var "x" (extended_indexoperators.ml[28,517+4]..[28,517+5]) + expression (extended_indexoperators.ml[28,517+8]..[28,517+15]) + Pexp_array + [ + expression (extended_indexoperators.ml[28,517+11]..[28,517+12]) + Pexp_constant PConst_int (0,None) + ] + ] + structure_item (extended_indexoperators.ml[29,535+0]..[29,535+18]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[29,535+4]..[29,535+5]) + Ppat_any + expression (extended_indexoperators.ml[29,535+8]..[29,535+18]) + Pexp_apply + expression (extended_indexoperators.ml[29,535+10]..[29,535+12]) + Pexp_ident "#?" (extended_indexoperators.ml[29,535+10]..[29,535+12]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[29,535+8]..[29,535+9]) + Pexp_constant PConst_int (1,None) + <arg> + Nolabel + expression (extended_indexoperators.ml[29,535+13]..[29,535+18]) + Pexp_apply + expression (extended_indexoperators.ml[29,535+13]..[29,535+18]) ghost + Pexp_ident "Array.get" (extended_indexoperators.ml[29,535+13]..[29,535+18]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[29,535+13]..[29,535+14]) + Pexp_ident "x" (extended_indexoperators.ml[29,535+13]..[29,535+14]) + <arg> + Nolabel + expression (extended_indexoperators.ml[29,535+16]..[29,535+17]) + Pexp_constant PConst_int (0,None) + ] + ] + ] + structure_item (extended_indexoperators.ml[30,556+0]..[30,556+19]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[30,556+4]..[30,556+5]) + Ppat_any + expression (extended_indexoperators.ml[30,556+8]..[30,556+19]) + Pexp_apply + expression (extended_indexoperators.ml[30,556+10]..[30,556+12]) + Pexp_ident "#?" (extended_indexoperators.ml[30,556+10]..[30,556+12]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[30,556+8]..[30,556+9]) + Pexp_constant PConst_int (1,None) + <arg> + Nolabel + expression (extended_indexoperators.ml[30,556+13]..[30,556+19]) + Pexp_apply + expression (extended_indexoperators.ml[30,556+13]..[30,556+19]) + Pexp_ident ".%()" (extended_indexoperators.ml[30,556+13]..[30,556+19]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[30,556+13]..[30,556+14]) + Pexp_ident "x" (extended_indexoperators.ml[30,556+13]..[30,556+14]) + <arg> + Nolabel + expression (extended_indexoperators.ml[30,556+17]..[30,556+18]) + Pexp_constant PConst_int (0,None) + ] + ] + ] + structure_item (extended_indexoperators.ml[33,599+0]..[33,599+22]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[33,599+4]..[33,599+5]) + Ppat_any + expression (extended_indexoperators.ml[33,599+8]..[33,599+22]) + Pexp_apply + expression (extended_indexoperators.ml[33,599+8]..[33,599+22]) + Pexp_ident ".%()" (extended_indexoperators.ml[33,599+8]..[33,599+22]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[33,599+8]..[33,599+9]) + Pexp_ident "x" (extended_indexoperators.ml[33,599+8]..[33,599+9]) + <arg> + Nolabel + expression (extended_indexoperators.ml[33,599+12]..[33,599+21]) + Pexp_sequence + expression (extended_indexoperators.ml[33,599+12]..[33,599+14]) + Pexp_construct "()" (extended_indexoperators.ml[33,599+12]..[33,599+14]) + None + expression (extended_indexoperators.ml[33,599+16]..[33,599+21]) + Pexp_sequence + expression (extended_indexoperators.ml[33,599+16]..[33,599+18]) + Pexp_construct "()" (extended_indexoperators.ml[33,599+16]..[33,599+18]) + None + expression (extended_indexoperators.ml[33,599+20]..[33,599+21]) + Pexp_constant PConst_int (0,None) + ] + ] + structure_item (extended_indexoperators.ml[34,622+0]..[34,622+37]) + Pstr_value Nonrec + [ + <def> + pattern (extended_indexoperators.ml[34,622+4]..[34,622+5]) + Ppat_any + expression (extended_indexoperators.ml[34,622+8]..[34,622+37]) + Pexp_apply + expression (extended_indexoperators.ml[34,622+8]..[34,622+37]) + Pexp_ident ".%()" (extended_indexoperators.ml[34,622+8]..[34,622+37]) ghost + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[34,622+8]..[34,622+9]) + Pexp_ident "x" (extended_indexoperators.ml[34,622+8]..[34,622+9]) + <arg> + Nolabel + expression (extended_indexoperators.ml[34,622+12]..[34,622+36]) + Pexp_sequence + expression (extended_indexoperators.ml[34,622+12]..[34,622+33]) + Pexp_apply + expression (extended_indexoperators.ml[34,622+12]..[34,622+25]) + Pexp_ident "print_endline" (extended_indexoperators.ml[34,622+12]..[34,622+25]) + [ + <arg> + Nolabel + expression (extended_indexoperators.ml[34,622+26]..[34,622+33]) + Pexp_constant PConst_string("hello",None) + ] + expression (extended_indexoperators.ml[34,622+35]..[34,622+36]) + Pexp_constant PConst_int (0,None) + ] + ] +] + diff --git a/testsuite/tests/parsing/extended_indexoperators.ml b/testsuite/tests/parsing/extended_indexoperators.ml index 490c767cbf..cc45ea5b60 100644 --- a/testsuite/tests/parsing/extended_indexoperators.ml +++ b/testsuite/tests/parsing/extended_indexoperators.ml @@ -1,3 +1,10 @@ +(* TEST + flags = "-dparsetree" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + let (.?[]) = Hashtbl.find_opt let (.@[]) = Hashtbl.find let ( .@[]<- ) = Hashtbl.add diff --git a/testsuite/tests/parsing/extended_indexoperators.ml.reference b/testsuite/tests/parsing/extended_indexoperators.ml.reference deleted file mode 100644 index 54e0f6a972..0000000000 --- a/testsuite/tests/parsing/extended_indexoperators.ml.reference +++ /dev/null @@ -1,391 +0,0 @@ -[ - structure_item (extended_indexoperators.ml[1,0+0]..[1,0+29]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[1,0+4]..[1,0+10]) - Ppat_var ".?[]" (extended_indexoperators.ml[1,0+4]..[1,0+10]) - expression (extended_indexoperators.ml[1,0+13]..[1,0+29]) - Pexp_ident "Hashtbl.find_opt" (extended_indexoperators.ml[1,0+13]..[1,0+29]) - ] - structure_item (extended_indexoperators.ml[2,30+0]..[2,30+25]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[2,30+4]..[2,30+10]) - Ppat_var ".@[]" (extended_indexoperators.ml[2,30+4]..[2,30+10]) - expression (extended_indexoperators.ml[2,30+13]..[2,30+25]) - Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[2,30+13]..[2,30+25]) - ] - structure_item (extended_indexoperators.ml[3,56+0]..[3,56+28]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[3,56+4]..[3,56+14]) - Ppat_var ".@[]<-" (extended_indexoperators.ml[3,56+4]..[3,56+14]) - expression (extended_indexoperators.ml[3,56+17]..[3,56+28]) - Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[3,56+17]..[3,56+28]) - ] - structure_item (extended_indexoperators.ml[4,85+0]..[4,85+25]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[4,85+4]..[4,85+10]) - Ppat_var ".@{}" (extended_indexoperators.ml[4,85+4]..[4,85+10]) - expression (extended_indexoperators.ml[4,85+13]..[4,85+25]) - Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[4,85+13]..[4,85+25]) - ] - structure_item (extended_indexoperators.ml[5,111+0]..[5,111+28]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[5,111+4]..[5,111+14]) - Ppat_var ".@{}<-" (extended_indexoperators.ml[5,111+4]..[5,111+14]) - expression (extended_indexoperators.ml[5,111+17]..[5,111+28]) - Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[5,111+17]..[5,111+28]) - ] - structure_item (extended_indexoperators.ml[6,140+0]..[6,140+25]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[6,140+4]..[6,140+10]) - Ppat_var ".@()" (extended_indexoperators.ml[6,140+4]..[6,140+10]) - expression (extended_indexoperators.ml[6,140+13]..[6,140+25]) - Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[6,140+13]..[6,140+25]) - ] - structure_item (extended_indexoperators.ml[7,166+0]..[7,166+28]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[7,166+4]..[7,166+14]) - Ppat_var ".@()<-" (extended_indexoperators.ml[7,166+4]..[7,166+14]) - expression (extended_indexoperators.ml[7,166+17]..[7,166+28]) - Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[7,166+17]..[7,166+28]) - ] - structure_item (extended_indexoperators.ml[9,196+0]..[9,196+25]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[9,196+4]..[9,196+5]) - Ppat_var "h" (extended_indexoperators.ml[9,196+4]..[9,196+5]) - expression (extended_indexoperators.ml[9,196+8]..[9,196+25]) - Pexp_apply - expression (extended_indexoperators.ml[9,196+8]..[9,196+22]) - Pexp_ident "Hashtbl.create" (extended_indexoperators.ml[9,196+8]..[9,196+22]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[9,196+23]..[9,196+25]) - Pexp_constant PConst_int (17,None) - ] - ] - structure_item (extended_indexoperators.ml[12,226+2]..[15,293+28]) - Pstr_eval - expression (extended_indexoperators.ml[12,226+2]..[15,293+28]) - Pexp_sequence - expression (extended_indexoperators.ml[12,226+2]..[12,226+17]) - Pexp_apply - expression (extended_indexoperators.ml[12,226+2]..[12,226+17]) - Pexp_ident ".@()<-" (extended_indexoperators.ml[12,226+2]..[12,226+17]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[12,226+2]..[12,226+3]) - Pexp_ident "h" (extended_indexoperators.ml[12,226+2]..[12,226+3]) - <arg> - Nolabel - expression (extended_indexoperators.ml[12,226+6]..[12,226+11]) - Pexp_constant PConst_string("One",None) - <arg> - Nolabel - expression (extended_indexoperators.ml[12,226+16]..[12,226+17]) - Pexp_constant PConst_int (1,None) - ] - expression (extended_indexoperators.ml[13,244+2]..[15,293+28]) - Pexp_sequence - expression (extended_indexoperators.ml[13,244+2]..[13,244+25]) - Pexp_assert - expression (extended_indexoperators.ml[13,244+9]..[13,244+25]) - Pexp_apply - expression (extended_indexoperators.ml[13,244+21]..[13,244+22]) - Pexp_ident "=" (extended_indexoperators.ml[13,244+21]..[13,244+22]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[13,244+10]..[13,244+20]) - Pexp_apply - expression (extended_indexoperators.ml[13,244+10]..[13,244+20]) - Pexp_ident ".@{}" (extended_indexoperators.ml[13,244+10]..[13,244+20]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[13,244+10]..[13,244+11]) - Pexp_ident "h" (extended_indexoperators.ml[13,244+10]..[13,244+11]) - <arg> - Nolabel - expression (extended_indexoperators.ml[13,244+14]..[13,244+19]) - Pexp_constant PConst_string("One",None) - ] - <arg> - Nolabel - expression (extended_indexoperators.ml[13,244+23]..[13,244+24]) - Pexp_constant PConst_int (1,None) - ] - expression (extended_indexoperators.ml[14,270+2]..[15,293+28]) - Pexp_sequence - expression (extended_indexoperators.ml[14,270+2]..[14,270+22]) - Pexp_apply - expression (extended_indexoperators.ml[14,270+2]..[14,270+11]) - Pexp_ident "print_int" (extended_indexoperators.ml[14,270+2]..[14,270+11]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[14,270+12]..[14,270+22]) - Pexp_apply - expression (extended_indexoperators.ml[14,270+12]..[14,270+22]) - Pexp_ident ".@{}" (extended_indexoperators.ml[14,270+12]..[14,270+22]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[14,270+12]..[14,270+13]) - Pexp_ident "h" (extended_indexoperators.ml[14,270+12]..[14,270+13]) - <arg> - Nolabel - expression (extended_indexoperators.ml[14,270+16]..[14,270+21]) - Pexp_constant PConst_string("One",None) - ] - ] - expression (extended_indexoperators.ml[15,293+2]..[15,293+28]) - Pexp_assert - expression (extended_indexoperators.ml[15,293+9]..[15,293+28]) - Pexp_apply - expression (extended_indexoperators.ml[15,293+21]..[15,293+22]) - Pexp_ident "=" (extended_indexoperators.ml[15,293+21]..[15,293+22]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[15,293+10]..[15,293+20]) - Pexp_apply - expression (extended_indexoperators.ml[15,293+10]..[15,293+20]) - Pexp_ident ".?[]" (extended_indexoperators.ml[15,293+10]..[15,293+20]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[15,293+10]..[15,293+11]) - Pexp_ident "h" (extended_indexoperators.ml[15,293+10]..[15,293+11]) - <arg> - Nolabel - expression (extended_indexoperators.ml[15,293+14]..[15,293+19]) - Pexp_constant PConst_string("Two",None) - ] - <arg> - Nolabel - expression (extended_indexoperators.ml[15,293+23]..[15,293+27]) - Pexp_construct "None" (extended_indexoperators.ml[15,293+23]..[15,293+27]) - None - ] - structure_item (extended_indexoperators.ml[19,344+0]..[19,344+23]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[19,344+4]..[19,344+10]) - Ppat_var "#?" (extended_indexoperators.ml[19,344+4]..[19,344+10]) - expression (extended_indexoperators.ml[19,344+11]..[19,344+23]) ghost - Pexp_fun - Nolabel - None - pattern (extended_indexoperators.ml[19,344+11]..[19,344+12]) - Ppat_var "x" (extended_indexoperators.ml[19,344+11]..[19,344+12]) - expression (extended_indexoperators.ml[19,344+13]..[19,344+23]) ghost - Pexp_fun - Nolabel - None - pattern (extended_indexoperators.ml[19,344+13]..[19,344+14]) - Ppat_var "y" (extended_indexoperators.ml[19,344+13]..[19,344+14]) - expression (extended_indexoperators.ml[19,344+17]..[19,344+23]) - Pexp_tuple - [ - expression (extended_indexoperators.ml[19,344+18]..[19,344+19]) - Pexp_ident "x" (extended_indexoperators.ml[19,344+18]..[19,344+19]) - expression (extended_indexoperators.ml[19,344+21]..[19,344+22]) - Pexp_ident "y" (extended_indexoperators.ml[19,344+21]..[19,344+22]) - ] - ] - structure_item (extended_indexoperators.ml[20,370+0]..[20,370+24]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[20,370+4]..[20,370+12]) - Ppat_var ".%()" (extended_indexoperators.ml[20,370+4]..[20,370+12]) - expression (extended_indexoperators.ml[20,370+13]..[20,370+24]) ghost - Pexp_fun - Nolabel - None - pattern (extended_indexoperators.ml[20,370+13]..[20,370+14]) - Ppat_var "x" (extended_indexoperators.ml[20,370+13]..[20,370+14]) - expression (extended_indexoperators.ml[20,370+15]..[20,370+24]) ghost - Pexp_fun - Nolabel - None - pattern (extended_indexoperators.ml[20,370+15]..[20,370+16]) - Ppat_var "y" (extended_indexoperators.ml[20,370+15]..[20,370+16]) - expression (extended_indexoperators.ml[20,370+19]..[20,370+24]) - Pexp_apply - expression (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost - Pexp_ident "Array.get" (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[20,370+19]..[20,370+20]) - Pexp_ident "x" (extended_indexoperators.ml[20,370+19]..[20,370+20]) - <arg> - Nolabel - expression (extended_indexoperators.ml[20,370+22]..[20,370+23]) - Pexp_ident "y" (extended_indexoperators.ml[20,370+22]..[20,370+23]) - ] - ] - structure_item (extended_indexoperators.ml[21,397+0]..[21,397+15]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[21,397+4]..[21,397+5]) - Ppat_var "x" (extended_indexoperators.ml[21,397+4]..[21,397+5]) - expression (extended_indexoperators.ml[21,397+8]..[21,397+15]) - Pexp_array - [ - expression (extended_indexoperators.ml[21,397+11]..[21,397+12]) - Pexp_constant PConst_int (0,None) - ] - ] - structure_item (extended_indexoperators.ml[22,415+0]..[22,415+18]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[22,415+4]..[22,415+5]) - Ppat_any - expression (extended_indexoperators.ml[22,415+8]..[22,415+18]) - Pexp_apply - expression (extended_indexoperators.ml[22,415+10]..[22,415+12]) - Pexp_ident "#?" (extended_indexoperators.ml[22,415+10]..[22,415+12]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[22,415+8]..[22,415+9]) - Pexp_constant PConst_int (1,None) - <arg> - Nolabel - expression (extended_indexoperators.ml[22,415+13]..[22,415+18]) - Pexp_apply - expression (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost - Pexp_ident "Array.get" (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[22,415+13]..[22,415+14]) - Pexp_ident "x" (extended_indexoperators.ml[22,415+13]..[22,415+14]) - <arg> - Nolabel - expression (extended_indexoperators.ml[22,415+16]..[22,415+17]) - Pexp_constant PConst_int (0,None) - ] - ] - ] - structure_item (extended_indexoperators.ml[23,436+0]..[23,436+19]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[23,436+4]..[23,436+5]) - Ppat_any - expression (extended_indexoperators.ml[23,436+8]..[23,436+19]) - Pexp_apply - expression (extended_indexoperators.ml[23,436+10]..[23,436+12]) - Pexp_ident "#?" (extended_indexoperators.ml[23,436+10]..[23,436+12]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[23,436+8]..[23,436+9]) - Pexp_constant PConst_int (1,None) - <arg> - Nolabel - expression (extended_indexoperators.ml[23,436+13]..[23,436+19]) - Pexp_apply - expression (extended_indexoperators.ml[23,436+13]..[23,436+19]) - Pexp_ident ".%()" (extended_indexoperators.ml[23,436+13]..[23,436+19]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[23,436+13]..[23,436+14]) - Pexp_ident "x" (extended_indexoperators.ml[23,436+13]..[23,436+14]) - <arg> - Nolabel - expression (extended_indexoperators.ml[23,436+17]..[23,436+18]) - Pexp_constant PConst_int (0,None) - ] - ] - ] - structure_item (extended_indexoperators.ml[26,479+0]..[26,479+22]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[26,479+4]..[26,479+5]) - Ppat_any - expression (extended_indexoperators.ml[26,479+8]..[26,479+22]) - Pexp_apply - expression (extended_indexoperators.ml[26,479+8]..[26,479+22]) - Pexp_ident ".%()" (extended_indexoperators.ml[26,479+8]..[26,479+22]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[26,479+8]..[26,479+9]) - Pexp_ident "x" (extended_indexoperators.ml[26,479+8]..[26,479+9]) - <arg> - Nolabel - expression (extended_indexoperators.ml[26,479+12]..[26,479+21]) - Pexp_sequence - expression (extended_indexoperators.ml[26,479+12]..[26,479+14]) - Pexp_construct "()" (extended_indexoperators.ml[26,479+12]..[26,479+14]) - None - expression (extended_indexoperators.ml[26,479+16]..[26,479+21]) - Pexp_sequence - expression (extended_indexoperators.ml[26,479+16]..[26,479+18]) - Pexp_construct "()" (extended_indexoperators.ml[26,479+16]..[26,479+18]) - None - expression (extended_indexoperators.ml[26,479+20]..[26,479+21]) - Pexp_constant PConst_int (0,None) - ] - ] - structure_item (extended_indexoperators.ml[27,502+0]..[27,502+37]) - Pstr_value Nonrec - [ - <def> - pattern (extended_indexoperators.ml[27,502+4]..[27,502+5]) - Ppat_any - expression (extended_indexoperators.ml[27,502+8]..[27,502+37]) - Pexp_apply - expression (extended_indexoperators.ml[27,502+8]..[27,502+37]) - Pexp_ident ".%()" (extended_indexoperators.ml[27,502+8]..[27,502+37]) ghost - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[27,502+8]..[27,502+9]) - Pexp_ident "x" (extended_indexoperators.ml[27,502+8]..[27,502+9]) - <arg> - Nolabel - expression (extended_indexoperators.ml[27,502+12]..[27,502+36]) - Pexp_sequence - expression (extended_indexoperators.ml[27,502+12]..[27,502+33]) - Pexp_apply - expression (extended_indexoperators.ml[27,502+12]..[27,502+25]) - Pexp_ident "print_endline" (extended_indexoperators.ml[27,502+12]..[27,502+25]) - [ - <arg> - Nolabel - expression (extended_indexoperators.ml[27,502+26]..[27,502+33]) - Pexp_constant PConst_string("hello",None) - ] - expression (extended_indexoperators.ml[27,502+35]..[27,502+36]) - Pexp_constant PConst_int (0,None) - ] - ] -] - diff --git a/testsuite/tests/parsing/extensions.compilers.reference b/testsuite/tests/parsing/extensions.compilers.reference new file mode 100644 index 0000000000..dfad2ad77d --- /dev/null +++ b/testsuite/tests/parsing/extensions.compilers.reference @@ -0,0 +1,326 @@ +[ + structure_item (extensions.ml[9,153+0]..[9,153+22]) + Pstr_extension "foo" + [ + structure_item (extensions.ml[9,153+7]..[9,153+21]) + Pstr_eval + expression (extensions.ml[9,153+7]..[9,153+21]) + Pexp_let Nonrec + [ + <def> + pattern (extensions.ml[9,153+11]..[9,153+12]) + Ppat_var "x" (extensions.ml[9,153+11]..[9,153+12]) + expression (extensions.ml[9,153+15]..[9,153+16]) + Pexp_constant PConst_int (1,None) + ] + expression (extensions.ml[9,153+20]..[9,153+21]) + Pexp_ident "x" (extensions.ml[9,153+20]..[9,153+21]) + ] + structure_item (extensions.ml[10,176+0]..[10,176+46]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[10,176+4]..[10,176+46]) ghost + Ppat_constraint + pattern (extensions.ml[10,176+4]..[10,176+14]) + Ppat_extension "foo" + [ + structure_item (extensions.ml[10,176+10]..[10,176+13]) + Pstr_eval + expression (extensions.ml[10,176+10]..[10,176+13]) + Pexp_apply + expression (extensions.ml[10,176+11]..[10,176+12]) + Pexp_ident "+" (extensions.ml[10,176+11]..[10,176+12]) + [ + <arg> + Nolabel + expression (extensions.ml[10,176+10]..[10,176+11]) + Pexp_constant PConst_int (2,None) + <arg> + Nolabel + expression (extensions.ml[10,176+12]..[10,176+13]) + Pexp_constant PConst_int (1,None) + ] + ] + core_type (extensions.ml[10,176+17]..[10,176+31]) + Ptyp_extension "foo" + [ + structure_item (extensions.ml[10,176+23]..[10,176+30]) + Pstr_eval + expression (extensions.ml[10,176+23]..[10,176+30]) + Pexp_field + expression (extensions.ml[10,176+23]..[10,176+26]) + Pexp_ident "bar" (extensions.ml[10,176+23]..[10,176+26]) + "baz" (extensions.ml[10,176+27]..[10,176+30]) + ] + expression (extensions.ml[10,176+34]..[10,176+46]) + Pexp_extension "foo" + [ + structure_item (extensions.ml[10,176+40]..[10,176+45]) + Pstr_eval + expression (extensions.ml[10,176+40]..[10,176+45]) + Pexp_constant PConst_string("foo",None) + ] + ] + structure_item (extensions.ml[12,224+0]..[12,224+26]) + Pstr_extension "foo" + [ + structure_item (extensions.ml[12,224+7]..[12,224+24]) + Pstr_module + "M" (extensions.ml[12,224+14]..[12,224+15]) + module_expr (extensions.ml[12,224+18]..[12,224+24]) + Pmod_extension "bar" + [] + ] + structure_item (extensions.ml[13,251+0]..[13,251+74]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[13,251+4]..[13,251+74]) ghost + Ppat_constraint + pattern (extensions.ml[13,251+4]..[13,251+23]) + Ppat_extension "foo" + [ + structure_item (extensions.ml[13,251+10]..[13,251+21]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[13,251+14]..[13,251+16]) + Ppat_construct "()" (extensions.ml[13,251+14]..[13,251+16]) + None + expression (extensions.ml[13,251+19]..[13,251+21]) + Pexp_construct "()" (extensions.ml[13,251+19]..[13,251+21]) + None + ] + ] + core_type (extensions.ml[13,251+26]..[13,251+44]) + Ptyp_extension "foo" + [ + structure_item (extensions.ml[13,251+32]..[13,251+42]) + Pstr_type Rec + [ + type_declaration "t" (extensions.ml[13,251+37]..[13,251+38]) (extensions.ml[13,251+32]..[13,251+42]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (extensions.ml[13,251+41]..[13,251+42]) + Ptyp_constr "t" (extensions.ml[13,251+41]..[13,251+42]) + [] + ] + ] + expression (extensions.ml[13,251+47]..[13,251+74]) + Pexp_extension "foo" + [ + structure_item (extensions.ml[13,251+53]..[13,251+73]) + Pstr_class + [ + class_declaration (extensions.ml[13,251+53]..[13,251+73]) + pci_virt = Concrete + pci_params = + [] + pci_name = "c" (extensions.ml[13,251+59]..[13,251+60]) + pci_expr = + class_expr (extensions.ml[13,251+63]..[13,251+73]) + Pcl_structure + class_structure + pattern (extensions.ml[13,251+69]..[13,251+69]) ghost + Ppat_any + [] + ] + ] + ] + structure_item (extensions.ml[15,327+0]..[15,327+16]) + Pstr_extension "foo" + core_type (extensions.ml[15,327+8]..[15,327+15]) + Ptyp_constr "list" (extensions.ml[15,327+11]..[15,327+15]) + [ + core_type (extensions.ml[15,327+8]..[15,327+10]) + Ptyp_var a + ] + structure_item (extensions.ml[16,344+0]..[16,344+60]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[16,344+4]..[16,344+60]) ghost + Ppat_constraint + pattern (extensions.ml[16,344+4]..[16,344+19]) + Ppat_extension "foo" + core_type (extensions.ml[16,344+11]..[16,344+17]) + Ptyp_variant closed=Closed + [ + Rtag "Foo" true + [] + ] + None + core_type (extensions.ml[16,344+22]..[16,344+37]) + Ptyp_extension "foo" + core_type (extensions.ml[16,344+29]..[16,344+35]) + Ptyp_arrow + Nolabel + core_type (extensions.ml[16,344+29]..[16,344+30]) + Ptyp_constr "t" (extensions.ml[16,344+29]..[16,344+30]) + [] + core_type (extensions.ml[16,344+34]..[16,344+35]) + Ptyp_constr "t" (extensions.ml[16,344+34]..[16,344+35]) + [] + expression (extensions.ml[16,344+40]..[16,344+60]) + Pexp_extension "foo" + core_type (extensions.ml[16,344+47]..[16,344+58]) + Ptyp_object Closed + method foo + core_type (extensions.ml[16,344+55]..[16,344+56]) + Ptyp_constr "t" (extensions.ml[16,344+55]..[16,344+56]) + [] + ] + structure_item (extensions.ml[18,406+0]..[18,406+11]) + Pstr_extension "foo" + pattern (extensions.ml[18,406+8]..[18,406+9]) + Ppat_any + structure_item (extensions.ml[19,418+0]..[19,418+26]) + Pstr_extension "foo" + pattern (extensions.ml[19,418+8]..[19,418+14]) + Ppat_construct "Some" (extensions.ml[19,418+8]..[19,418+12]) + Some + pattern (extensions.ml[19,418+13]..[19,418+14]) + Ppat_var "y" (extensions.ml[19,418+13]..[19,418+14]) + <when> + expression (extensions.ml[19,418+20]..[19,418+25]) + Pexp_apply + expression (extensions.ml[19,418+22]..[19,418+23]) + Pexp_ident ">" (extensions.ml[19,418+22]..[19,418+23]) + [ + <arg> + Nolabel + expression (extensions.ml[19,418+20]..[19,418+21]) + Pexp_ident "y" (extensions.ml[19,418+20]..[19,418+21]) + <arg> + Nolabel + expression (extensions.ml[19,418+24]..[19,418+25]) + Pexp_constant PConst_int (0,None) + ] + structure_item (extensions.ml[20,445+0]..[20,445+60]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[20,445+4]..[20,445+60]) ghost + Ppat_constraint + pattern (extensions.ml[20,445+4]..[20,445+28]) + Ppat_extension "foo" + pattern (extensions.ml[20,445+11]..[20,445+26]) + Ppat_or + pattern (extensions.ml[20,445+12]..[20,445+17]) + Ppat_construct "Bar" (extensions.ml[20,445+12]..[20,445+15]) + Some + pattern (extensions.ml[20,445+16]..[20,445+17]) + Ppat_var "x" (extensions.ml[20,445+16]..[20,445+17]) + pattern (extensions.ml[20,445+20]..[20,445+25]) + Ppat_construct "Baz" (extensions.ml[20,445+20]..[20,445+23]) + Some + pattern (extensions.ml[20,445+24]..[20,445+25]) + Ppat_var "x" (extensions.ml[20,445+24]..[20,445+25]) + core_type (extensions.ml[20,445+31]..[20,445+44]) + Ptyp_extension "foo" + pattern (extensions.ml[20,445+38]..[20,445+42]) + Ppat_type + "bar" (extensions.ml[20,445+39]..[20,445+42]) + expression (extensions.ml[20,445+47]..[20,445+60]) + Pexp_extension "foo" + pattern (extensions.ml[20,445+54]..[20,445+59]) + Ppat_record Closed + [ + "x" (extensions.ml[20,445+56]..[20,445+57]) + pattern (extensions.ml[20,445+56]..[20,445+57]) + Ppat_var "x" (extensions.ml[20,445+56]..[20,445+57]) + ] + ] + structure_item (extensions.ml[22,507+0]..[22,507+26]) + Pstr_extension "foo" + [ + signature_item (extensions.ml[22,507+8]..[22,507+25]) + Psig_module "M" (extensions.ml[22,507+15]..[22,507+16]) + module_type (extensions.ml[22,507+19]..[22,507+25]) + Pmod_extension "baz" + [] + ] + structure_item (extensions.ml[23,534+0]..[25,606+23]) + Pstr_value Nonrec + [ + <def> + pattern (extensions.ml[23,534+4]..[25,606+23]) ghost + Ppat_constraint + pattern (extensions.ml[23,534+4]..[23,534+38]) + Ppat_extension "foo" + [ + signature_item (extensions.ml[23,534+11]..[23,534+36]) + Psig_include + module_type (extensions.ml[23,534+19]..[23,534+36]) + Pmty_with + module_type (extensions.ml[23,534+19]..[23,534+20]) + Pmty_ident "S" (extensions.ml[23,534+19]..[23,534+20]) + [ + Pwith_type "t" (extensions.ml[23,534+31]..[23,534+32]) + type_declaration "t" (extensions.ml[23,534+31]..[23,534+32]) (extensions.ml[23,534+26]..[23,534+36]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (extensions.ml[23,534+35]..[23,534+36]) + Ptyp_constr "t" (extensions.ml[23,534+35]..[23,534+36]) + [] + ] + ] + core_type (extensions.ml[24,573+4]..[24,573+32]) + Ptyp_extension "foo" + [ + signature_item (extensions.ml[24,573+11]..[24,573+20]) + Psig_value + value_description "x" (extensions.ml[24,573+15]..[24,573+16]) (extensions.ml[24,573+11]..[24,573+20]) + core_type (extensions.ml[24,573+19]..[24,573+20]) + Ptyp_constr "t" (extensions.ml[24,573+19]..[24,573+20]) + [] + [] + signature_item (extensions.ml[24,573+22]..[24,573+31]) + Psig_value + value_description "y" (extensions.ml[24,573+26]..[24,573+27]) (extensions.ml[24,573+22]..[24,573+31]) + core_type (extensions.ml[24,573+30]..[24,573+31]) + Ptyp_constr "t" (extensions.ml[24,573+30]..[24,573+31]) + [] + [] + ] + expression (extensions.ml[25,606+4]..[25,606+23]) + Pexp_extension "foo" + [ + signature_item (extensions.ml[25,606+11]..[25,606+21]) + Psig_type Rec + [ + type_declaration "t" (extensions.ml[25,606+16]..[25,606+17]) (extensions.ml[25,606+11]..[25,606+21]) + ptype_params = + [] + ptype_cstrs = + [] + ptype_kind = + Ptype_abstract + ptype_private = Public + ptype_manifest = + Some + core_type (extensions.ml[25,606+20]..[25,606+21]) + Ptyp_constr "t" (extensions.ml[25,606+20]..[25,606+21]) + [] + ] + ] + ] +] + +File "extensions.ml", line 9, characters 3-6: +Error: Uninterpreted extension 'foo'. diff --git a/testsuite/tests/parsing/extensions.ml b/testsuite/tests/parsing/extensions.ml index e0feab8b22..326d2a4768 100644 --- a/testsuite/tests/parsing/extensions.ml +++ b/testsuite/tests/parsing/extensions.ml @@ -1,3 +1,10 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) [%%foo let x = 1 in x] let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"] diff --git a/testsuite/tests/parsing/extensions.ml.reference b/testsuite/tests/parsing/extensions.ml.reference deleted file mode 100644 index e904d7e9a7..0000000000 --- a/testsuite/tests/parsing/extensions.ml.reference +++ /dev/null @@ -1,326 +0,0 @@ -[ - structure_item (extensions.ml[2,1+0]..[2,1+22]) - Pstr_extension "foo" - [ - structure_item (extensions.ml[2,1+7]..[2,1+21]) - Pstr_eval - expression (extensions.ml[2,1+7]..[2,1+21]) - Pexp_let Nonrec - [ - <def> - pattern (extensions.ml[2,1+11]..[2,1+12]) - Ppat_var "x" (extensions.ml[2,1+11]..[2,1+12]) - expression (extensions.ml[2,1+15]..[2,1+16]) - Pexp_constant PConst_int (1,None) - ] - expression (extensions.ml[2,1+20]..[2,1+21]) - Pexp_ident "x" (extensions.ml[2,1+20]..[2,1+21]) - ] - structure_item (extensions.ml[3,24+0]..[3,24+46]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[3,24+4]..[3,24+46]) ghost - Ppat_constraint - pattern (extensions.ml[3,24+4]..[3,24+14]) - Ppat_extension "foo" - [ - structure_item (extensions.ml[3,24+10]..[3,24+13]) - Pstr_eval - expression (extensions.ml[3,24+10]..[3,24+13]) - Pexp_apply - expression (extensions.ml[3,24+11]..[3,24+12]) - Pexp_ident "+" (extensions.ml[3,24+11]..[3,24+12]) - [ - <arg> - Nolabel - expression (extensions.ml[3,24+10]..[3,24+11]) - Pexp_constant PConst_int (2,None) - <arg> - Nolabel - expression (extensions.ml[3,24+12]..[3,24+13]) - Pexp_constant PConst_int (1,None) - ] - ] - core_type (extensions.ml[3,24+17]..[3,24+31]) - Ptyp_extension "foo" - [ - structure_item (extensions.ml[3,24+23]..[3,24+30]) - Pstr_eval - expression (extensions.ml[3,24+23]..[3,24+30]) - Pexp_field - expression (extensions.ml[3,24+23]..[3,24+26]) - Pexp_ident "bar" (extensions.ml[3,24+23]..[3,24+26]) - "baz" (extensions.ml[3,24+27]..[3,24+30]) - ] - expression (extensions.ml[3,24+34]..[3,24+46]) - Pexp_extension "foo" - [ - structure_item (extensions.ml[3,24+40]..[3,24+45]) - Pstr_eval - expression (extensions.ml[3,24+40]..[3,24+45]) - Pexp_constant PConst_string("foo",None) - ] - ] - structure_item (extensions.ml[5,72+0]..[5,72+26]) - Pstr_extension "foo" - [ - structure_item (extensions.ml[5,72+7]..[5,72+24]) - Pstr_module - "M" (extensions.ml[5,72+14]..[5,72+15]) - module_expr (extensions.ml[5,72+18]..[5,72+24]) - Pmod_extension "bar" - [] - ] - structure_item (extensions.ml[6,99+0]..[6,99+74]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[6,99+4]..[6,99+74]) ghost - Ppat_constraint - pattern (extensions.ml[6,99+4]..[6,99+23]) - Ppat_extension "foo" - [ - structure_item (extensions.ml[6,99+10]..[6,99+21]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[6,99+14]..[6,99+16]) - Ppat_construct "()" (extensions.ml[6,99+14]..[6,99+16]) - None - expression (extensions.ml[6,99+19]..[6,99+21]) - Pexp_construct "()" (extensions.ml[6,99+19]..[6,99+21]) - None - ] - ] - core_type (extensions.ml[6,99+26]..[6,99+44]) - Ptyp_extension "foo" - [ - structure_item (extensions.ml[6,99+32]..[6,99+42]) - Pstr_type Rec - [ - type_declaration "t" (extensions.ml[6,99+37]..[6,99+38]) (extensions.ml[6,99+32]..[6,99+42]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (extensions.ml[6,99+41]..[6,99+42]) - Ptyp_constr "t" (extensions.ml[6,99+41]..[6,99+42]) - [] - ] - ] - expression (extensions.ml[6,99+47]..[6,99+74]) - Pexp_extension "foo" - [ - structure_item (extensions.ml[6,99+53]..[6,99+73]) - Pstr_class - [ - class_declaration (extensions.ml[6,99+53]..[6,99+73]) - pci_virt = Concrete - pci_params = - [] - pci_name = "c" (extensions.ml[6,99+59]..[6,99+60]) - pci_expr = - class_expr (extensions.ml[6,99+63]..[6,99+73]) - Pcl_structure - class_structure - pattern (extensions.ml[6,99+69]..[6,99+69]) ghost - Ppat_any - [] - ] - ] - ] - structure_item (extensions.ml[8,175+0]..[8,175+16]) - Pstr_extension "foo" - core_type (extensions.ml[8,175+8]..[8,175+15]) - Ptyp_constr "list" (extensions.ml[8,175+11]..[8,175+15]) - [ - core_type (extensions.ml[8,175+8]..[8,175+10]) - Ptyp_var a - ] - structure_item (extensions.ml[9,192+0]..[9,192+60]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[9,192+4]..[9,192+60]) ghost - Ppat_constraint - pattern (extensions.ml[9,192+4]..[9,192+19]) - Ppat_extension "foo" - core_type (extensions.ml[9,192+11]..[9,192+17]) - Ptyp_variant closed=Closed - [ - Rtag "Foo" true - [] - ] - None - core_type (extensions.ml[9,192+22]..[9,192+37]) - Ptyp_extension "foo" - core_type (extensions.ml[9,192+29]..[9,192+35]) - Ptyp_arrow - Nolabel - core_type (extensions.ml[9,192+29]..[9,192+30]) - Ptyp_constr "t" (extensions.ml[9,192+29]..[9,192+30]) - [] - core_type (extensions.ml[9,192+34]..[9,192+35]) - Ptyp_constr "t" (extensions.ml[9,192+34]..[9,192+35]) - [] - expression (extensions.ml[9,192+40]..[9,192+60]) - Pexp_extension "foo" - core_type (extensions.ml[9,192+47]..[9,192+58]) - Ptyp_object Closed - method foo - core_type (extensions.ml[9,192+55]..[9,192+56]) - Ptyp_constr "t" (extensions.ml[9,192+55]..[9,192+56]) - [] - ] - structure_item (extensions.ml[11,254+0]..[11,254+11]) - Pstr_extension "foo" - pattern (extensions.ml[11,254+8]..[11,254+9]) - Ppat_any - structure_item (extensions.ml[12,266+0]..[12,266+26]) - Pstr_extension "foo" - pattern (extensions.ml[12,266+8]..[12,266+14]) - Ppat_construct "Some" (extensions.ml[12,266+8]..[12,266+12]) - Some - pattern (extensions.ml[12,266+13]..[12,266+14]) - Ppat_var "y" (extensions.ml[12,266+13]..[12,266+14]) - <when> - expression (extensions.ml[12,266+20]..[12,266+25]) - Pexp_apply - expression (extensions.ml[12,266+22]..[12,266+23]) - Pexp_ident ">" (extensions.ml[12,266+22]..[12,266+23]) - [ - <arg> - Nolabel - expression (extensions.ml[12,266+20]..[12,266+21]) - Pexp_ident "y" (extensions.ml[12,266+20]..[12,266+21]) - <arg> - Nolabel - expression (extensions.ml[12,266+24]..[12,266+25]) - Pexp_constant PConst_int (0,None) - ] - structure_item (extensions.ml[13,293+0]..[13,293+60]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[13,293+4]..[13,293+60]) ghost - Ppat_constraint - pattern (extensions.ml[13,293+4]..[13,293+28]) - Ppat_extension "foo" - pattern (extensions.ml[13,293+11]..[13,293+26]) - Ppat_or - pattern (extensions.ml[13,293+12]..[13,293+17]) - Ppat_construct "Bar" (extensions.ml[13,293+12]..[13,293+15]) - Some - pattern (extensions.ml[13,293+16]..[13,293+17]) - Ppat_var "x" (extensions.ml[13,293+16]..[13,293+17]) - pattern (extensions.ml[13,293+20]..[13,293+25]) - Ppat_construct "Baz" (extensions.ml[13,293+20]..[13,293+23]) - Some - pattern (extensions.ml[13,293+24]..[13,293+25]) - Ppat_var "x" (extensions.ml[13,293+24]..[13,293+25]) - core_type (extensions.ml[13,293+31]..[13,293+44]) - Ptyp_extension "foo" - pattern (extensions.ml[13,293+38]..[13,293+42]) - Ppat_type - "bar" (extensions.ml[13,293+39]..[13,293+42]) - expression (extensions.ml[13,293+47]..[13,293+60]) - Pexp_extension "foo" - pattern (extensions.ml[13,293+54]..[13,293+59]) - Ppat_record Closed - [ - "x" (extensions.ml[13,293+56]..[13,293+57]) - pattern (extensions.ml[13,293+56]..[13,293+57]) - Ppat_var "x" (extensions.ml[13,293+56]..[13,293+57]) - ] - ] - structure_item (extensions.ml[15,355+0]..[15,355+26]) - Pstr_extension "foo" - [ - signature_item (extensions.ml[15,355+8]..[15,355+25]) - Psig_module "M" (extensions.ml[15,355+15]..[15,355+16]) - module_type (extensions.ml[15,355+19]..[15,355+25]) - Pmod_extension "baz" - [] - ] - structure_item (extensions.ml[16,382+0]..[18,454+23]) - Pstr_value Nonrec - [ - <def> - pattern (extensions.ml[16,382+4]..[18,454+23]) ghost - Ppat_constraint - pattern (extensions.ml[16,382+4]..[16,382+38]) - Ppat_extension "foo" - [ - signature_item (extensions.ml[16,382+11]..[16,382+36]) - Psig_include - module_type (extensions.ml[16,382+19]..[16,382+36]) - Pmty_with - module_type (extensions.ml[16,382+19]..[16,382+20]) - Pmty_ident "S" (extensions.ml[16,382+19]..[16,382+20]) - [ - Pwith_type "t" (extensions.ml[16,382+31]..[16,382+32]) - type_declaration "t" (extensions.ml[16,382+31]..[16,382+32]) (extensions.ml[16,382+26]..[16,382+36]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (extensions.ml[16,382+35]..[16,382+36]) - Ptyp_constr "t" (extensions.ml[16,382+35]..[16,382+36]) - [] - ] - ] - core_type (extensions.ml[17,421+4]..[17,421+32]) - Ptyp_extension "foo" - [ - signature_item (extensions.ml[17,421+11]..[17,421+20]) - Psig_value - value_description "x" (extensions.ml[17,421+15]..[17,421+16]) (extensions.ml[17,421+11]..[17,421+20]) - core_type (extensions.ml[17,421+19]..[17,421+20]) - Ptyp_constr "t" (extensions.ml[17,421+19]..[17,421+20]) - [] - [] - signature_item (extensions.ml[17,421+22]..[17,421+31]) - Psig_value - value_description "y" (extensions.ml[17,421+26]..[17,421+27]) (extensions.ml[17,421+22]..[17,421+31]) - core_type (extensions.ml[17,421+30]..[17,421+31]) - Ptyp_constr "t" (extensions.ml[17,421+30]..[17,421+31]) - [] - [] - ] - expression (extensions.ml[18,454+4]..[18,454+23]) - Pexp_extension "foo" - [ - signature_item (extensions.ml[18,454+11]..[18,454+21]) - Psig_type Rec - [ - type_declaration "t" (extensions.ml[18,454+16]..[18,454+17]) (extensions.ml[18,454+11]..[18,454+21]) - ptype_params = - [] - ptype_cstrs = - [] - ptype_kind = - Ptype_abstract - ptype_private = Public - ptype_manifest = - Some - core_type (extensions.ml[18,454+20]..[18,454+21]) - Ptyp_constr "t" (extensions.ml[18,454+20]..[18,454+21]) - [] - ] - ] - ] -] - -File "extensions.ml", line 2, characters 3-6: -Error: Uninterpreted extension 'foo'. diff --git a/testsuite/tests/parsing/int_and_float_with_modifier.compilers.reference b/testsuite/tests/parsing/int_and_float_with_modifier.compilers.reference new file mode 100644 index 0000000000..84eddc7c8e --- /dev/null +++ b/testsuite/tests/parsing/int_and_float_with_modifier.compilers.reference @@ -0,0 +1,86 @@ +[ + structure_item (int_and_float_with_modifier.ml[9,153+0]..[10,184+57]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[9,153+4]..[9,153+28]) + Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[9,153+4]..[9,153+28]) + expression (int_and_float_with_modifier.ml[10,184+2]..[10,184+57]) + Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z) + ] + structure_item (int_and_float_with_modifier.ml[11,242+0]..[12,275+58]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[11,242+4]..[11,242+30]) + Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[11,242+4]..[11,242+30]) + expression (int_and_float_with_modifier.ml[12,275+2]..[12,275+58]) + Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z) + ] + structure_item (int_and_float_with_modifier.ml[14,335+0]..[14,335+21]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[14,335+4]..[14,335+9]) + Ppat_var "int32" (int_and_float_with_modifier.ml[14,335+4]..[14,335+9]) + expression (int_and_float_with_modifier.ml[14,335+16]..[14,335+21]) + Pexp_constant PConst_int (1234,Some l) + ] + structure_item (int_and_float_with_modifier.ml[15,357+0]..[15,357+21]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[15,357+4]..[15,357+9]) + Ppat_var "int64" (int_and_float_with_modifier.ml[15,357+4]..[15,357+9]) + expression (int_and_float_with_modifier.ml[15,357+16]..[15,357+21]) + Pexp_constant PConst_int (1234,Some L) + ] + structure_item (int_and_float_with_modifier.ml[16,379+0]..[16,379+21]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[16,379+4]..[16,379+13]) + Ppat_var "nativeint" (int_and_float_with_modifier.ml[16,379+4]..[16,379+13]) + expression (int_and_float_with_modifier.ml[16,379+16]..[16,379+21]) + Pexp_constant PConst_int (1234,Some n) + ] + structure_item (int_and_float_with_modifier.ml[18,402+0]..[18,402+32]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[18,402+4]..[18,402+24]) + Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[18,402+4]..[18,402+24]) + expression (int_and_float_with_modifier.ml[18,402+27]..[18,402+32]) + Pexp_constant PConst_int (0x32f,None) + ] + structure_item (int_and_float_with_modifier.ml[19,435+0]..[19,435+32]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[19,435+4]..[19,435+21]) + Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[19,435+4]..[19,435+21]) + expression (int_and_float_with_modifier.ml[19,435+27]..[19,435+32]) + Pexp_constant PConst_int (0x32,Some g) + ] + structure_item (int_and_float_with_modifier.ml[21,469+0]..[21,469+33]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[21,469+4]..[21,469+25]) + Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[21,469+4]..[21,469+25]) + expression (int_and_float_with_modifier.ml[21,469+28]..[21,469+33]) + Pexp_constant PConst_float (1.2e3,None) + ] + structure_item (int_and_float_with_modifier.ml[22,503+0]..[22,503+32]) + Pstr_value Nonrec + [ + <def> + pattern (int_and_float_with_modifier.ml[22,503+4]..[22,503+22]) + Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[22,503+4]..[22,503+22]) + expression (int_and_float_with_modifier.ml[22,503+28]..[22,503+32]) + Pexp_constant PConst_float (1.2,Some g) + ] +] + +File "int_and_float_with_modifier.ml", line 10, characters 2-57: +Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z diff --git a/testsuite/tests/parsing/int_and_float_with_modifier.ml b/testsuite/tests/parsing/int_and_float_with_modifier.ml index 06384257b3..444964be85 100644 --- a/testsuite/tests/parsing/int_and_float_with_modifier.ml +++ b/testsuite/tests/parsing/int_and_float_with_modifier.ml @@ -1,3 +1,11 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + let int_with_custom_modifier = 1234567890_1234567890_1234567890_1234567890_1234567890z let float_with_custom_modifier = diff --git a/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference b/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference deleted file mode 100644 index fd3bee0e4c..0000000000 --- a/testsuite/tests/parsing/int_and_float_with_modifier.ml.reference +++ /dev/null @@ -1,86 +0,0 @@ -[ - structure_item (int_and_float_with_modifier.ml[1,0+0]..[2,31+57]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[1,0+4]..[1,0+28]) - Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[1,0+4]..[1,0+28]) - expression (int_and_float_with_modifier.ml[2,31+2]..[2,31+57]) - Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z) - ] - structure_item (int_and_float_with_modifier.ml[3,89+0]..[4,122+58]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[3,89+4]..[3,89+30]) - Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[3,89+4]..[3,89+30]) - expression (int_and_float_with_modifier.ml[4,122+2]..[4,122+58]) - Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z) - ] - structure_item (int_and_float_with_modifier.ml[6,182+0]..[6,182+21]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[6,182+4]..[6,182+9]) - Ppat_var "int32" (int_and_float_with_modifier.ml[6,182+4]..[6,182+9]) - expression (int_and_float_with_modifier.ml[6,182+16]..[6,182+21]) - Pexp_constant PConst_int (1234,Some l) - ] - structure_item (int_and_float_with_modifier.ml[7,204+0]..[7,204+21]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[7,204+4]..[7,204+9]) - Ppat_var "int64" (int_and_float_with_modifier.ml[7,204+4]..[7,204+9]) - expression (int_and_float_with_modifier.ml[7,204+16]..[7,204+21]) - Pexp_constant PConst_int (1234,Some L) - ] - structure_item (int_and_float_with_modifier.ml[8,226+0]..[8,226+21]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[8,226+4]..[8,226+13]) - Ppat_var "nativeint" (int_and_float_with_modifier.ml[8,226+4]..[8,226+13]) - expression (int_and_float_with_modifier.ml[8,226+16]..[8,226+21]) - Pexp_constant PConst_int (1234,Some n) - ] - structure_item (int_and_float_with_modifier.ml[10,249+0]..[10,249+32]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[10,249+4]..[10,249+24]) - Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[10,249+4]..[10,249+24]) - expression (int_and_float_with_modifier.ml[10,249+27]..[10,249+32]) - Pexp_constant PConst_int (0x32f,None) - ] - structure_item (int_and_float_with_modifier.ml[11,282+0]..[11,282+32]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[11,282+4]..[11,282+21]) - Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[11,282+4]..[11,282+21]) - expression (int_and_float_with_modifier.ml[11,282+27]..[11,282+32]) - Pexp_constant PConst_int (0x32,Some g) - ] - structure_item (int_and_float_with_modifier.ml[13,316+0]..[13,316+33]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[13,316+4]..[13,316+25]) - Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[13,316+4]..[13,316+25]) - expression (int_and_float_with_modifier.ml[13,316+28]..[13,316+33]) - Pexp_constant PConst_float (1.2e3,None) - ] - structure_item (int_and_float_with_modifier.ml[14,350+0]..[14,350+32]) - Pstr_value Nonrec - [ - <def> - pattern (int_and_float_with_modifier.ml[14,350+4]..[14,350+22]) - Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[14,350+4]..[14,350+22]) - expression (int_and_float_with_modifier.ml[14,350+28]..[14,350+32]) - Pexp_constant PConst_float (1.2,Some g) - ] -] - -File "int_and_float_with_modifier.ml", line 2, characters 2-57: -Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z diff --git a/testsuite/tests/parsing/ocamltests b/testsuite/tests/parsing/ocamltests new file mode 100644 index 0000000000..b509fdb8c2 --- /dev/null +++ b/testsuite/tests/parsing/ocamltests @@ -0,0 +1,11 @@ +attributes.ml +docstrings.ml +extended_indexoperators.ml +extensions.ml +int_and_float_with_modifier.ml +pr6604_2.ml +pr6604_3.ml +pr6604.ml +pr6865.ml +pr7165.ml +shortcut_ext_attr.ml diff --git a/testsuite/tests/parsing/pr6604.compilers.reference b/testsuite/tests/parsing/pr6604.compilers.reference new file mode 100644 index 0000000000..634351de91 --- /dev/null +++ b/testsuite/tests/parsing/pr6604.compilers.reference @@ -0,0 +1,2 @@ +File "pr6604.ml", line 9, characters 0-1: +Error: Syntax error diff --git a/testsuite/tests/parsing/pr6604.ml b/testsuite/tests/parsing/pr6604.ml index e3a9368692..806f9c37ed 100644 --- a/testsuite/tests/parsing/pr6604.ml +++ b/testsuite/tests/parsing/pr6604.ml @@ -1 +1,9 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + #1 diff --git a/testsuite/tests/parsing/pr6604.ml.reference b/testsuite/tests/parsing/pr6604.ml.reference deleted file mode 100644 index 515b2317bd..0000000000 --- a/testsuite/tests/parsing/pr6604.ml.reference +++ /dev/null @@ -1,2 +0,0 @@ -File "pr6604.ml", line 1, characters 0-1: -Error: Syntax error diff --git a/testsuite/tests/parsing/pr6604_2.compilers.reference b/testsuite/tests/parsing/pr6604_2.compilers.reference new file mode 100644 index 0000000000..3d5c60ef06 --- /dev/null +++ b/testsuite/tests/parsing/pr6604_2.compilers.reference @@ -0,0 +1,2 @@ +File "pr6604_2.ml", line 9, characters 1-2: +Error: Syntax error diff --git a/testsuite/tests/parsing/pr6604_2.ml b/testsuite/tests/parsing/pr6604_2.ml index e929b1110a..995e242d33 100644 --- a/testsuite/tests/parsing/pr6604_2.ml +++ b/testsuite/tests/parsing/pr6604_2.ml @@ -1 +1,9 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + #1 "pr6604.ml" diff --git a/testsuite/tests/parsing/pr6604_2.ml.reference b/testsuite/tests/parsing/pr6604_2.ml.reference deleted file mode 100644 index dbbb95a9d7..0000000000 --- a/testsuite/tests/parsing/pr6604_2.ml.reference +++ /dev/null @@ -1,2 +0,0 @@ -File "pr6604_2.ml", line 1, characters 1-2: -Error: Syntax error diff --git a/testsuite/tests/parsing/pr6604_3.ml.reference b/testsuite/tests/parsing/pr6604_3.compilers.reference index 7dd4387521..7dd4387521 100644 --- a/testsuite/tests/parsing/pr6604_3.ml.reference +++ b/testsuite/tests/parsing/pr6604_3.compilers.reference diff --git a/testsuite/tests/parsing/pr6604_3.ml b/testsuite/tests/parsing/pr6604_3.ml index 82f9bf27dc..ef15c5c068 100644 --- a/testsuite/tests/parsing/pr6604_3.ml +++ b/testsuite/tests/parsing/pr6604_3.ml @@ -1,3 +1,10 @@ +(* TEST + flags = "-dparsetree" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + # 1 "pr6604.ml" # 3 "pr6604.ml" diff --git a/testsuite/tests/parsing/pr6865.compilers.reference b/testsuite/tests/parsing/pr6865.compilers.reference new file mode 100644 index 0000000000..fb417c36b2 --- /dev/null +++ b/testsuite/tests/parsing/pr6865.compilers.reference @@ -0,0 +1,52 @@ +[ + structure_item (pr6865.ml[9,153+0]..[9,153+14]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[9,153+0]..[9,153+14]) + Pstr_value Nonrec + [ + <def> + pattern (pr6865.ml[9,153+8]..[9,153+9]) + Ppat_var "x" (pr6865.ml[9,153+8]..[9,153+9]) + expression (pr6865.ml[9,153+12]..[9,153+14]) + Pexp_constant PConst_int (42,None) + ] + ] + structure_item (pr6865.ml[10,168+0]..[10,168+25]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[10,168+0]..[10,168+25]) + Pstr_value Nonrec + [ + <def> + pattern (pr6865.ml[10,168+8]..[10,168+9]) + Ppat_any + expression (pr6865.ml[10,168+12]..[10,168+14]) + Pexp_construct "()" (pr6865.ml[10,168+12]..[10,168+14]) + None + <def> + pattern (pr6865.ml[10,168+19]..[10,168+20]) + Ppat_any + expression (pr6865.ml[10,168+23]..[10,168+25]) + Pexp_construct "()" (pr6865.ml[10,168+23]..[10,168+25]) + None + ] + ] + structure_item (pr6865.ml[11,194+0]..[11,194+14]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[11,194+0]..[11,194+14]) + Pstr_value Nonrec + [ + <def> + pattern (pr6865.ml[11,194+8]..[11,194+9]) + Ppat_any + expression (pr6865.ml[11,194+12]..[11,194+14]) + Pexp_construct "()" (pr6865.ml[11,194+12]..[11,194+14]) + None + ] + ] +] + +File "pr6865.ml", line 9, characters 4-7: +Error: Uninterpreted extension 'foo'. diff --git a/testsuite/tests/parsing/pr6865.ml b/testsuite/tests/parsing/pr6865.ml index 78cd602feb..c673e2a613 100644 --- a/testsuite/tests/parsing/pr6865.ml +++ b/testsuite/tests/parsing/pr6865.ml @@ -1,3 +1,11 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + let%foo x = 42 let%foo _ = () and _ = () let%foo _ = () diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference deleted file mode 100644 index 72abd40e11..0000000000 --- a/testsuite/tests/parsing/pr6865.ml.reference +++ /dev/null @@ -1,52 +0,0 @@ -[ - structure_item (pr6865.ml[1,0+0]..[1,0+14]) ghost - Pstr_extension "foo" - [ - structure_item (pr6865.ml[1,0+0]..[1,0+14]) - Pstr_value Nonrec - [ - <def> - pattern (pr6865.ml[1,0+8]..[1,0+9]) - Ppat_var "x" (pr6865.ml[1,0+8]..[1,0+9]) - expression (pr6865.ml[1,0+12]..[1,0+14]) - Pexp_constant PConst_int (42,None) - ] - ] - structure_item (pr6865.ml[2,15+0]..[2,15+25]) ghost - Pstr_extension "foo" - [ - structure_item (pr6865.ml[2,15+0]..[2,15+25]) - Pstr_value Nonrec - [ - <def> - pattern (pr6865.ml[2,15+8]..[2,15+9]) - Ppat_any - expression (pr6865.ml[2,15+12]..[2,15+14]) - Pexp_construct "()" (pr6865.ml[2,15+12]..[2,15+14]) - None - <def> - pattern (pr6865.ml[2,15+19]..[2,15+20]) - Ppat_any - expression (pr6865.ml[2,15+23]..[2,15+25]) - Pexp_construct "()" (pr6865.ml[2,15+23]..[2,15+25]) - None - ] - ] - structure_item (pr6865.ml[3,41+0]..[3,41+14]) ghost - Pstr_extension "foo" - [ - structure_item (pr6865.ml[3,41+0]..[3,41+14]) - Pstr_value Nonrec - [ - <def> - pattern (pr6865.ml[3,41+8]..[3,41+9]) - Ppat_any - expression (pr6865.ml[3,41+12]..[3,41+14]) - Pexp_construct "()" (pr6865.ml[3,41+12]..[3,41+14]) - None - ] - ] -] - -File "pr6865.ml", line 1, characters 4-7: -Error: Uninterpreted extension 'foo'. diff --git a/testsuite/tests/parsing/pr7165.ml.reference b/testsuite/tests/parsing/pr7165.compilers.reference index 886efe1adc..55fe3c49eb 100644 --- a/testsuite/tests/parsing/pr7165.ml.reference +++ b/testsuite/tests/parsing/pr7165.compilers.reference @@ -1,2 +1,2 @@ -File "pr7165.ml", line 4, characters 1-23: +File "pr7165.ml", line 12, characters 1-23: Error: Invalid lexer directive "#9342101923012312312 \"\"": line number out of range diff --git a/testsuite/tests/parsing/pr7165.ml b/testsuite/tests/parsing/pr7165.ml index 00124a7b52..e25708c1fc 100644 --- a/testsuite/tests/parsing/pr7165.ml +++ b/testsuite/tests/parsing/pr7165.ml @@ -1,3 +1,11 @@ +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + (* this is a lexer directive with an out-of-bound integer; it should result in a lexing error instead of an uncaught exception as in PR#7165 *) diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference index c31013494a..d8ceb058b2 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference +++ b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference @@ -1,493 +1,493 @@ [ - structure_item (shortcut_ext_attr.ml[3,19+0]..[24,570+31]) + structure_item (shortcut_ext_attr.ml[9,170+0]..[30,721+31]) Pstr_value Nonrec [ <def> - pattern (shortcut_ext_attr.ml[3,19+4]..[3,19+6]) - Ppat_construct "()" (shortcut_ext_attr.ml[3,19+4]..[3,19+6]) + pattern (shortcut_ext_attr.ml[9,170+4]..[9,170+6]) + Ppat_construct "()" (shortcut_ext_attr.ml[9,170+4]..[9,170+6]) None - expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) ghost + expression (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) + structure_item (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) Pstr_eval - expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[10,179+2]..[30,721+31]) Pexp_let Nonrec [ <def> attribute "foo" [] - pattern (shortcut_ext_attr.ml[4,28+16]..[4,28+17]) - Ppat_var "x" (shortcut_ext_attr.ml[4,28+16]..[4,28+17]) - expression (shortcut_ext_attr.ml[4,28+20]..[4,28+21]) + pattern (shortcut_ext_attr.ml[10,179+16]..[10,179+17]) + Ppat_var "x" (shortcut_ext_attr.ml[10,179+16]..[10,179+17]) + expression (shortcut_ext_attr.ml[10,179+20]..[10,179+21]) Pexp_constant PConst_int (3,None) <def> attribute "foo" [] - pattern (shortcut_ext_attr.ml[5,50+12]..[5,50+13]) - Ppat_var "y" (shortcut_ext_attr.ml[5,50+12]..[5,50+13]) - expression (shortcut_ext_attr.ml[5,50+16]..[5,50+17]) + pattern (shortcut_ext_attr.ml[11,201+12]..[11,201+13]) + Ppat_var "y" (shortcut_ext_attr.ml[11,201+12]..[11,201+13]) + expression (shortcut_ext_attr.ml[11,201+16]..[11,201+17]) Pexp_constant PConst_int (4,None) ] - expression (shortcut_ext_attr.ml[6,71+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[12,222+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[6,71+2]..[6,71+36]) + expression (shortcut_ext_attr.ml[12,222+2]..[12,222+36]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[6,71+3]..[6,71+35]) + structure_item (shortcut_ext_attr.ml[12,222+3]..[12,222+35]) Pstr_eval - expression (shortcut_ext_attr.ml[6,71+3]..[6,71+35]) + expression (shortcut_ext_attr.ml[12,222+3]..[12,222+35]) attribute "foo" [] - Pexp_letmodule "M" (shortcut_ext_attr.ml[6,71+24]..[6,71+25]) - module_expr (shortcut_ext_attr.ml[6,71+28]..[6,71+29]) - Pmod_ident "M" (shortcut_ext_attr.ml[6,71+28]..[6,71+29]) - expression (shortcut_ext_attr.ml[6,71+33]..[6,71+35]) - Pexp_construct "()" (shortcut_ext_attr.ml[6,71+33]..[6,71+35]) + Pexp_letmodule "M" (shortcut_ext_attr.ml[12,222+24]..[12,222+25]) + module_expr (shortcut_ext_attr.ml[12,222+28]..[12,222+29]) + Pmod_ident "M" (shortcut_ext_attr.ml[12,222+28]..[12,222+29]) + expression (shortcut_ext_attr.ml[12,222+33]..[12,222+35]) + Pexp_construct "()" (shortcut_ext_attr.ml[12,222+33]..[12,222+35]) None ] - expression (shortcut_ext_attr.ml[7,110+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[13,261+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[7,110+2]..[7,110+30]) + expression (shortcut_ext_attr.ml[13,261+2]..[13,261+30]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[7,110+3]..[7,110+29]) + structure_item (shortcut_ext_attr.ml[13,261+3]..[13,261+29]) Pstr_eval - expression (shortcut_ext_attr.ml[7,110+3]..[7,110+29]) + expression (shortcut_ext_attr.ml[13,261+3]..[13,261+29]) attribute "foo" [] - Pexp_open Fresh ""M" (shortcut_ext_attr.ml[7,110+22]..[7,110+23])" - expression (shortcut_ext_attr.ml[7,110+27]..[7,110+29]) - Pexp_construct "()" (shortcut_ext_attr.ml[7,110+27]..[7,110+29]) + Pexp_open Fresh ""M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23])" + expression (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) + Pexp_construct "()" (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) None ] - expression (shortcut_ext_attr.ml[8,143+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[14,294+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[8,143+2]..[8,143+25]) + expression (shortcut_ext_attr.ml[14,294+2]..[14,294+25]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[8,143+3]..[8,143+24]) + structure_item (shortcut_ext_attr.ml[14,294+3]..[14,294+24]) Pstr_eval - expression (shortcut_ext_attr.ml[8,143+3]..[8,143+24]) + expression (shortcut_ext_attr.ml[14,294+3]..[14,294+24]) attribute "foo" [] Pexp_fun Nolabel None - pattern (shortcut_ext_attr.ml[8,143+17]..[8,143+18]) - Ppat_var "x" (shortcut_ext_attr.ml[8,143+17]..[8,143+18]) - expression (shortcut_ext_attr.ml[8,143+22]..[8,143+24]) - Pexp_construct "()" (shortcut_ext_attr.ml[8,143+22]..[8,143+24]) + pattern (shortcut_ext_attr.ml[14,294+17]..[14,294+18]) + Ppat_var "x" (shortcut_ext_attr.ml[14,294+17]..[14,294+18]) + expression (shortcut_ext_attr.ml[14,294+22]..[14,294+24]) + Pexp_construct "()" (shortcut_ext_attr.ml[14,294+22]..[14,294+24]) None ] - expression (shortcut_ext_attr.ml[9,171+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[15,322+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[9,171+2]..[9,171+30]) + expression (shortcut_ext_attr.ml[15,322+2]..[15,322+30]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[9,171+3]..[9,171+29]) + structure_item (shortcut_ext_attr.ml[15,322+3]..[15,322+29]) Pstr_eval - expression (shortcut_ext_attr.ml[9,171+3]..[9,171+29]) + expression (shortcut_ext_attr.ml[15,322+3]..[15,322+29]) attribute "foo" [] Pexp_function [ <case> - pattern (shortcut_ext_attr.ml[9,171+22]..[9,171+23]) - Ppat_var "x" (shortcut_ext_attr.ml[9,171+22]..[9,171+23]) - expression (shortcut_ext_attr.ml[9,171+27]..[9,171+29]) - Pexp_construct "()" (shortcut_ext_attr.ml[9,171+27]..[9,171+29]) + pattern (shortcut_ext_attr.ml[15,322+22]..[15,322+23]) + Ppat_var "x" (shortcut_ext_attr.ml[15,322+22]..[15,322+23]) + expression (shortcut_ext_attr.ml[15,322+27]..[15,322+29]) + Pexp_construct "()" (shortcut_ext_attr.ml[15,322+27]..[15,322+29]) None ] ] - expression (shortcut_ext_attr.ml[10,204+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[16,355+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[10,204+2]..[10,204+33]) + expression (shortcut_ext_attr.ml[16,355+2]..[16,355+33]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[10,204+3]..[10,204+32]) + structure_item (shortcut_ext_attr.ml[16,355+3]..[16,355+32]) Pstr_eval - expression (shortcut_ext_attr.ml[10,204+3]..[10,204+32]) + expression (shortcut_ext_attr.ml[16,355+3]..[16,355+32]) attribute "foo" [] Pexp_try - expression (shortcut_ext_attr.ml[10,204+17]..[10,204+19]) - Pexp_construct "()" (shortcut_ext_attr.ml[10,204+17]..[10,204+19]) + expression (shortcut_ext_attr.ml[16,355+17]..[16,355+19]) + Pexp_construct "()" (shortcut_ext_attr.ml[16,355+17]..[16,355+19]) None [ <case> - pattern (shortcut_ext_attr.ml[10,204+25]..[10,204+26]) + pattern (shortcut_ext_attr.ml[16,355+25]..[16,355+26]) Ppat_any - expression (shortcut_ext_attr.ml[10,204+30]..[10,204+32]) - Pexp_construct "()" (shortcut_ext_attr.ml[10,204+30]..[10,204+32]) + expression (shortcut_ext_attr.ml[16,355+30]..[16,355+32]) + Pexp_construct "()" (shortcut_ext_attr.ml[16,355+30]..[16,355+32]) None ] ] - expression (shortcut_ext_attr.ml[11,240+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[17,391+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[11,240+2]..[11,240+35]) + expression (shortcut_ext_attr.ml[17,391+2]..[17,391+35]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[11,240+3]..[11,240+34]) + structure_item (shortcut_ext_attr.ml[17,391+3]..[17,391+34]) Pstr_eval - expression (shortcut_ext_attr.ml[11,240+3]..[11,240+34]) + expression (shortcut_ext_attr.ml[17,391+3]..[17,391+34]) attribute "foo" [] Pexp_ifthenelse - expression (shortcut_ext_attr.ml[11,240+16]..[11,240+18]) - Pexp_construct "()" (shortcut_ext_attr.ml[11,240+16]..[11,240+18]) + expression (shortcut_ext_attr.ml[17,391+16]..[17,391+18]) + Pexp_construct "()" (shortcut_ext_attr.ml[17,391+16]..[17,391+18]) None - expression (shortcut_ext_attr.ml[11,240+24]..[11,240+26]) - Pexp_construct "()" (shortcut_ext_attr.ml[11,240+24]..[11,240+26]) + expression (shortcut_ext_attr.ml[17,391+24]..[17,391+26]) + Pexp_construct "()" (shortcut_ext_attr.ml[17,391+24]..[17,391+26]) None Some - expression (shortcut_ext_attr.ml[11,240+32]..[11,240+34]) - Pexp_construct "()" (shortcut_ext_attr.ml[11,240+32]..[11,240+34]) + expression (shortcut_ext_attr.ml[17,391+32]..[17,391+34]) + Pexp_construct "()" (shortcut_ext_attr.ml[17,391+32]..[17,391+34]) None ] - expression (shortcut_ext_attr.ml[12,278+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[18,429+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) ghost + expression (shortcut_ext_attr.ml[18,429+2]..[18,429+31]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) + structure_item (shortcut_ext_attr.ml[18,429+2]..[18,429+31]) Pstr_eval - expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) + expression (shortcut_ext_attr.ml[18,429+2]..[18,429+31]) attribute "foo" [] Pexp_while - expression (shortcut_ext_attr.ml[12,278+18]..[12,278+20]) - Pexp_construct "()" (shortcut_ext_attr.ml[12,278+18]..[12,278+20]) + expression (shortcut_ext_attr.ml[18,429+18]..[18,429+20]) + Pexp_construct "()" (shortcut_ext_attr.ml[18,429+18]..[18,429+20]) None - expression (shortcut_ext_attr.ml[12,278+24]..[12,278+26]) - Pexp_construct "()" (shortcut_ext_attr.ml[12,278+24]..[12,278+26]) + expression (shortcut_ext_attr.ml[18,429+24]..[18,429+26]) + Pexp_construct "()" (shortcut_ext_attr.ml[18,429+24]..[18,429+26]) None ] - expression (shortcut_ext_attr.ml[13,312+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[19,463+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) ghost + expression (shortcut_ext_attr.ml[19,463+2]..[19,463+39]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) + structure_item (shortcut_ext_attr.ml[19,463+2]..[19,463+39]) Pstr_eval - expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) + expression (shortcut_ext_attr.ml[19,463+2]..[19,463+39]) attribute "foo" [] Pexp_for Up - pattern (shortcut_ext_attr.ml[13,312+16]..[13,312+17]) - Ppat_var "x" (shortcut_ext_attr.ml[13,312+16]..[13,312+17]) - expression (shortcut_ext_attr.ml[13,312+20]..[13,312+22]) - Pexp_construct "()" (shortcut_ext_attr.ml[13,312+20]..[13,312+22]) + pattern (shortcut_ext_attr.ml[19,463+16]..[19,463+17]) + Ppat_var "x" (shortcut_ext_attr.ml[19,463+16]..[19,463+17]) + expression (shortcut_ext_attr.ml[19,463+20]..[19,463+22]) + Pexp_construct "()" (shortcut_ext_attr.ml[19,463+20]..[19,463+22]) None - expression (shortcut_ext_attr.ml[13,312+26]..[13,312+28]) - Pexp_construct "()" (shortcut_ext_attr.ml[13,312+26]..[13,312+28]) + expression (shortcut_ext_attr.ml[19,463+26]..[19,463+28]) + Pexp_construct "()" (shortcut_ext_attr.ml[19,463+26]..[19,463+28]) None - expression (shortcut_ext_attr.ml[13,312+32]..[13,312+34]) - Pexp_construct "()" (shortcut_ext_attr.ml[13,312+32]..[13,312+34]) + expression (shortcut_ext_attr.ml[19,463+32]..[19,463+34]) + Pexp_construct "()" (shortcut_ext_attr.ml[19,463+32]..[19,463+34]) None ] - expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[20,505+2]..[30,721+31]) Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[14,354+2]..[24,570+31]) + structure_item (shortcut_ext_attr.ml[20,505+2]..[30,721+31]) Pstr_eval - expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[20,505+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[14,354+2]..[14,354+4]) - Pexp_construct "()" (shortcut_ext_attr.ml[14,354+2]..[14,354+4]) + expression (shortcut_ext_attr.ml[20,505+2]..[20,505+4]) + Pexp_construct "()" (shortcut_ext_attr.ml[20,505+2]..[20,505+4]) None - expression (shortcut_ext_attr.ml[14,354+11]..[24,570+31]) + expression (shortcut_ext_attr.ml[20,505+11]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[14,354+11]..[14,354+13]) - Pexp_construct "()" (shortcut_ext_attr.ml[14,354+11]..[14,354+13]) + expression (shortcut_ext_attr.ml[20,505+11]..[20,505+13]) + Pexp_construct "()" (shortcut_ext_attr.ml[20,505+11]..[20,505+13]) None - expression (shortcut_ext_attr.ml[15,370+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[21,521+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) ghost + expression (shortcut_ext_attr.ml[21,521+2]..[21,521+23]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) + structure_item (shortcut_ext_attr.ml[21,521+2]..[21,521+23]) Pstr_eval - expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) + expression (shortcut_ext_attr.ml[21,521+2]..[21,521+23]) attribute "foo" [] Pexp_assert - expression (shortcut_ext_attr.ml[15,370+19]..[15,370+23]) - Pexp_construct "true" (shortcut_ext_attr.ml[15,370+19]..[15,370+23]) + expression (shortcut_ext_attr.ml[21,521+19]..[21,521+23]) + Pexp_construct "true" (shortcut_ext_attr.ml[21,521+19]..[21,521+23]) None ] - expression (shortcut_ext_attr.ml[16,396+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[22,547+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) ghost + expression (shortcut_ext_attr.ml[22,547+2]..[22,547+18]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) + structure_item (shortcut_ext_attr.ml[22,547+2]..[22,547+18]) Pstr_eval - expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) + expression (shortcut_ext_attr.ml[22,547+2]..[22,547+18]) attribute "foo" [] Pexp_lazy - expression (shortcut_ext_attr.ml[16,396+17]..[16,396+18]) - Pexp_ident "x" (shortcut_ext_attr.ml[16,396+17]..[16,396+18]) + expression (shortcut_ext_attr.ml[22,547+17]..[22,547+18]) + Pexp_ident "x" (shortcut_ext_attr.ml[22,547+17]..[22,547+18]) ] - expression (shortcut_ext_attr.ml[17,417+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[23,568+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) ghost + expression (shortcut_ext_attr.ml[23,568+2]..[23,568+22]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) + structure_item (shortcut_ext_attr.ml[23,568+2]..[23,568+22]) Pstr_eval - expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) + expression (shortcut_ext_attr.ml[23,568+2]..[23,568+22]) attribute "foo" [] Pexp_object class_structure - pattern (shortcut_ext_attr.ml[17,417+18]..[17,417+18]) ghost + pattern (shortcut_ext_attr.ml[23,568+18]..[23,568+18]) ghost Ppat_any [] ] - expression (shortcut_ext_attr.ml[18,442+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[24,593+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) ghost + expression (shortcut_ext_attr.ml[24,593+2]..[24,593+23]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) + structure_item (shortcut_ext_attr.ml[24,593+2]..[24,593+23]) Pstr_eval - expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) + expression (shortcut_ext_attr.ml[24,593+2]..[24,593+23]) attribute "foo" [] Pexp_constant PConst_int (3,None) ] - expression (shortcut_ext_attr.ml[19,468+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[25,619+2]..[30,721+31]) Pexp_sequence - expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) ghost + expression (shortcut_ext_attr.ml[25,619+2]..[25,619+17]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) + structure_item (shortcut_ext_attr.ml[25,619+2]..[25,619+17]) Pstr_eval - expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) + expression (shortcut_ext_attr.ml[25,619+2]..[25,619+17]) attribute "foo" [] - Pexp_new "x" (shortcut_ext_attr.ml[19,468+16]..[19,468+17]) + Pexp_new "x" (shortcut_ext_attr.ml[25,619+16]..[25,619+17]) ] - expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) ghost + expression (shortcut_ext_attr.ml[27,640+2]..[30,721+31]) ghost Pexp_extension "foo" [ - structure_item (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) + structure_item (shortcut_ext_attr.ml[27,640+2]..[30,721+31]) Pstr_eval - expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) + expression (shortcut_ext_attr.ml[27,640+2]..[30,721+31]) attribute "foo" [] Pexp_match - expression (shortcut_ext_attr.ml[21,489+18]..[21,489+20]) - Pexp_construct "()" (shortcut_ext_attr.ml[21,489+18]..[21,489+20]) + expression (shortcut_ext_attr.ml[27,640+18]..[27,640+20]) + Pexp_construct "()" (shortcut_ext_attr.ml[27,640+18]..[27,640+20]) None [ <case> - pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) ghost + pattern (shortcut_ext_attr.ml[29,694+4]..[29,694+20]) ghost Ppat_extension "foo" - pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) + pattern (shortcut_ext_attr.ml[29,694+4]..[29,694+20]) attribute "foo" [] Ppat_lazy - pattern (shortcut_ext_attr.ml[23,543+19]..[23,543+20]) - Ppat_var "x" (shortcut_ext_attr.ml[23,543+19]..[23,543+20]) - expression (shortcut_ext_attr.ml[23,543+24]..[23,543+26]) - Pexp_construct "()" (shortcut_ext_attr.ml[23,543+24]..[23,543+26]) + pattern (shortcut_ext_attr.ml[29,694+19]..[29,694+20]) + Ppat_var "x" (shortcut_ext_attr.ml[29,694+19]..[29,694+20]) + expression (shortcut_ext_attr.ml[29,694+24]..[29,694+26]) + Pexp_construct "()" (shortcut_ext_attr.ml[29,694+24]..[29,694+26]) None <case> - pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) ghost + pattern (shortcut_ext_attr.ml[30,721+4]..[30,721+25]) ghost Ppat_extension "foo" - pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) + pattern (shortcut_ext_attr.ml[30,721+4]..[30,721+25]) attribute "foo" [] Ppat_exception - pattern (shortcut_ext_attr.ml[24,570+24]..[24,570+25]) - Ppat_var "x" (shortcut_ext_attr.ml[24,570+24]..[24,570+25]) - expression (shortcut_ext_attr.ml[24,570+29]..[24,570+31]) - Pexp_construct "()" (shortcut_ext_attr.ml[24,570+29]..[24,570+31]) + pattern (shortcut_ext_attr.ml[30,721+24]..[30,721+25]) + Ppat_var "x" (shortcut_ext_attr.ml[30,721+24]..[30,721+25]) + expression (shortcut_ext_attr.ml[30,721+29]..[30,721+31]) + Pexp_construct "()" (shortcut_ext_attr.ml[30,721+29]..[30,721+31]) None ] ] ] ] ] - structure_item (shortcut_ext_attr.ml[28,628+0]..[40,898+5]) + structure_item (shortcut_ext_attr.ml[34,779+0]..[46,1049+5]) Pstr_class [ - class_declaration (shortcut_ext_attr.ml[28,628+0]..[40,898+5]) + class_declaration (shortcut_ext_attr.ml[34,779+0]..[46,1049+5]) pci_virt = Concrete pci_params = [] - pci_name = "x" (shortcut_ext_attr.ml[28,628+6]..[28,628+7]) + pci_name = "x" (shortcut_ext_attr.ml[34,779+6]..[34,779+7]) pci_expr = - class_expr (shortcut_ext_attr.ml[29,638+12]..[40,898+5]) + class_expr (shortcut_ext_attr.ml[35,789+12]..[46,1049+5]) attribute "foo" [] Pcl_fun Nolabel None - pattern (shortcut_ext_attr.ml[29,638+12]..[29,638+13]) - Ppat_var "x" (shortcut_ext_attr.ml[29,638+12]..[29,638+13]) - class_expr (shortcut_ext_attr.ml[30,655+2]..[40,898+5]) + pattern (shortcut_ext_attr.ml[35,789+12]..[35,789+13]) + Ppat_var "x" (shortcut_ext_attr.ml[35,789+12]..[35,789+13]) + class_expr (shortcut_ext_attr.ml[36,806+2]..[46,1049+5]) Pcl_let Nonrec [ <def> attribute "foo" [] - pattern (shortcut_ext_attr.ml[30,655+12]..[30,655+13]) - Ppat_var "x" (shortcut_ext_attr.ml[30,655+12]..[30,655+13]) - expression (shortcut_ext_attr.ml[30,655+16]..[30,655+17]) + pattern (shortcut_ext_attr.ml[36,806+12]..[36,806+13]) + Ppat_var "x" (shortcut_ext_attr.ml[36,806+12]..[36,806+13]) + expression (shortcut_ext_attr.ml[36,806+16]..[36,806+17]) Pexp_constant PConst_int (3,None) ] - class_expr (shortcut_ext_attr.ml[31,676+2]..[40,898+5]) + class_expr (shortcut_ext_attr.ml[37,827+2]..[46,1049+5]) attribute "foo" [] Pcl_structure class_structure - pattern (shortcut_ext_attr.ml[31,676+14]..[31,676+14]) ghost + pattern (shortcut_ext_attr.ml[37,827+14]..[37,827+14]) ghost Ppat_any [ - class_field (shortcut_ext_attr.ml[32,691+4]..[32,691+19]) + class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+19]) attribute "foo" [] Pcf_inherit Fresh - class_expr (shortcut_ext_attr.ml[32,691+18]..[32,691+19]) - Pcl_constr "x" (shortcut_ext_attr.ml[32,691+18]..[32,691+19]) + class_expr (shortcut_ext_attr.ml[38,842+18]..[38,842+19]) + Pcl_constr "x" (shortcut_ext_attr.ml[38,842+18]..[38,842+19]) [] None - class_field (shortcut_ext_attr.ml[33,711+4]..[33,711+19]) + class_field (shortcut_ext_attr.ml[39,862+4]..[39,862+19]) attribute "foo" [] Pcf_val Immutable - "x" (shortcut_ext_attr.ml[33,711+14]..[33,711+15]) + "x" (shortcut_ext_attr.ml[39,862+14]..[39,862+15]) Concrete Fresh - expression (shortcut_ext_attr.ml[33,711+18]..[33,711+19]) + expression (shortcut_ext_attr.ml[39,862+18]..[39,862+19]) Pexp_constant PConst_int (3,None) - class_field (shortcut_ext_attr.ml[34,731+4]..[34,731+27]) + class_field (shortcut_ext_attr.ml[40,882+4]..[40,882+27]) attribute "foo" [] Pcf_val Immutable - "x" (shortcut_ext_attr.ml[34,731+22]..[34,731+23]) + "x" (shortcut_ext_attr.ml[40,882+22]..[40,882+23]) Virtual - core_type (shortcut_ext_attr.ml[34,731+26]..[34,731+27]) - Ptyp_constr "t" (shortcut_ext_attr.ml[34,731+26]..[34,731+27]) + core_type (shortcut_ext_attr.ml[40,882+26]..[40,882+27]) + Ptyp_constr "t" (shortcut_ext_attr.ml[40,882+26]..[40,882+27]) [] - class_field (shortcut_ext_attr.ml[35,759+4]..[35,759+28]) + class_field (shortcut_ext_attr.ml[41,910+4]..[41,910+28]) attribute "foo" [] Pcf_val Mutable - "x" (shortcut_ext_attr.ml[35,759+23]..[35,759+24]) + "x" (shortcut_ext_attr.ml[41,910+23]..[41,910+24]) Concrete Override - expression (shortcut_ext_attr.ml[35,759+27]..[35,759+28]) + expression (shortcut_ext_attr.ml[41,910+27]..[41,910+28]) Pexp_constant PConst_int (3,None) - class_field (shortcut_ext_attr.ml[36,788+4]..[36,788+22]) + class_field (shortcut_ext_attr.ml[42,939+4]..[42,939+22]) attribute "foo" [] Pcf_method Public - "x" (shortcut_ext_attr.ml[36,788+17]..[36,788+18]) + "x" (shortcut_ext_attr.ml[42,939+17]..[42,939+18]) Concrete Fresh - expression (shortcut_ext_attr.ml[36,788+10]..[36,788+22]) ghost + expression (shortcut_ext_attr.ml[42,939+10]..[42,939+22]) ghost Pexp_poly - expression (shortcut_ext_attr.ml[36,788+21]..[36,788+22]) + expression (shortcut_ext_attr.ml[42,939+21]..[42,939+22]) Pexp_constant PConst_int (3,None) None - class_field (shortcut_ext_attr.ml[37,811+4]..[37,811+30]) + class_field (shortcut_ext_attr.ml[43,962+4]..[43,962+30]) attribute "foo" [] Pcf_method Public - "x" (shortcut_ext_attr.ml[37,811+25]..[37,811+26]) + "x" (shortcut_ext_attr.ml[43,962+25]..[43,962+26]) Virtual - core_type (shortcut_ext_attr.ml[37,811+29]..[37,811+30]) - Ptyp_constr "t" (shortcut_ext_attr.ml[37,811+29]..[37,811+30]) + core_type (shortcut_ext_attr.ml[43,962+29]..[43,962+30]) + Ptyp_constr "t" (shortcut_ext_attr.ml[43,962+29]..[43,962+30]) [] - class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+31]) + class_field (shortcut_ext_attr.ml[44,993+4]..[44,993+31]) attribute "foo" [] Pcf_method Private - "x" (shortcut_ext_attr.ml[38,842+26]..[38,842+27]) + "x" (shortcut_ext_attr.ml[44,993+26]..[44,993+27]) Concrete Override - expression (shortcut_ext_attr.ml[38,842+10]..[38,842+31]) ghost + expression (shortcut_ext_attr.ml[44,993+10]..[44,993+31]) ghost Pexp_poly - expression (shortcut_ext_attr.ml[38,842+30]..[38,842+31]) + expression (shortcut_ext_attr.ml[44,993+30]..[44,993+31]) Pexp_constant PConst_int (3,None) None - class_field (shortcut_ext_attr.ml[39,874+4]..[39,874+23]) + class_field (shortcut_ext_attr.ml[45,1025+4]..[45,1025+23]) attribute "foo" [] Pcf_initializer - expression (shortcut_ext_attr.ml[39,874+22]..[39,874+23]) - Pexp_ident "x" (shortcut_ext_attr.ml[39,874+22]..[39,874+23]) + expression (shortcut_ext_attr.ml[45,1025+22]..[45,1025+23]) + Pexp_ident "x" (shortcut_ext_attr.ml[45,1025+22]..[45,1025+23]) ] ] - structure_item (shortcut_ext_attr.ml[43,934+0]..[51,1114+5]) + structure_item (shortcut_ext_attr.ml[49,1085+0]..[57,1265+5]) Pstr_class_type [ - class_type_declaration (shortcut_ext_attr.ml[43,934+0]..[51,1114+5]) + class_type_declaration (shortcut_ext_attr.ml[49,1085+0]..[57,1265+5]) pci_virt = Concrete pci_params = [] - pci_name = "t" (shortcut_ext_attr.ml[43,934+11]..[43,934+12]) + pci_name = "t" (shortcut_ext_attr.ml[49,1085+11]..[49,1085+12]) pci_expr = - class_type (shortcut_ext_attr.ml[44,949+2]..[51,1114+5]) + class_type (shortcut_ext_attr.ml[50,1100+2]..[57,1265+5]) attribute "foo" [] Pcty_signature class_signature - core_type (shortcut_ext_attr.ml[44,949+14]..[44,949+14]) + core_type (shortcut_ext_attr.ml[50,1100+14]..[50,1100+14]) Ptyp_any [ - class_type_field (shortcut_ext_attr.ml[45,964+4]..[45,964+19]) + class_type_field (shortcut_ext_attr.ml[51,1115+4]..[51,1115+19]) attribute "foo" [] Pctf_inherit - class_type (shortcut_ext_attr.ml[45,964+18]..[45,964+19]) - Pcty_constr "t" (shortcut_ext_attr.ml[45,964+18]..[45,964+19]) + class_type (shortcut_ext_attr.ml[51,1115+18]..[51,1115+19]) + Pcty_constr "t" (shortcut_ext_attr.ml[51,1115+18]..[51,1115+19]) [] - class_type_field (shortcut_ext_attr.ml[46,984+4]..[46,984+19]) + class_type_field (shortcut_ext_attr.ml[52,1135+4]..[52,1135+19]) attribute "foo" [] Pctf_val "x" Immutable Concrete - core_type (shortcut_ext_attr.ml[46,984+18]..[46,984+19]) - Ptyp_constr "t" (shortcut_ext_attr.ml[46,984+18]..[46,984+19]) + core_type (shortcut_ext_attr.ml[52,1135+18]..[52,1135+19]) + Ptyp_constr "t" (shortcut_ext_attr.ml[52,1135+18]..[52,1135+19]) [] - class_type_field (shortcut_ext_attr.ml[47,1004+4]..[47,1004+27]) + class_type_field (shortcut_ext_attr.ml[53,1155+4]..[53,1155+27]) attribute "foo" [] Pctf_val "x" Mutable Concrete - core_type (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27]) - Ptyp_constr "t" (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27]) + core_type (shortcut_ext_attr.ml[53,1155+26]..[53,1155+27]) + Ptyp_constr "t" (shortcut_ext_attr.ml[53,1155+26]..[53,1155+27]) [] - class_type_field (shortcut_ext_attr.ml[48,1032+4]..[48,1032+22]) + class_type_field (shortcut_ext_attr.ml[54,1183+4]..[54,1183+22]) attribute "foo" [] Pctf_method "x" Public Concrete - core_type (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22]) - Ptyp_constr "t" (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22]) + core_type (shortcut_ext_attr.ml[54,1183+21]..[54,1183+22]) + Ptyp_constr "t" (shortcut_ext_attr.ml[54,1183+21]..[54,1183+22]) [] - class_type_field (shortcut_ext_attr.ml[49,1055+4]..[49,1055+30]) + class_type_field (shortcut_ext_attr.ml[55,1206+4]..[55,1206+30]) attribute "foo" [] Pctf_method "x" Private Concrete - core_type (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30]) - Ptyp_constr "t" (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30]) + core_type (shortcut_ext_attr.ml[55,1206+29]..[55,1206+30]) + Ptyp_constr "t" (shortcut_ext_attr.ml[55,1206+29]..[55,1206+30]) [] - class_type_field (shortcut_ext_attr.ml[50,1086+4]..[50,1086+27]) + class_type_field (shortcut_ext_attr.ml[56,1237+4]..[56,1237+27]) attribute "foo" [] Pctf_constraint - core_type (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22]) - Ptyp_constr "t" (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22]) + core_type (shortcut_ext_attr.ml[56,1237+21]..[56,1237+22]) + Ptyp_constr "t" (shortcut_ext_attr.ml[56,1237+21]..[56,1237+22]) [] - core_type (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27]) - Ptyp_constr "t'" (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27]) + core_type (shortcut_ext_attr.ml[56,1237+25]..[56,1237+27]) + Ptyp_constr "t'" (shortcut_ext_attr.ml[56,1237+25]..[56,1237+27]) [] ] ] - structure_item (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22]) + structure_item (shortcut_ext_attr.ml[60,1295+0]..[61,1304+22]) Pstr_type Rec [ - type_declaration "t" (shortcut_ext_attr.ml[54,1144+5]..[54,1144+6]) (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22]) + type_declaration "t" (shortcut_ext_attr.ml[60,1295+5]..[60,1295+6]) (shortcut_ext_attr.ml[60,1295+0]..[61,1304+22]) ptype_params = [] ptype_cstrs = @@ -497,86 +497,86 @@ ptype_private = Public ptype_manifest = Some - core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) ghost + core_type (shortcut_ext_attr.ml[61,1304+2]..[61,1304+22]) ghost Ptyp_extension "foo" - core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) + core_type (shortcut_ext_attr.ml[61,1304+2]..[61,1304+22]) attribute "foo" [] - Ptyp_package "M" (shortcut_ext_attr.ml[55,1153+20]..[55,1153+21]) + Ptyp_package "M" (shortcut_ext_attr.ml[61,1304+20]..[61,1304+21]) [] ] - structure_item (shortcut_ext_attr.ml[58,1202+0]..[61,1258+22]) + structure_item (shortcut_ext_attr.ml[64,1353+0]..[67,1409+22]) Pstr_module - "M" (shortcut_ext_attr.ml[58,1202+7]..[58,1202+8]) - module_expr (shortcut_ext_attr.ml[59,1213+2]..[61,1258+22]) + "M" (shortcut_ext_attr.ml[64,1353+7]..[64,1353+8]) + module_expr (shortcut_ext_attr.ml[65,1364+2]..[67,1409+22]) attribute "foo" [] - Pmod_functor "M" (shortcut_ext_attr.ml[59,1213+17]..[59,1213+18]) - module_type (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22]) - Pmty_ident "S" (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22]) - module_expr (shortcut_ext_attr.ml[60,1240+4]..[61,1258+22]) + Pmod_functor "M" (shortcut_ext_attr.ml[65,1364+17]..[65,1364+18]) + module_type (shortcut_ext_attr.ml[65,1364+21]..[65,1364+22]) + Pmty_ident "S" (shortcut_ext_attr.ml[65,1364+21]..[65,1364+22]) + module_expr (shortcut_ext_attr.ml[66,1391+4]..[67,1409+22]) Pmod_apply - module_expr (shortcut_ext_attr.ml[60,1240+4]..[60,1240+17]) + module_expr (shortcut_ext_attr.ml[66,1391+4]..[66,1391+17]) attribute "foo" [] Pmod_unpack - expression (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16]) - Pexp_ident "x" (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16]) - module_expr (shortcut_ext_attr.ml[61,1258+5]..[61,1258+21]) + expression (shortcut_ext_attr.ml[66,1391+15]..[66,1391+16]) + Pexp_ident "x" (shortcut_ext_attr.ml[66,1391+15]..[66,1391+16]) + module_expr (shortcut_ext_attr.ml[67,1409+5]..[67,1409+21]) attribute "foo" [] Pmod_structure [] - structure_item (shortcut_ext_attr.ml[64,1311+0]..[67,1384+19]) - Pstr_modtype "S" (shortcut_ext_attr.ml[64,1311+12]..[64,1311+13]) - module_type (shortcut_ext_attr.ml[65,1327+2]..[67,1384+19]) + structure_item (shortcut_ext_attr.ml[70,1462+0]..[73,1535+19]) + Pstr_modtype "S" (shortcut_ext_attr.ml[70,1462+12]..[70,1462+13]) + module_type (shortcut_ext_attr.ml[71,1478+2]..[73,1535+19]) attribute "foo" [] - Pmty_functor "M" (shortcut_ext_attr.ml[65,1327+17]..[65,1327+18]) - module_type (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20]) - Pmty_ident "S" (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20]) - module_type (shortcut_ext_attr.ml[66,1352+4]..[67,1384+19]) + Pmty_functor "M" (shortcut_ext_attr.ml[71,1478+17]..[71,1478+18]) + module_type (shortcut_ext_attr.ml[71,1478+19]..[71,1478+20]) + Pmty_ident "S" (shortcut_ext_attr.ml[71,1478+19]..[71,1478+20]) + module_type (shortcut_ext_attr.ml[72,1503+4]..[73,1535+19]) Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost - module_type (shortcut_ext_attr.ml[66,1352+5]..[66,1352+27]) + module_type (shortcut_ext_attr.ml[72,1503+5]..[72,1503+27]) attribute "foo" [] Pmty_typeof - module_expr (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27]) - Pmod_ident "M" (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27]) - module_type (shortcut_ext_attr.ml[67,1384+5]..[67,1384+18]) + module_expr (shortcut_ext_attr.ml[72,1503+26]..[72,1503+27]) + Pmod_ident "M" (shortcut_ext_attr.ml[72,1503+26]..[72,1503+27]) + module_type (shortcut_ext_attr.ml[73,1535+5]..[73,1535+18]) attribute "foo" [] Pmty_signature [] - structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) ghost + structure_item (shortcut_ext_attr.ml[76,1578+0]..[77,1598+15]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) + structure_item (shortcut_ext_attr.ml[76,1578+0]..[77,1598+15]) Pstr_value Nonrec [ <def> attribute "foo" [] - pattern (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15]) - Ppat_var "x" (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15]) - expression (shortcut_ext_attr.ml[70,1427+18]..[70,1427+19]) + pattern (shortcut_ext_attr.ml[76,1578+14]..[76,1578+15]) + Ppat_var "x" (shortcut_ext_attr.ml[76,1578+14]..[76,1578+15]) + expression (shortcut_ext_attr.ml[76,1578+18]..[76,1578+19]) Pexp_constant PConst_int (4,None) <def> attribute "foo" [] - pattern (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11]) - Ppat_var "y" (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11]) - expression (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15]) - Pexp_ident "x" (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15]) + pattern (shortcut_ext_attr.ml[77,1598+10]..[77,1598+11]) + Ppat_var "y" (shortcut_ext_attr.ml[77,1598+10]..[77,1598+11]) + expression (shortcut_ext_attr.ml[77,1598+14]..[77,1598+15]) + Pexp_ident "x" (shortcut_ext_attr.ml[77,1598+14]..[77,1598+15]) ] ] - structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) ghost + structure_item (shortcut_ext_attr.ml[79,1615+0]..[80,1638+17]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) + structure_item (shortcut_ext_attr.ml[79,1615+0]..[80,1638+17]) Pstr_type Rec [ - type_declaration "t" (shortcut_ext_attr.ml[73,1464+15]..[73,1464+16]) (shortcut_ext_attr.ml[73,1464+0]..[73,1464+22]) + type_declaration "t" (shortcut_ext_attr.ml[79,1615+15]..[79,1615+16]) (shortcut_ext_attr.ml[79,1615+0]..[79,1615+22]) attribute "foo" [] ptype_params = @@ -588,10 +588,10 @@ ptype_private = Public ptype_manifest = Some - core_type (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22]) - Ptyp_constr "int" (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22]) + core_type (shortcut_ext_attr.ml[79,1615+19]..[79,1615+22]) + Ptyp_constr "int" (shortcut_ext_attr.ml[79,1615+19]..[79,1615+22]) [] - type_declaration "t" (shortcut_ext_attr.ml[74,1487+10]..[74,1487+11]) (shortcut_ext_attr.ml[74,1487+0]..[74,1487+17]) + type_declaration "t" (shortcut_ext_attr.ml[80,1638+10]..[80,1638+11]) (shortcut_ext_attr.ml[80,1638+0]..[80,1638+17]) attribute "foo" [] ptype_params = @@ -603,25 +603,25 @@ ptype_private = Public ptype_manifest = Some - core_type (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17]) - Ptyp_constr "int" (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17]) + core_type (shortcut_ext_attr.ml[80,1638+14]..[80,1638+17]) + Ptyp_constr "int" (shortcut_ext_attr.ml[80,1638+14]..[80,1638+17]) [] ] ] - structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) ghost + structure_item (shortcut_ext_attr.ml[81,1656+0]..[81,1656+21]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) + structure_item (shortcut_ext_attr.ml[81,1656+0]..[81,1656+21]) Pstr_typext type_extension attribute "foo" [] - ptyext_path = "t" (shortcut_ext_attr.ml[75,1505+15]..[75,1505+16]) + ptyext_path = "t" (shortcut_ext_attr.ml[81,1656+15]..[81,1656+16]) ptyext_params = [] ptyext_constructors = [ - extension_constructor (shortcut_ext_attr.ml[75,1505+20]..[75,1505+21]) + extension_constructor (shortcut_ext_attr.ml[81,1656+20]..[81,1656+21]) pext_name = "T" pext_kind = Pext_decl @@ -630,64 +630,64 @@ ] ptyext_private = Public ] - structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) ghost + structure_item (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) + structure_item (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21]) Pstr_class [ - class_declaration (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) + class_declaration (shortcut_ext_attr.ml[83,1679+0]..[83,1679+21]) attribute "foo" [] pci_virt = Concrete pci_params = [] - pci_name = "x" (shortcut_ext_attr.ml[77,1528+16]..[77,1528+17]) + pci_name = "x" (shortcut_ext_attr.ml[83,1679+16]..[83,1679+17]) pci_expr = - class_expr (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21]) - Pcl_constr "x" (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21]) + class_expr (shortcut_ext_attr.ml[83,1679+20]..[83,1679+21]) + Pcl_constr "x" (shortcut_ext_attr.ml[83,1679+20]..[83,1679+21]) [] ] ] - structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) ghost + structure_item (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) + structure_item (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26]) Pstr_class_type [ - class_type_declaration (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) + class_type_declaration (shortcut_ext_attr.ml[84,1701+0]..[84,1701+26]) attribute "foo" [] pci_virt = Concrete pci_params = [] - pci_name = "x" (shortcut_ext_attr.ml[78,1550+21]..[78,1550+22]) + pci_name = "x" (shortcut_ext_attr.ml[84,1701+21]..[84,1701+22]) pci_expr = - class_type (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26]) - Pcty_constr "x" (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26]) + class_type (shortcut_ext_attr.ml[84,1701+25]..[84,1701+26]) + Pcty_constr "x" (shortcut_ext_attr.ml[84,1701+25]..[84,1701+26]) [] ] ] - structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) ghost + structure_item (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) + structure_item (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30]) Pstr_primitive - value_description "x" (shortcut_ext_attr.ml[79,1577+19]..[79,1577+20]) (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) + value_description "x" (shortcut_ext_attr.ml[85,1728+19]..[85,1728+20]) (shortcut_ext_attr.ml[85,1728+0]..[85,1728+30]) attribute "foo" [] - core_type (shortcut_ext_attr.ml[79,1577+23]..[79,1577+24]) + core_type (shortcut_ext_attr.ml[85,1728+23]..[85,1728+24]) Ptyp_any [ "" ] ] - structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) ghost + structure_item (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) + structure_item (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21]) Pstr_exception - extension_constructor (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) + extension_constructor (shortcut_ext_attr.ml[86,1759+0]..[86,1759+21]) attribute "foo" [] pext_name = "X" @@ -696,110 +696,110 @@ [] None ] - structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) ghost + structure_item (shortcut_ext_attr.ml[88,1782+0]..[88,1782+22]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) + structure_item (shortcut_ext_attr.ml[88,1782+0]..[88,1782+22]) Pstr_module - "M" (shortcut_ext_attr.ml[82,1631+17]..[82,1631+18]) + "M" (shortcut_ext_attr.ml[88,1782+17]..[88,1782+18]) attribute "foo" [] - module_expr (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22]) - Pmod_ident "M" (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22]) + module_expr (shortcut_ext_attr.ml[88,1782+21]..[88,1782+22]) + Pmod_ident "M" (shortcut_ext_attr.ml[88,1782+21]..[88,1782+22]) ] - structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) ghost + structure_item (shortcut_ext_attr.ml[89,1805+0]..[90,1836+19]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) + structure_item (shortcut_ext_attr.ml[89,1805+0]..[90,1836+19]) Pstr_recmodule [ - "M" (shortcut_ext_attr.ml[83,1654+21]..[83,1654+22]) + "M" (shortcut_ext_attr.ml[89,1805+21]..[89,1805+22]) attribute "foo" [] - module_expr (shortcut_ext_attr.ml[83,1654+23]..[83,1654+30]) + module_expr (shortcut_ext_attr.ml[89,1805+23]..[89,1805+30]) Pmod_constraint - module_expr (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30]) - Pmod_ident "M" (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30]) - module_type (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26]) - Pmty_ident "S" (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26]) - "M" (shortcut_ext_attr.ml[84,1685+10]..[84,1685+11]) + module_expr (shortcut_ext_attr.ml[89,1805+29]..[89,1805+30]) + Pmod_ident "M" (shortcut_ext_attr.ml[89,1805+29]..[89,1805+30]) + module_type (shortcut_ext_attr.ml[89,1805+25]..[89,1805+26]) + Pmty_ident "S" (shortcut_ext_attr.ml[89,1805+25]..[89,1805+26]) + "M" (shortcut_ext_attr.ml[90,1836+10]..[90,1836+11]) attribute "foo" [] - module_expr (shortcut_ext_attr.ml[84,1685+12]..[84,1685+19]) + module_expr (shortcut_ext_attr.ml[90,1836+12]..[90,1836+19]) Pmod_constraint - module_expr (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19]) - Pmod_ident "M" (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19]) - module_type (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15]) - Pmty_ident "S" (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15]) + module_expr (shortcut_ext_attr.ml[90,1836+18]..[90,1836+19]) + Pmod_ident "M" (shortcut_ext_attr.ml[90,1836+18]..[90,1836+19]) + module_type (shortcut_ext_attr.ml[90,1836+14]..[90,1836+15]) + Pmty_ident "S" (shortcut_ext_attr.ml[90,1836+14]..[90,1836+15]) ] ] - structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) ghost + structure_item (shortcut_ext_attr.ml[91,1856+0]..[91,1856+27]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) - Pstr_modtype "S" (shortcut_ext_attr.ml[85,1705+22]..[85,1705+23]) + structure_item (shortcut_ext_attr.ml[91,1856+0]..[91,1856+27]) + Pstr_modtype "S" (shortcut_ext_attr.ml[91,1856+22]..[91,1856+23]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27]) - Pmty_ident "S" (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27]) + module_type (shortcut_ext_attr.ml[91,1856+26]..[91,1856+27]) + Pmty_ident "S" (shortcut_ext_attr.ml[91,1856+26]..[91,1856+27]) ] - structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) ghost + structure_item (shortcut_ext_attr.ml[93,1885+0]..[93,1885+19]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) + structure_item (shortcut_ext_attr.ml[93,1885+0]..[93,1885+19]) Pstr_include attribute "foo" [] - module_expr (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19]) - Pmod_ident "M" (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19]) + module_expr (shortcut_ext_attr.ml[93,1885+18]..[93,1885+19]) + Pmod_ident "M" (shortcut_ext_attr.ml[93,1885+18]..[93,1885+19]) ] - structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) ghost + structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16]) ghost Pstr_extension "foo" [ - structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) - Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16]) + structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16]) + Pstr_open Fresh "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) attribute "foo" [] ] - structure_item (shortcut_ext_attr.ml[91,1794+0]..[114,2190+3]) - Pstr_modtype "S" (shortcut_ext_attr.ml[91,1794+12]..[91,1794+13]) - module_type (shortcut_ext_attr.ml[91,1794+16]..[114,2190+3]) + structure_item (shortcut_ext_attr.ml[97,1945+0]..[120,2341+3]) + Pstr_modtype "S" (shortcut_ext_attr.ml[97,1945+12]..[97,1945+13]) + module_type (shortcut_ext_attr.ml[97,1945+16]..[120,2341+3]) Pmty_signature [ - signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) ghost + signature_item (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) + signature_item (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21]) Psig_value - value_description "x" (shortcut_ext_attr.ml[92,1814+16]..[92,1814+17]) (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) + value_description "x" (shortcut_ext_attr.ml[98,1965+16]..[98,1965+17]) (shortcut_ext_attr.ml[98,1965+2]..[98,1965+21]) attribute "foo" [] - core_type (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21]) - Ptyp_constr "t" (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21]) + core_type (shortcut_ext_attr.ml[98,1965+20]..[98,1965+21]) + Ptyp_constr "t" (shortcut_ext_attr.ml[98,1965+20]..[98,1965+21]) [] [] ] - signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) ghost + signature_item (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) + signature_item (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31]) Psig_value - value_description "x" (shortcut_ext_attr.ml[93,1836+21]..[93,1836+22]) (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) + value_description "x" (shortcut_ext_attr.ml[99,1987+21]..[99,1987+22]) (shortcut_ext_attr.ml[99,1987+2]..[99,1987+31]) attribute "foo" [] - core_type (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26]) - Ptyp_constr "t" (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26]) + core_type (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26]) + Ptyp_constr "t" (shortcut_ext_attr.ml[99,1987+25]..[99,1987+26]) [] [ "" ] ] - signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) ghost + signature_item (shortcut_ext_attr.ml[101,2020+2]..[102,2045+20]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) + signature_item (shortcut_ext_attr.ml[101,2020+2]..[102,2045+20]) Psig_type Rec [ - type_declaration "t" (shortcut_ext_attr.ml[95,1869+17]..[95,1869+18]) (shortcut_ext_attr.ml[95,1869+2]..[95,1869+24]) + type_declaration "t" (shortcut_ext_attr.ml[101,2020+17]..[101,2020+18]) (shortcut_ext_attr.ml[101,2020+2]..[101,2020+24]) attribute "foo" [] ptype_params = @@ -811,10 +811,10 @@ ptype_private = Public ptype_manifest = Some - core_type (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24]) - Ptyp_constr "int" (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24]) + core_type (shortcut_ext_attr.ml[101,2020+21]..[101,2020+24]) + Ptyp_constr "int" (shortcut_ext_attr.ml[101,2020+21]..[101,2020+24]) [] - type_declaration "t'" (shortcut_ext_attr.ml[96,1894+12]..[96,1894+14]) (shortcut_ext_attr.ml[96,1894+2]..[96,1894+20]) + type_declaration "t'" (shortcut_ext_attr.ml[102,2045+12]..[102,2045+14]) (shortcut_ext_attr.ml[102,2045+2]..[102,2045+20]) attribute "foo" [] ptype_params = @@ -826,25 +826,25 @@ ptype_private = Public ptype_manifest = Some - core_type (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20]) - Ptyp_constr "int" (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20]) + core_type (shortcut_ext_attr.ml[102,2045+17]..[102,2045+20]) + Ptyp_constr "int" (shortcut_ext_attr.ml[102,2045+17]..[102,2045+20]) [] ] ] - signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) ghost + signature_item (shortcut_ext_attr.ml[103,2066+2]..[103,2066+23]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) + signature_item (shortcut_ext_attr.ml[103,2066+2]..[103,2066+23]) Psig_typext type_extension attribute "foo" [] - ptyext_path = "t" (shortcut_ext_attr.ml[97,1915+17]..[97,1915+18]) + ptyext_path = "t" (shortcut_ext_attr.ml[103,2066+17]..[103,2066+18]) ptyext_params = [] ptyext_constructors = [ - extension_constructor (shortcut_ext_attr.ml[97,1915+22]..[97,1915+23]) + extension_constructor (shortcut_ext_attr.ml[103,2066+22]..[103,2066+23]) pext_name = "T" pext_kind = Pext_decl @@ -853,12 +853,12 @@ ] ptyext_private = Public ] - signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) ghost + signature_item (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) + signature_item (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23]) Psig_exception - extension_constructor (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) + extension_constructor (shortcut_ext_attr.ml[105,2091+2]..[105,2091+23]) attribute "foo" [] pext_name = "X" @@ -867,112 +867,112 @@ [] None ] - signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) ghost + signature_item (shortcut_ext_attr.ml[107,2116+2]..[107,2116+24]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) - Psig_module "M" (shortcut_ext_attr.ml[101,1965+19]..[101,1965+20]) + signature_item (shortcut_ext_attr.ml[107,2116+2]..[107,2116+24]) + Psig_module "M" (shortcut_ext_attr.ml[107,2116+19]..[107,2116+20]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24]) - Pmty_ident "S" (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24]) + module_type (shortcut_ext_attr.ml[107,2116+23]..[107,2116+24]) + Pmty_ident "S" (shortcut_ext_attr.ml[107,2116+23]..[107,2116+24]) ] - signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) ghost + signature_item (shortcut_ext_attr.ml[108,2141+2]..[109,2170+17]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) + signature_item (shortcut_ext_attr.ml[108,2141+2]..[109,2170+17]) Psig_recmodule [ - "M" (shortcut_ext_attr.ml[102,1990+23]..[102,1990+24]) + "M" (shortcut_ext_attr.ml[108,2141+23]..[108,2141+24]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28]) - Pmty_ident "S" (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28]) - "M" (shortcut_ext_attr.ml[103,2019+12]..[103,2019+13]) + module_type (shortcut_ext_attr.ml[108,2141+27]..[108,2141+28]) + Pmty_ident "S" (shortcut_ext_attr.ml[108,2141+27]..[108,2141+28]) + "M" (shortcut_ext_attr.ml[109,2170+12]..[109,2170+13]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17]) - Pmty_ident "S" (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17]) + module_type (shortcut_ext_attr.ml[109,2170+16]..[109,2170+17]) + Pmty_ident "S" (shortcut_ext_attr.ml[109,2170+16]..[109,2170+17]) ] ] - signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) ghost + signature_item (shortcut_ext_attr.ml[110,2188+2]..[110,2188+24]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) - Psig_module "M" (shortcut_ext_attr.ml[104,2037+19]..[104,2037+20]) + signature_item (shortcut_ext_attr.ml[110,2188+2]..[110,2188+24]) + Psig_module "M" (shortcut_ext_attr.ml[110,2188+19]..[110,2188+20]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24]) - Pmty_alias "M" (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24]) + module_type (shortcut_ext_attr.ml[110,2188+23]..[110,2188+24]) + Pmty_alias "M" (shortcut_ext_attr.ml[110,2188+23]..[110,2188+24]) ] - signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) ghost + signature_item (shortcut_ext_attr.ml[112,2214+2]..[112,2214+29]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) - Psig_modtype "S" (shortcut_ext_attr.ml[106,2063+24]..[106,2063+25]) + signature_item (shortcut_ext_attr.ml[112,2214+2]..[112,2214+29]) + Psig_modtype "S" (shortcut_ext_attr.ml[112,2214+24]..[112,2214+25]) attribute "foo" [] - module_type (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29]) - Pmty_ident "S" (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29]) + module_type (shortcut_ext_attr.ml[112,2214+28]..[112,2214+29]) + Pmty_ident "S" (shortcut_ext_attr.ml[112,2214+28]..[112,2214+29]) ] - signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) ghost + signature_item (shortcut_ext_attr.ml[114,2245+2]..[114,2245+21]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) + signature_item (shortcut_ext_attr.ml[114,2245+2]..[114,2245+21]) Psig_include - module_type (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21]) - Pmty_ident "M" (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21]) + module_type (shortcut_ext_attr.ml[114,2245+20]..[114,2245+21]) + Pmty_ident "M" (shortcut_ext_attr.ml[114,2245+20]..[114,2245+21]) attribute "foo" [] ] - signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) ghost + signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) - Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18]) + signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18]) + Psig_open Fresh "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) attribute "foo" [] ] - signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) ghost + signature_item (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) + signature_item (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23]) Psig_class [ - class_description (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) + class_description (shortcut_ext_attr.ml[117,2287+2]..[117,2287+23]) attribute "foo" [] pci_virt = Concrete pci_params = [] - pci_name = "x" (shortcut_ext_attr.ml[111,2136+18]..[111,2136+19]) + pci_name = "x" (shortcut_ext_attr.ml[117,2287+18]..[117,2287+19]) pci_expr = - class_type (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23]) - Pcty_constr "t" (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23]) + class_type (shortcut_ext_attr.ml[117,2287+22]..[117,2287+23]) + Pcty_constr "t" (shortcut_ext_attr.ml[117,2287+22]..[117,2287+23]) [] ] ] - signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) ghost + signature_item (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28]) ghost Psig_extension "foo" [ - signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) + signature_item (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28]) Psig_class_type [ - class_type_declaration (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) + class_type_declaration (shortcut_ext_attr.ml[118,2311+2]..[118,2311+28]) attribute "foo" [] pci_virt = Concrete pci_params = [] - pci_name = "x" (shortcut_ext_attr.ml[112,2160+23]..[112,2160+24]) + pci_name = "x" (shortcut_ext_attr.ml[118,2311+23]..[118,2311+24]) pci_expr = - class_type (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28]) - Pcty_constr "x" (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28]) + class_type (shortcut_ext_attr.ml[118,2311+27]..[118,2311+28]) + Pcty_constr "x" (shortcut_ext_attr.ml[118,2311+27]..[118,2311+28]) [] ] ] ] ] -File "shortcut_ext_attr.ml", line 4, characters 6-9: +File "shortcut_ext_attr.ml", line 10, characters 6-9: Error: Uninterpreted extension 'foo'. diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml b/testsuite/tests/parsing/shortcut_ext_attr.ml index 7f6d1f51c1..222e7a0c97 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.ml +++ b/testsuite/tests/parsing/shortcut_ext_attr.ml @@ -1,4 +1,10 @@ - +(* TEST + flags = "-dparsetree" + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) (* Expressions *) let () = let%foo[@foo] x = 3 diff --git a/testsuite/tests/tool-lexyacc/Makefile b/testsuite/tests/tool-lexyacc/Makefile deleted file mode 100644 index 479e8a25e8..0000000000 --- a/testsuite/tests/tool-lexyacc/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -MODULES=syntax gram_aux grammar scan_aux scanner lexgen output -MAIN_MODULE=main -LEX_MODULES=scanner -YACC_MODULES=grammar -ADD_COMPFLAGS=-w a -EXEC_ARGS=input - -include $(BASEDIR)/makefiles/Makefile.one -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-lexyacc/main.compilers.reference b/testsuite/tests/tool-lexyacc/main.compilers.reference new file mode 100644 index 0000000000..a19b8c297b --- /dev/null +++ b/testsuite/tests/tool-lexyacc/main.compilers.reference @@ -0,0 +1 @@ +14 shift/reduce conflicts, 2 reduce/reduce conflicts. diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml index 16b9a3a932..4f58b93edc 100644 --- a/testsuite/tests/tool-lexyacc/main.ml +++ b/testsuite/tests/tool-lexyacc/main.ml @@ -1,3 +1,12 @@ +(* TEST + modules = "syntax.ml gram_aux.ml grammar.mly scan_aux.ml scanner.mll lexgen.ml output.ml" + files = "input" + arguments = "input" + ocamllex_flags = " -q " + ocamlyacc_flags = " -q " + flags = " -w a " +*) + (* The lexer generator. Command-line parsing. *) open Syntax diff --git a/testsuite/tests/tool-lexyacc/ocamltests b/testsuite/tests/tool-lexyacc/ocamltests new file mode 100644 index 0000000000..d389d15661 --- /dev/null +++ b/testsuite/tests/tool-lexyacc/ocamltests @@ -0,0 +1 @@ +main.ml diff --git a/testsuite/tests/tool-ocamlc-compat32/Makefile b/testsuite/tests/tool-ocamlc-compat32/Makefile deleted file mode 100644 index 938f0253fa..0000000000 --- a/testsuite/tests/tool-ocamlc-compat32/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -BASEDIR=../.. - -.PHONY: default -default: - @printf " ... testing -compat-32" - @if ($(OCAMLC) -config | grep "word_size: *64") \ - then $(MAKE) run; \ - else echo ' => skipped (not compiled in 64bit)'; \ - fi - -.PHONY: run -run: - @$(OCAMLC) -compat-32 -c a.ml > test.result 2>&1 || true - @$(OCAMLC) -c a.ml - @$(OCAMLC) -compat-32 -a a.cmo -o a.cma >> test.result 2>&1 || true - @$(OCAMLC) -a a.cmo -o a.cma - @$(OCAMLC) -compat-32 a.cma -o a.byte -linkall >> test.result 2>&1 || true - @$(DIFF) test.reference test.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - -promote: defaultpromote - -clean: defaultclean - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamlc-compat32/a.ml b/testsuite/tests/tool-ocamlc-compat32/a.ml deleted file mode 100644 index 81fdd4586b..0000000000 --- a/testsuite/tests/tool-ocamlc-compat32/a.ml +++ /dev/null @@ -1 +0,0 @@ -let a = 0xffffffffffff diff --git a/testsuite/tests/tool-ocamlc-compat32/compat32.compilers.reference b/testsuite/tests/tool-ocamlc-compat32/compat32.compilers.reference new file mode 100644 index 0000000000..0f74c72809 --- /dev/null +++ b/testsuite/tests/tool-ocamlc-compat32/compat32.compilers.reference @@ -0,0 +1,6 @@ +File "compat32.ml", line 1: +Error: Generated bytecode unit "compat32.cmo" cannot be used on a 32-bit platform +File "_none_", line 1: +Error: Generated bytecode library "compat32.cma" cannot be used on a 32-bit platform +File "_none_", line 1: +Error: Generated bytecode executable "compat32.byte" cannot be used on a 32-bit platform diff --git a/testsuite/tests/tool-ocamlc-compat32/compat32.ml b/testsuite/tests/tool-ocamlc-compat32/compat32.ml new file mode 100644 index 0000000000..8b09d8ab66 --- /dev/null +++ b/testsuite/tests/tool-ocamlc-compat32/compat32.ml @@ -0,0 +1,29 @@ +(* TEST + * arch64 + ** setup-ocamlc.byte-build-env + *** ocamlc.byte + compile_only = "true" + flags = "-compat-32" + ocamlc_byte_exit_status = "2" + **** ocamlc.byte + ocamlc_byte_exit_status = "0" + flags = "" + ***** ocamlc.byte + compile_only = "false" + all_modules = "compat32.cmo" + flags = "-compat-32 -a" + program = "compat32.cma" + ocamlc_byte_exit_status = "2" + ****** ocamlc.byte + flags = "-a" + program = "compat32.cma" + ocamlc_byte_exit_status = "0" + ******* ocamlc.byte + all_modules = "compat32.cma" + flags = "-compat-32 -linkall" + program = "compat32.byte" + ocamlc_byte_exit_status = "2" + ******** check-ocamlc.byte-output +*) + +let a = 0xffffffffffff diff --git a/testsuite/tests/tool-ocamlc-compat32/ocamltests b/testsuite/tests/tool-ocamlc-compat32/ocamltests new file mode 100644 index 0000000000..3f712ba6a9 --- /dev/null +++ b/testsuite/tests/tool-ocamlc-compat32/ocamltests @@ -0,0 +1 @@ +compat32.ml diff --git a/testsuite/tests/tool-ocamlc-compat32/test.reference b/testsuite/tests/tool-ocamlc-compat32/test.reference deleted file mode 100644 index 8ef25626ce..0000000000 --- a/testsuite/tests/tool-ocamlc-compat32/test.reference +++ /dev/null @@ -1,6 +0,0 @@ -File "a.ml", line 1: -Error: Generated bytecode unit "a.cmo" cannot be used on a 32-bit platform -File "_none_", line 1: -Error: Generated bytecode library "a.cma" cannot be used on a 32-bit platform -File "_none_", line 1: -Error: Generated bytecode executable "a.byte" cannot be used on a 32-bit platform diff --git a/testsuite/tests/tool-ocamldoc-2/Makefile b/testsuite/tests/tool-ocamldoc-2/Makefile deleted file mode 100644 index 18ba07db7b..0000000000 --- a/testsuite/tests/tool-ocamldoc-2/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -COMPFLAGS=-I $(OTOPDIR)/ocamldoc -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str -DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\ - -latextitle "1,subsection*" \ - -latextitle "2,subsubsection*" \ - -latextitle "6,subsection*" \ - -latextitle "7,subsubsection*" \ - -latex-type-prefix "TYP" \ - -latex-module-prefix "" \ - -latex-module-type-prefix "" \ - -latex-value-prefix "" - -.PHONY: default -default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - else \ - $(SET_LD_PATH) $(MAKE) run; \ - fi - -.PHONY: run -run: *.ml *.mli *.txt - @for file in *.mli *.ml *.txt; do \ - printf " ... testing '$$file'"; \ - F="`basename $$file .mli`"; \ - F="`basename $$F .ml`"; \ - F="`basename $$F .txt`"; \ - $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \ - -o $$F.result $$file; \ - $(DIFF) $$F.reference $$F.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamldoc-2/loop.ml b/testsuite/tests/tool-ocamldoc-2/loop.ml deleted file mode 100644 index b0306b76ca..0000000000 --- a/testsuite/tests/tool-ocamldoc-2/loop.ml +++ /dev/null @@ -1,3 +0,0 @@ - -module rec A : sig type t end = B and B : sig type t = A.t end = A;; - diff --git a/testsuite/tests/tool-ocamldoc-2/variants.mli b/testsuite/tests/tool-ocamldoc-2/variants.mli deleted file mode 100644 index 7562a0b8ff..0000000000 --- a/testsuite/tests/tool-ocamldoc-2/variants.mli +++ /dev/null @@ -1,38 +0,0 @@ -(** This test is here to check the latex code generated for variants *) - -type s = A | B (** only B is documented here *) | C - -type t = - | A - (** doc for A *) - | B - (** doc for B *) - -(** Some documentation for u*) -type u = -| A (** doc for A *) | B of unit (** doc for B *) - - -(** With records *) -type w = -| A of { x: int } - (** doc for A *) -| B of { y:int } - (** doc for B *) - -(** With args *) -type z = -| A of int - (** doc for A *) -| B of int - (** doc for B *) - -(** Gadt notation *) -type a = - A: a (** doc for A*) - -(** Lonely constructor *) -type b = - B (** doc for B *) - -type no_documentation = A | B | C diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.mli b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli deleted file mode 100644 index f80cd2bd11..0000000000 --- a/testsuite/tests/tool-ocamldoc-html/Inline_records.mli +++ /dev/null @@ -1,45 +0,0 @@ -(** - This test focuses on the printing of documentation for inline record - within the latex generator. -*) - - -(** A nice exception *) -exception Simple - -(** An open sum type *) -type ext = .. - -(** A simple record type for reference *) -type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *); - more:int list (** More documentation for r, [more : int list] *) } - - -(** A sum type with one inline record *) -type t = A of {lbl: int (** [A] field documentation *) - ; more:int list (** More [A] field documentation *) } -(** Constructor documentation *) - -(** A sum type with two inline records *) -type s = - | B of { a_label_for_B : int (** [B] field documentation *); - more_label_for_B:int list (** More [B] field documentation *) } - (** Constructor B documentation *) - | C of { c_has_label_too: float (** [C] field documentation*); - more_than_one: unit (** ... documentations *) } - (** Constructor C documentation *) - -(** A gadt constructor *) -type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any -(** Constructor D documentation *) - -exception Error of {name:string (** Error field documentation [name:string] *) } - -type ext += - | E of { yet_another_field: unit (** Field documentation for [E] in ext *) } - (** Constructor E documentation *) - | F of { even_more: int -> int (** Some field documentations for [F] *) } - (** Constructor F documentation *) - | G of { last: int -> int (** The last and least field documentation *) } - (** Constructor G documentation *) -(** Two new constructors for ext *) diff --git a/testsuite/tests/tool-ocamldoc-html/Makefile b/testsuite/tests/tool-ocamldoc-html/Makefile deleted file mode 100644 index 116b580b9e..0000000000 --- a/testsuite/tests/tool-ocamldoc-html/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -COMPFLAGS=-I $(OTOPDIR)/ocamldoc -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str -DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\ - -latextitle "6,subsection*" \ - -latextitle "7,subsubsection*" \ - -latex-type-prefix "TYP" \ - -latex-module-prefix "" \ - -latex-module-type-prefix "" \ - -latex-value-prefix "" - -.PHONY: default -default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - else \ - $(SET_LD_PATH) $(MAKE) run; \ - fi - -.PHONY: run -run: *.mli *.ml -# Note that we strip both .ml and .mli extensions - @for file in *.ml *.mli; do \ - printf " ... testing '$$file'"; \ - F="`basename $$file .mli`"; \ - F="`basename $$F .ml`"; \ - $(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \ - -o index $$file; \ - cp $$F.html $$F.result; \ - $(DIFF) $$F.reference $$F.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done;\ -# For linebreaks.mli, we also compare type_Linebreaks.html and not only -# the main html file - @cp type_Linebreaks.html type_Linebreaks.result;\ - printf " ... testing 'type_Linebreak.html'";\ - $(DIFF) type_Linebreaks.reference type_Linebreaks.result\ - && echo " => passed" || echo " => failed" - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.mli b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli deleted file mode 100644 index f80cd2bd11..0000000000 --- a/testsuite/tests/tool-ocamldoc-man/Inline_records.mli +++ /dev/null @@ -1,45 +0,0 @@ -(** - This test focuses on the printing of documentation for inline record - within the latex generator. -*) - - -(** A nice exception *) -exception Simple - -(** An open sum type *) -type ext = .. - -(** A simple record type for reference *) -type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *); - more:int list (** More documentation for r, [more : int list] *) } - - -(** A sum type with one inline record *) -type t = A of {lbl: int (** [A] field documentation *) - ; more:int list (** More [A] field documentation *) } -(** Constructor documentation *) - -(** A sum type with two inline records *) -type s = - | B of { a_label_for_B : int (** [B] field documentation *); - more_label_for_B:int list (** More [B] field documentation *) } - (** Constructor B documentation *) - | C of { c_has_label_too: float (** [C] field documentation*); - more_than_one: unit (** ... documentations *) } - (** Constructor C documentation *) - -(** A gadt constructor *) -type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any -(** Constructor D documentation *) - -exception Error of {name:string (** Error field documentation [name:string] *) } - -type ext += - | E of { yet_another_field: unit (** Field documentation for [E] in ext *) } - (** Constructor E documentation *) - | F of { even_more: int -> int (** Some field documentations for [F] *) } - (** Constructor F documentation *) - | G of { last: int -> int (** The last and least field documentation *) } - (** Constructor G documentation *) -(** Two new constructors for ext *) diff --git a/testsuite/tests/tool-ocamldoc-man/Makefile b/testsuite/tests/tool-ocamldoc-man/Makefile deleted file mode 100644 index a3c272a115..0000000000 --- a/testsuite/tests/tool-ocamldoc-man/Makefile +++ /dev/null @@ -1,54 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -COMPFLAGS=-I $(OTOPDIR)/ocamldoc -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str -DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\ - -latextitle "6,subsection*" \ - -latextitle "7,subsubsection*" \ - -latex-type-prefix "TYP" \ - -latex-module-prefix "" \ - -latex-module-type-prefix "" \ - -latex-value-prefix "" - -.PHONY: default -default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - else \ - $(SET_LD_PATH) $(MAKE) run; \ - fi - -.PHONY: run -run: *.mli - @for file in *.mli; do \ - printf " ... testing '$$file'"; \ - F="`basename $$file .mli`"; \ - $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -man $ \ - -o index $$file; \ - tail -n +2 $$F.3o > $$F.result; \ - $(DIFF) $$F.reference $$F.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux *.3o - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamldoc-open/Makefile b/testsuite/tests/tool-ocamldoc-open/Makefile deleted file mode 100644 index 92f09a1d60..0000000000 --- a/testsuite/tests/tool-ocamldoc-open/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -BASEDIR=../.. -COMPFLAGS=-I $(OTOPDIR)/ocamldoc -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str -DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS) - -SRC= main.ml alias.ml inner.ml -ODOCS=$(SRC:%.ml=%.odoc) - -.PHONY: default -default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - else \ - $(SET_LD_PATH) $(MAKE) doc; \ - fi - -.PHONY: doc -doc: $(ODOCS) - @printf " ... testing ocamldoc '-open' option";\ - $(OCAMLDOC) $(DOCFLAGS) -hide-warnings \ - -load alias.odoc -load inner.odoc \ - -load main.odoc -latex -o doc.result ;\ - $(DIFF) doc.result doc.reference > /dev/null \ - && echo " => passed" || echo " => failed"; - -inner.odoc: inner.ml - @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \ - -dump inner.odoc inner.ml - -alias.odoc: inner.cmi alias.ml - @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \ - -dump alias.odoc alias.ml - -main.odoc: alias.cmi main.ml - @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \ - -open Alias.Container -open Aliased_inner -dump main.odoc main.ml - -alias.cmi:inner.cmi - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.odoc *.toc *.sty *.aux *.log *.result - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamldoc-open/doc.reference b/testsuite/tests/tool-ocamldoc-open/main.latex.reference index 29c5eaf07b..29c5eaf07b 100644 --- a/testsuite/tests/tool-ocamldoc-open/doc.reference +++ b/testsuite/tests/tool-ocamldoc-open/main.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-open/main.ml b/testsuite/tests/tool-ocamldoc-open/main.ml index abc1f818f3..4dca4e546d 100644 --- a/testsuite/tests/tool-ocamldoc-open/main.ml +++ b/testsuite/tests/tool-ocamldoc-open/main.ml @@ -1,3 +1,9 @@ +(* TEST + modules = "inner.ml alias.ml" + * ocamldoc + ocamldoc_backend="latex" + ocamldoc_flags=" -open Alias.Container -open Aliased_inner " +*) (** Documentation test *) diff --git a/testsuite/tests/tool-ocamldoc-open/main.ocamldoc.latex.reference b/testsuite/tests/tool-ocamldoc-open/main.ocamldoc.latex.reference new file mode 100644 index 0000000000..930579ee7d --- /dev/null +++ b/testsuite/tests/tool-ocamldoc-open/main.ocamldoc.latex.reference @@ -0,0 +1,3 @@ +Warning: Module or module type Inner not found +Warning: Module or module type Inner not found +Warning: Module or module type Inner not found diff --git a/testsuite/tests/tool-ocamldoc-open/ocamltests b/testsuite/tests/tool-ocamldoc-open/ocamltests new file mode 100644 index 0000000000..d389d15661 --- /dev/null +++ b/testsuite/tests/tool-ocamldoc-open/ocamltests @@ -0,0 +1 @@ +main.ml diff --git a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.reference b/testsuite/tests/tool-ocamldoc/Documentation_tags.html.reference index 53f9d79efa..53f9d79efa 100644 --- a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.reference +++ b/testsuite/tests/tool-ocamldoc/Documentation_tags.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.mli b/testsuite/tests/tool-ocamldoc/Documentation_tags.mli index bac254ab72..413a4ca08d 100644 --- a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.mli +++ b/testsuite/tests/tool-ocamldoc/Documentation_tags.mli @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with html +*) + (** Test the html rendering of ocamldoc documentation tags *) val heterological: unit diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference b/testsuite/tests/tool-ocamldoc/Extensible_variant.latex.reference index a4b01455d2..a4b01455d2 100644 --- a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference +++ b/testsuite/tests/tool-ocamldoc/Extensible_variant.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml b/testsuite/tests/tool-ocamldoc/Extensible_variant.ml index 324a48d880..f459fa276b 100644 --- a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml +++ b/testsuite/tests/tool-ocamldoc/Extensible_variant.ml @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with latex +*) + (** Testing display of extensible variant types and exceptions. @test_types_display diff --git a/testsuite/tests/tool-ocamldoc/Extensible_variant.ocamldoc.latex.reference b/testsuite/tests/tool-ocamldoc/Extensible_variant.ocamldoc.latex.reference new file mode 100644 index 0000000000..c80cf1420f --- /dev/null +++ b/testsuite/tests/tool-ocamldoc/Extensible_variant.ocamldoc.latex.reference @@ -0,0 +1 @@ +Warning: Tag @test_types_display not handled by this generator diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference b/testsuite/tests/tool-ocamldoc/Inline_records.html.reference index 92d9e79d36..617a5e6ef3 100644 --- a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference +++ b/testsuite/tests/tool-ocamldoc/Inline_records.html.reference @@ -32,6 +32,13 @@ </div> </div> +<pre><span id="EXCEPTIONLess"><span class="keyword">exception</span> Less</span> <span class="keyword">of</span> <code class="type">int</code></pre> +<div class="info "> +<div class="info-desc"> +<p>A less simple exception</p> +</div> +</div> + <pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre> <div class="info "> <div class="info-desc"> diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.reference b/testsuite/tests/tool-ocamldoc/Inline_records.latex.reference index 506f253a8d..506f253a8d 100644 --- a/testsuite/tests/tool-ocamldoc-2/inline_records.reference +++ b/testsuite/tests/tool-ocamldoc/Inline_records.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.reference b/testsuite/tests/tool-ocamldoc/Inline_records.man.reference index 7184b97102..a2890e4045 100644 --- a/testsuite/tests/tool-ocamldoc-man/Inline_records.reference +++ b/testsuite/tests/tool-ocamldoc/Inline_records.man.reference @@ -24,6 +24,15 @@ within the latex generator\&. A nice exception .sp + +.I exception Less +.B of +.B int + +.sp +A less simple exception + +.sp .I type ext = .. diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.mli b/testsuite/tests/tool-ocamldoc/Inline_records.mli index ee5f14d722..5b4646d9e1 100644 --- a/testsuite/tests/tool-ocamldoc-2/inline_records.mli +++ b/testsuite/tests/tool-ocamldoc/Inline_records.mli @@ -1,3 +1,9 @@ +(* TEST + * ocamldoc with html + * ocamldoc with latex + * ocamldoc with man +*) + (** This test focuses on the printing of documentation for inline record within the latex generator. diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference b/testsuite/tests/tool-ocamldoc/Inline_records_bis.latex.reference index 25986d097b..25986d097b 100644 --- a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference +++ b/testsuite/tests/tool-ocamldoc/Inline_records_bis.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml b/testsuite/tests/tool-ocamldoc/Inline_records_bis.ml index ee5f14d722..4844aaf27a 100644 --- a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml +++ b/testsuite/tests/tool-ocamldoc/Inline_records_bis.ml @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with latex +*) + (** This test focuses on the printing of documentation for inline record within the latex generator. diff --git a/testsuite/tests/tool-ocamldoc-html/Item_ids.reference b/testsuite/tests/tool-ocamldoc/Item_ids.html.reference index 94eddefcfe..94eddefcfe 100644 --- a/testsuite/tests/tool-ocamldoc-html/Item_ids.reference +++ b/testsuite/tests/tool-ocamldoc/Item_ids.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Item_ids.mli b/testsuite/tests/tool-ocamldoc/Item_ids.mli index 9001d3a107..878c6fef30 100644 --- a/testsuite/tests/tool-ocamldoc-html/Item_ids.mli +++ b/testsuite/tests/tool-ocamldoc/Item_ids.mli @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with html +*) + (** Check that all toplevel items are given a unique id. *) exception Ex @@ -10,4 +14,3 @@ class type ct= object end [@@@attribute] module M: sig end module type s = sig end - diff --git a/testsuite/tests/tool-ocamldoc-2/level_0.reference b/testsuite/tests/tool-ocamldoc/Level_0.latex.reference index 331512ffc1..331512ffc1 100644 --- a/testsuite/tests/tool-ocamldoc-2/level_0.reference +++ b/testsuite/tests/tool-ocamldoc/Level_0.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-2/level_0.mli b/testsuite/tests/tool-ocamldoc/Level_0.mli index 22c4665d21..d9458572a0 100644 --- a/testsuite/tests/tool-ocamldoc-2/level_0.mli +++ b/testsuite/tests/tool-ocamldoc/Level_0.mli @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with latex +*) + (** Test for level 0 headings {1 Level 1} diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference b/testsuite/tests/tool-ocamldoc/Linebreaks.html.reference index 8abb6dc9f0..8abb6dc9f0 100644 --- a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference +++ b/testsuite/tests/tool-ocamldoc/Linebreaks.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli b/testsuite/tests/tool-ocamldoc/Linebreaks.mli index cca816f301..1dce3838b8 100644 --- a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli +++ b/testsuite/tests/tool-ocamldoc/Linebreaks.mli @@ -1,3 +1,10 @@ +(* TEST + * ocamldoc with html + ** check-program-output + output="type_Linebreaks.html" + reference="${test_source_directory}/type_Linebreaks.reference" +*) + (** This file tests the encoding of linebreak inside OCaml code by the ocamldoc html backend. diff --git a/testsuite/tests/tool-ocamldoc-html/Loop.reference b/testsuite/tests/tool-ocamldoc/Loop.html.reference index 2025479d06..2025479d06 100644 --- a/testsuite/tests/tool-ocamldoc-html/Loop.reference +++ b/testsuite/tests/tool-ocamldoc/Loop.html.reference diff --git a/testsuite/tests/tool-ocamldoc-2/loop.reference b/testsuite/tests/tool-ocamldoc/Loop.latex.reference index 8c386f300e..8c386f300e 100644 --- a/testsuite/tests/tool-ocamldoc-2/loop.reference +++ b/testsuite/tests/tool-ocamldoc/Loop.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Loop.ml b/testsuite/tests/tool-ocamldoc/Loop.ml index b0306b76ca..8428f9fc15 100644 --- a/testsuite/tests/tool-ocamldoc-html/Loop.ml +++ b/testsuite/tests/tool-ocamldoc/Loop.ml @@ -1,3 +1,5 @@ - +(* TEST + * ocamldoc with html + * ocamldoc with latex +*) module rec A : sig type t end = B and B : sig type t = A.t end = A;; - diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile deleted file mode 100644 index e28c62f1b1..0000000000 --- a/testsuite/tests/tool-ocamldoc/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Clerc, SED, INRIA Rocquencourt * -#* * -#* Copyright 2010 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. * -#* * -#************************************************************************** - -BASEDIR=../.. -CUSTOM_MODULE=odoc_test -COMPFLAGS=-I $(OTOPDIR)/ocamldoc -LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str -DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS) - -.PHONY: default -default: - @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ - echo 'skipped (shared libraries not available)'; \ - else \ - $(SET_LD_PATH) $(MAKE) run; \ - fi - -.PHONY: run -run: $(CUSTOM_MODULE).cmo - @for file in t*.ml; do \ - printf " ... testing '$$file'"; \ - F="`basename $$file .ml`"; \ - $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -g $(CUSTOM_MODULE).cmo \ - -o $$F.result $$file; \ - $(DIFF) $$F.reference $$F.result >/dev/null \ - && echo " => passed" || echo " => failed"; \ - done; - @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -html t*.ml 2>&1 \ - | grep -v test_types_display || true - @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex t*.ml 2>&1 \ - | grep -v test_types_display || true - -.PHONY: promote -promote: defaultpromote - -.PHONY: clean -clean: defaultclean - @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux - -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference b/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference index d8c837baba..d8c837baba 100644 --- a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference +++ b/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml b/testsuite/tests/tool-ocamldoc/Module_whitespace.ml index d9ddee7b6f..75c6c29274 100644 --- a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.ml +++ b/testsuite/tests/tool-ocamldoc/Module_whitespace.ml @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with html +*) + module M = Set.Make(struct type t = int let compare = compare diff --git a/testsuite/tests/tool-ocamldoc/Module_whitespace.ocamldoc.html.reference b/testsuite/tests/tool-ocamldoc/Module_whitespace.ocamldoc.html.reference new file mode 100644 index 0000000000..515605c3c1 --- /dev/null +++ b/testsuite/tests/tool-ocamldoc/Module_whitespace.ocamldoc.html.reference @@ -0,0 +1,2 @@ +Warning: Module or module type Stdlib.Set.Make not found +Warning: Module or module type Stdlib.Set.Make not found diff --git a/testsuite/tests/tool-ocamldoc-html/No_preamble.reference b/testsuite/tests/tool-ocamldoc/No_preamble.html.reference index f34662e88f..f34662e88f 100644 --- a/testsuite/tests/tool-ocamldoc-html/No_preamble.reference +++ b/testsuite/tests/tool-ocamldoc/No_preamble.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/No_preamble.mli b/testsuite/tests/tool-ocamldoc/No_preamble.mli index 2760e266fb..7d016dda22 100644 --- a/testsuite/tests/tool-ocamldoc-html/No_preamble.mli +++ b/testsuite/tests/tool-ocamldoc/No_preamble.mli @@ -1,3 +1,6 @@ +(* TEST + * ocamldoc with html +*) open String diff --git a/testsuite/tests/tool-ocamldoc-html/Paragraph.reference b/testsuite/tests/tool-ocamldoc/Paragraph.html.reference index 84dee74cf2..84dee74cf2 100644 --- a/testsuite/tests/tool-ocamldoc-html/Paragraph.reference +++ b/testsuite/tests/tool-ocamldoc/Paragraph.html.reference diff --git a/testsuite/tests/tool-ocamldoc-html/Paragraph.mli b/testsuite/tests/tool-ocamldoc/Paragraph.mli index 7081da1de7..5e94589c83 100644 --- a/testsuite/tests/tool-ocamldoc-html/Paragraph.mli +++ b/testsuite/tests/tool-ocamldoc/Paragraph.mli @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with html +*) + (** This file tests the generation of paragraph within module comments. diff --git a/testsuite/tests/tool-ocamldoc-2/short_description.reference b/testsuite/tests/tool-ocamldoc/Short_description.latex.reference index 9cc843fc00..4a938e4168 100644 --- a/testsuite/tests/tool-ocamldoc-2/short_description.reference +++ b/testsuite/tests/tool-ocamldoc/Short_description.latex.reference @@ -7,11 +7,16 @@ \usepackage{ocamldoc} \begin{document} \tableofcontents -\section{Short\_description : Short global description in text mode} +\section{Short\_description : (* TEST + * ocamldoc with latex +*)} \label{Short-underscoredescription}\index{Short-underscoredescription@\verb`Short_description`} +Short global description in text mode + + This file tests that documentation in text mode are given a short description in the global description of modules. diff --git a/testsuite/tests/tool-ocamldoc-2/short_description.txt b/testsuite/tests/tool-ocamldoc/Short_description.txt index 7241f875c2..e0021ea697 100644 --- a/testsuite/tests/tool-ocamldoc-2/short_description.txt +++ b/testsuite/tests/tool-ocamldoc/Short_description.txt @@ -1,3 +1,7 @@ +(* TEST + * ocamldoc with latex +*) + Short global description in text mode This file tests that documentation in text mode are given diff --git a/testsuite/tests/tool-ocamldoc-2/test.reference b/testsuite/tests/tool-ocamldoc/Test.latex.reference index a9861f7ff9..a9861f7ff9 100644 --- a/testsuite/tests/tool-ocamldoc-2/test.reference +++ b/testsuite/tests/tool-ocamldoc/Test.latex.reference diff --git a/testsuite/tests/tool-ocamldoc-2/test.mli b/testsuite/tests/tool-ocamldoc/Test.mli index 3c4ec1546c..b28c8e734e 100644 --- a/testsuite/tests/tool-ocamldoc-2/test.mli +++ b/testsuite/tests/tool-ocamldoc/Test.mli @@ -1,3 +1,6 @@ +(* TEST + * ocamldoc with latex +*) (** Ten comments for tests *) diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.reference b/testsuite/tests/tool-ocamldoc/Variants.html.reference index d5aa791dfa..aa6775bb55 100644 --- a/testsuite/tests/tool-ocamldoc-html/Variants.reference +++ b/testsuite/tests/tool-ocamldoc/Variants.html.reference @@ -265,4 +265,18 @@ </tr></table> + +<pre><code><span id="TYPEe"><span class="keyword">type</span> <code class="type"></code>e</span> = </code></pre><table class="typetable"> +<tr> +<td align="left" valign="top" > +<code><span class="keyword">|</span></code></td> +<td align="left" valign="top" > +<code></table> + +<div class="info "> +<div class="info-desc"> +<p>Empty variant</p> +</div> +</div> + </body></html>
\ No newline at end of file diff --git a/testsuite/tests/tool-ocamldoc-2/variants.reference b/testsuite/tests/tool-ocamldoc/Variants.latex.reference index 4d1753c72c..bc61839148 100644 --- a/testsuite/tests/tool-ocamldoc-2/variants.reference +++ b/testsuite/tests/tool-ocamldoc/Variants.latex.reference @@ -40,7 +40,17 @@ type t = | A \end{ocamldoccode} \begin{ocamldoccomment} -doc for A +doc for A. + \begin{ocamldoccode} +0 +\end{ocamldoccode} + + With three paragraphs. + \begin{ocamldoccode} +1 +\end{ocamldoccode} + + To check styling \end{ocamldoccomment} @@ -187,4 +197,18 @@ type no_documentation = \index{no-underscoredocumentation@\verb`no_documentation`} + + +\label{TYPVariants.e}\begin{ocamldoccode} +type e = + | +\end{ocamldoccode} +\index{e@\verb`e`} +\begin{ocamldocdescription} +Empty variant + + +\end{ocamldocdescription} + + \end{document} diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.mli b/testsuite/tests/tool-ocamldoc/Variants.mli index f60c267e4d..137a42ce6d 100644 --- a/testsuite/tests/tool-ocamldoc-html/Variants.mli +++ b/testsuite/tests/tool-ocamldoc/Variants.mli @@ -1,3 +1,8 @@ +(* TEST + * ocamldoc with html + * ocamldoc with latex +*) + (** This test is here to check the latex code generated for variants *) type s = A | B (** only B is documented here *) | C @@ -41,3 +46,6 @@ type b = B (** doc for B *) type no_documentation = A | B | C + +(** Empty variant *) +type e = | diff --git a/testsuite/tests/tool-ocamldoc/ocamltests b/testsuite/tests/tool-ocamldoc/ocamltests new file mode 100644 index 0000000000..0d05eb3dbd --- /dev/null +++ b/testsuite/tests/tool-ocamldoc/ocamltests @@ -0,0 +1,19 @@ +Documentation_tags.mli +Extensible_variant.ml +Inline_records.mli +Inline_records_bis.ml +Item_ids.mli +Paragraph.mli +Module_whitespace.ml +No_preamble.mli +Level_0.mli +Linebreaks.mli +Loop.ml +Short_description.txt +t01.ml +t02.ml +t03.ml +t04.ml +t05.ml +Test.mli +Variants.mli diff --git a/testsuite/tests/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml index b1db38ea65..1003b47f2d 100644 --- a/testsuite/tests/tool-ocamldoc/t01.ml +++ b/testsuite/tests/tool-ocamldoc/t01.ml @@ -1,3 +1,9 @@ +(* TEST + plugins="odoc_test.ml" + * ocamldoc + flags="-I ${ocamlsrcdir}/ocamldoc" +*) + (** Testing display of types. @test_types_display diff --git a/testsuite/tests/tool-ocamldoc/t02.ml b/testsuite/tests/tool-ocamldoc/t02.ml index d7c9742134..a2280cf8f3 100644 --- a/testsuite/tests/tool-ocamldoc/t02.ml +++ b/testsuite/tests/tool-ocamldoc/t02.ml @@ -1,3 +1,9 @@ +(* TEST + plugins="odoc_test.ml" + * ocamldoc + flags="-I ${ocamlsrcdir}/ocamldoc" +*) + module Foo = struct type u type t = int let x = 1 end;; module type TFoo = module type of Foo;; diff --git a/testsuite/tests/tool-ocamldoc/t03.ml b/testsuite/tests/tool-ocamldoc/t03.ml index 9d9e1593b4..3ee319ba02 100644 --- a/testsuite/tests/tool-ocamldoc/t03.ml +++ b/testsuite/tests/tool-ocamldoc/t03.ml @@ -1,3 +1,9 @@ +(* TEST + plugins="odoc_test.ml" + * ocamldoc + flags="-I ${ocamlsrcdir}/ocamldoc" +*) + module Foo = struct type t = int let x = 1 end;; module type MT = module type of Foo;; module Bar = struct type t = int let x = 2 end;; diff --git a/testsuite/tests/tool-ocamldoc/t03.ocamldoc.reference b/testsuite/tests/tool-ocamldoc/t03.ocamldoc.reference new file mode 100644 index 0000000000..cbf7ddccfa --- /dev/null +++ b/testsuite/tests/tool-ocamldoc/t03.ocamldoc.reference @@ -0,0 +1 @@ +Warning: Module type not found diff --git a/testsuite/tests/tool-ocamldoc/t04.ml b/testsuite/tests/tool-ocamldoc/t04.ml index 97782ae678..d815b4ccc0 100644 --- a/testsuite/tests/tool-ocamldoc/t04.ml +++ b/testsuite/tests/tool-ocamldoc/t04.ml @@ -1,3 +1,9 @@ +(* TEST + plugins="odoc_test.ml" + * ocamldoc + flags="-I ${ocamlsrcdir}/ocamldoc" +*) + (** Testing display of inline record. @test_types_display diff --git a/testsuite/tests/tool-ocamldoc/t05.ml b/testsuite/tests/tool-ocamldoc/t05.ml index b0306b76ca..885dc90a32 100644 --- a/testsuite/tests/tool-ocamldoc/t05.ml +++ b/testsuite/tests/tool-ocamldoc/t05.ml @@ -1,3 +1,7 @@ +(* TEST + plugins="odoc_test.ml" + * ocamldoc + flags="-I ${ocamlsrcdir}/ocamldoc" +*) module rec A : sig type t end = B and B : sig type t = A.t end = A;; - diff --git a/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference b/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference index ad097f1136..ad097f1136 100644 --- a/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference +++ b/testsuite/tests/tool-ocamldoc/type_Linebreaks.reference diff --git a/testsuite/tests/translprim/Makefile b/testsuite/tests/translprim/Makefile deleted file mode 100644 index cdfef9a21c..0000000000 --- a/testsuite/tests/translprim/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -newdefault: array_spec.ml.reference module_coercion.ml.reference - $(MAKE) default - -BASEDIR=../.. -TOPFLAGS+=-dlambda -include $(BASEDIR)/makefiles/Makefile.dlambda -include $(BASEDIR)/makefiles/Makefile.common - -GENERATED_SOURCES = array_spec.ml.reference module_coercion.ml.reference \ - *.flat-float - -ifeq "$(FLAT_FLOAT_ARRAY)" "true" -suffix = -flat -else -suffix = -noflat -endif - -array_spec.ml.reference: array_spec.ml.reference$(suffix) \ - $(FLAT_FLOAT_ARRAY).flat-float - cp $< $@ - -module_coercion.ml.reference: module_coercion.ml.reference$(suffix) \ - $(FLAT_FLOAT_ARRAY).flat-float - cp $< $@ - -%.flat-float: - @rm -f $(GENERATED_SOURCES) - @touch $@ diff --git a/testsuite/tests/translprim/array_spec.compilers.reference.flat b/testsuite/tests/translprim/array_spec.compilers.reference.flat new file mode 100644 index 0000000000..c692c8a9a4 --- /dev/null +++ b/testsuite/tests/translprim/array_spec.compilers.reference.flat @@ -0,0 +1,65 @@ +(setglobal Array_spec! + (let + (int_a = (makearray[int] 1 2 3) + float_a = (makearray[float] 1. 2. 3.) + addr_a = (makearray[addr] "a" "b" "c")) + (seq (array.length[int] int_a) (array.length[float] float_a) + (array.length[addr] addr_a) (function a (array.length[gen] a)) + (array.get[int] int_a 0) (array.get[float] float_a 0) + (array.get[addr] addr_a 0) (function a (array.get[gen] a 0)) + (array.unsafe_get[int] int_a 0) (array.unsafe_get[float] float_a 0) + (array.unsafe_get[addr] addr_a 0) + (function a (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1) + (array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a") + (function a x (array.set[gen] a 0 x)) (array.unsafe_set[int] int_a 0 1) + (array.unsafe_set[float] float_a 0 1.) + (array.unsafe_set[addr] addr_a 0 "a") + (function a x (array.unsafe_set[gen] a 0 x)) + (let + (eta_gen_len = (function prim stub (array.length[gen] prim)) + eta_gen_safe_get = + (function prim prim stub (array.get[gen] prim prim)) + eta_gen_unsafe_get = + (function prim prim stub (array.unsafe_get[gen] prim prim)) + eta_gen_safe_set = + (function prim prim prim stub (array.set[gen] prim prim prim)) + eta_gen_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[gen] prim prim prim)) + eta_int_len = (function prim stub (array.length[int] prim)) + eta_int_safe_get = + (function prim prim stub (array.get[int] prim prim)) + eta_int_unsafe_get = + (function prim prim stub (array.unsafe_get[int] prim prim)) + eta_int_safe_set = + (function prim prim prim stub (array.set[int] prim prim prim)) + eta_int_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[int] prim prim prim)) + eta_float_len = (function prim stub (array.length[float] prim)) + eta_float_safe_get = + (function prim prim stub (array.get[float] prim prim)) + eta_float_unsafe_get = + (function prim prim stub (array.unsafe_get[float] prim prim)) + eta_float_safe_set = + (function prim prim prim stub (array.set[float] prim prim prim)) + eta_float_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[float] prim prim prim)) + eta_addr_len = (function prim stub (array.length[addr] prim)) + eta_addr_safe_get = + (function prim prim stub (array.get[addr] prim prim)) + eta_addr_unsafe_get = + (function prim prim stub (array.unsafe_get[addr] prim prim)) + eta_addr_safe_set = + (function prim prim prim stub (array.set[addr] prim prim prim)) + eta_addr_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim))) + (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get + eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len + eta_int_safe_get eta_int_unsafe_get eta_int_safe_set + eta_int_unsafe_set eta_float_len eta_float_safe_get + eta_float_unsafe_get eta_float_safe_set eta_float_unsafe_set + eta_addr_len eta_addr_safe_get eta_addr_unsafe_get + eta_addr_safe_set eta_addr_unsafe_set))))) diff --git a/testsuite/tests/translprim/array_spec.compilers.reference.no-flat b/testsuite/tests/translprim/array_spec.compilers.reference.no-flat new file mode 100644 index 0000000000..b653805006 --- /dev/null +++ b/testsuite/tests/translprim/array_spec.compilers.reference.no-flat @@ -0,0 +1,65 @@ +(setglobal Array_spec! + (let + (int_a = (makearray[int] 1 2 3) + float_a = (makearray[addr] 1. 2. 3.) + addr_a = (makearray[addr] "a" "b" "c")) + (seq (array.length[int] int_a) (array.length[addr] float_a) + (array.length[addr] addr_a) (function a (array.length[addr] a)) + (array.get[int] int_a 0) (array.get[addr] float_a 0) + (array.get[addr] addr_a 0) (function a (array.get[addr] a 0)) + (array.unsafe_get[int] int_a 0) (array.unsafe_get[addr] float_a 0) + (array.unsafe_get[addr] addr_a 0) + (function a (array.unsafe_get[addr] a 0)) (array.set[int] int_a 0 1) + (array.set[addr] float_a 0 1.) (array.set[addr] addr_a 0 "a") + (function a x (array.set[addr] a 0 x)) + (array.unsafe_set[int] int_a 0 1) (array.unsafe_set[addr] float_a 0 1.) + (array.unsafe_set[addr] addr_a 0 "a") + (function a x (array.unsafe_set[addr] a 0 x)) + (let + (eta_gen_len = (function prim stub (array.length[addr] prim)) + eta_gen_safe_get = + (function prim prim stub (array.get[addr] prim prim)) + eta_gen_unsafe_get = + (function prim prim stub (array.unsafe_get[addr] prim prim)) + eta_gen_safe_set = + (function prim prim prim stub (array.set[addr] prim prim prim)) + eta_gen_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + eta_int_len = (function prim stub (array.length[int] prim)) + eta_int_safe_get = + (function prim prim stub (array.get[int] prim prim)) + eta_int_unsafe_get = + (function prim prim stub (array.unsafe_get[int] prim prim)) + eta_int_safe_set = + (function prim prim prim stub (array.set[int] prim prim prim)) + eta_int_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[int] prim prim prim)) + eta_float_len = (function prim stub (array.length[addr] prim)) + eta_float_safe_get = + (function prim prim stub (array.get[addr] prim prim)) + eta_float_unsafe_get = + (function prim prim stub (array.unsafe_get[addr] prim prim)) + eta_float_safe_set = + (function prim prim prim stub (array.set[addr] prim prim prim)) + eta_float_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + eta_addr_len = (function prim stub (array.length[addr] prim)) + eta_addr_safe_get = + (function prim prim stub (array.get[addr] prim prim)) + eta_addr_unsafe_get = + (function prim prim stub (array.unsafe_get[addr] prim prim)) + eta_addr_safe_set = + (function prim prim prim stub (array.set[addr] prim prim prim)) + eta_addr_unsafe_set = + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim))) + (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get + eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len + eta_int_safe_get eta_int_unsafe_get eta_int_safe_set + eta_int_unsafe_set eta_float_len eta_float_safe_get + eta_float_unsafe_get eta_float_safe_set eta_float_unsafe_set + eta_addr_len eta_addr_safe_get eta_addr_unsafe_get + eta_addr_safe_set eta_addr_unsafe_set))))) diff --git a/testsuite/tests/translprim/array_spec.ml b/testsuite/tests/translprim/array_spec.ml index e78c96343c..d84979d495 100644 --- a/testsuite/tests/translprim/array_spec.ml +++ b/testsuite/tests/translprim/array_spec.ml @@ -1,3 +1,15 @@ +(* TEST + * setup-ocamlc.byte-build-env + ** ocamlc.byte + flags = "-dlambda -dno-unique-ids" + *** flat-float-array + **** check-ocamlc.byte-output + compiler_reference = "${test_source_directory}/array_spec.compilers.reference.flat" + *** no-flat-float-array + **** check-ocamlc.byte-output + compiler_reference = "${test_source_directory}/array_spec.compilers.reference.no-flat" +*) + external len : 'a array -> int = "%array_length" external safe_get : 'a array -> int -> 'a = "%array_safe_get" external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" diff --git a/testsuite/tests/translprim/array_spec.ml.reference-flat b/testsuite/tests/translprim/array_spec.ml.reference-flat deleted file mode 100644 index 83fe0c4cdc..0000000000 --- a/testsuite/tests/translprim/array_spec.ml.reference-flat +++ /dev/null @@ -1,88 +0,0 @@ -(setglobal Array_spec! - (let - (int_a = (makearray[int] 1 2 3) - float_a = (makearray[float] 1. 2. 3.) - addr_a = (makearray[addr] "a" "b" "c")) - (seq (array.length[int] int_a) (array.length[float] float_a) - (array.length[addr] addr_a) - (function a (array.length[gen] a)) - (array.get[int] int_a 0) (array.get[float] float_a 0) - (array.get[addr] addr_a 0) - (function a (array.get[gen] a 0)) - (array.unsafe_get[int] int_a 0) - (array.unsafe_get[float] float_a 0) - (array.unsafe_get[addr] addr_a 0) - (function a (array.unsafe_get[gen] a 0)) - (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.) - (array.set[addr] addr_a 0 "a") - (function a x (array.set[gen] a 0 x)) - (array.unsafe_set[int] int_a 0 1) - (array.unsafe_set[float] float_a 0 1.) - (array.unsafe_set[addr] addr_a 0 "a") - (function a x (array.unsafe_set[gen] a 0 x)) - (let - (eta_gen_len = - (function prim stub (array.length[gen] prim)) - eta_gen_safe_get = - (function prim prim stub - (array.get[gen] prim prim)) - eta_gen_unsafe_get = - (function prim prim stub - (array.unsafe_get[gen] prim prim)) - eta_gen_safe_set = - (function prim prim prim stub - (array.set[gen] prim prim prim)) - eta_gen_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[gen] prim prim prim)) - eta_int_len = - (function prim stub (array.length[int] prim)) - eta_int_safe_get = - (function prim prim stub - (array.get[int] prim prim)) - eta_int_unsafe_get = - (function prim prim stub - (array.unsafe_get[int] prim prim)) - eta_int_safe_set = - (function prim prim prim stub - (array.set[int] prim prim prim)) - eta_int_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[int] prim prim prim)) - eta_float_len = - (function prim stub (array.length[float] prim)) - eta_float_safe_get = - (function prim prim stub - (array.get[float] prim prim)) - eta_float_unsafe_get = - (function prim prim stub - (array.unsafe_get[float] prim prim)) - eta_float_safe_set = - (function prim prim prim stub - (array.set[float] prim prim prim)) - eta_float_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[float] prim prim prim)) - eta_addr_len = - (function prim stub (array.length[addr] prim)) - eta_addr_safe_get = - (function prim prim stub - (array.get[addr] prim prim)) - eta_addr_unsafe_get = - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - eta_addr_safe_set = - (function prim prim prim stub - (array.set[addr] prim prim prim)) - eta_addr_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim))) - (makeblock 0 int_a float_a addr_a eta_gen_len - eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set - eta_gen_unsafe_set eta_int_len eta_int_safe_get - eta_int_unsafe_get eta_int_safe_set - eta_int_unsafe_set eta_float_len eta_float_safe_get - eta_float_unsafe_get eta_float_safe_set - eta_float_unsafe_set eta_addr_len eta_addr_safe_get - eta_addr_unsafe_get eta_addr_safe_set - eta_addr_unsafe_set))))) diff --git a/testsuite/tests/translprim/array_spec.ml.reference-noflat b/testsuite/tests/translprim/array_spec.ml.reference-noflat deleted file mode 100644 index ba90062d41..0000000000 --- a/testsuite/tests/translprim/array_spec.ml.reference-noflat +++ /dev/null @@ -1,88 +0,0 @@ -(setglobal Array_spec! - (let - (int_a = (makearray[int] 1 2 3) - float_a = (makearray[addr] 1. 2. 3.) - addr_a = (makearray[addr] "a" "b" "c")) - (seq (array.length[int] int_a) (array.length[addr] float_a) - (array.length[addr] addr_a) - (function a (array.length[addr] a)) - (array.get[int] int_a 0) (array.get[addr] float_a 0) - (array.get[addr] addr_a 0) - (function a (array.get[addr] a 0)) - (array.unsafe_get[int] int_a 0) - (array.unsafe_get[addr] float_a 0) - (array.unsafe_get[addr] addr_a 0) - (function a (array.unsafe_get[addr] a 0)) - (array.set[int] int_a 0 1) (array.set[addr] float_a 0 1.) - (array.set[addr] addr_a 0 "a") - (function a x (array.set[addr] a 0 x)) - (array.unsafe_set[int] int_a 0 1) - (array.unsafe_set[addr] float_a 0 1.) - (array.unsafe_set[addr] addr_a 0 "a") - (function a x (array.unsafe_set[addr] a 0 x)) - (let - (eta_gen_len = - (function prim stub (array.length[addr] prim)) - eta_gen_safe_get = - (function prim prim stub - (array.get[addr] prim prim)) - eta_gen_unsafe_get = - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - eta_gen_safe_set = - (function prim prim prim stub - (array.set[addr] prim prim prim)) - eta_gen_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - eta_int_len = - (function prim stub (array.length[int] prim)) - eta_int_safe_get = - (function prim prim stub - (array.get[int] prim prim)) - eta_int_unsafe_get = - (function prim prim stub - (array.unsafe_get[int] prim prim)) - eta_int_safe_set = - (function prim prim prim stub - (array.set[int] prim prim prim)) - eta_int_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[int] prim prim prim)) - eta_float_len = - (function prim stub (array.length[addr] prim)) - eta_float_safe_get = - (function prim prim stub - (array.get[addr] prim prim)) - eta_float_unsafe_get = - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - eta_float_safe_set = - (function prim prim prim stub - (array.set[addr] prim prim prim)) - eta_float_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - eta_addr_len = - (function prim stub (array.length[addr] prim)) - eta_addr_safe_get = - (function prim prim stub - (array.get[addr] prim prim)) - eta_addr_unsafe_get = - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - eta_addr_safe_set = - (function prim prim prim stub - (array.set[addr] prim prim prim)) - eta_addr_unsafe_set = - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim))) - (makeblock 0 int_a float_a addr_a eta_gen_len - eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set - eta_gen_unsafe_set eta_int_len eta_int_safe_get - eta_int_unsafe_get eta_int_safe_set - eta_int_unsafe_set eta_float_len eta_float_safe_get - eta_float_unsafe_get eta_float_safe_set - eta_float_unsafe_set eta_addr_len eta_addr_safe_get - eta_addr_unsafe_get eta_addr_safe_set - eta_addr_unsafe_set))))) diff --git a/testsuite/tests/translprim/comparison_table.compilers.reference b/testsuite/tests/translprim/comparison_table.compilers.reference new file mode 100644 index 0000000000..b3c439fe52 --- /dev/null +++ b/testsuite/tests/translprim/comparison_table.compilers.reference @@ -0,0 +1,248 @@ +(setglobal Comparison_table! + (let + (gen_cmp = (function x y (caml_compare x y)) + int_cmp = (function x y (caml_int_compare x y)) + bool_cmp = (function x y (caml_int_compare x y)) + intlike_cmp = (function x y (caml_int_compare x y)) + float_cmp = (function x y (caml_float_compare x y)) + string_cmp = (function x y (caml_string_compare x y)) + int32_cmp = (function x y (caml_int32_compare x y)) + int64_cmp = (function x y (caml_int64_compare x y)) + nativeint_cmp = (function x y (caml_nativeint_compare x y)) + gen_eq = (function x y (caml_equal x y)) + int_eq = (function x y (== x y)) + bool_eq = (function x y (== x y)) + intlike_eq = (function x y (== x y)) + float_eq = (function x y (==. x y)) + string_eq = (function x y (caml_string_equal x y)) + int32_eq = (function x y (Int32.== x y)) + int64_eq = (function x y (Int64.== x y)) + nativeint_eq = (function x y (Nativeint.== x y)) + gen_ne = (function x y (caml_notequal x y)) + int_ne = (function x y (!= x y)) + bool_ne = (function x y (!= x y)) + intlike_ne = (function x y (!= x y)) + float_ne = (function x y (!=. x y)) + string_ne = (function x y (caml_string_notequal x y)) + int32_ne = (function x y (Int32.!= x y)) + int64_ne = (function x y (Int64.!= x y)) + nativeint_ne = (function x y (Nativeint.!= x y)) + gen_lt = (function x y (caml_lessthan x y)) + int_lt = (function x y (< x y)) + bool_lt = (function x y (< x y)) + intlike_lt = (function x y (< x y)) + float_lt = (function x y (<. x y)) + string_lt = (function x y (caml_string_lessthan x y)) + int32_lt = (function x y (Int32.< x y)) + int64_lt = (function x y (Int64.< x y)) + nativeint_lt = (function x y (Nativeint.< x y)) + gen_gt = (function x y (caml_greaterthan x y)) + int_gt = (function x y (> x y)) + bool_gt = (function x y (> x y)) + intlike_gt = (function x y (> x y)) + float_gt = (function x y (>. x y)) + string_gt = (function x y (caml_string_greaterthan x y)) + int32_gt = (function x y (Int32.> x y)) + int64_gt = (function x y (Int64.> x y)) + nativeint_gt = (function x y (Nativeint.> x y)) + gen_le = (function x y (caml_lessequal x y)) + int_le = (function x y (<= x y)) + bool_le = (function x y (<= x y)) + intlike_le = (function x y (<= x y)) + float_le = (function x y (<=. x y)) + string_le = (function x y (caml_string_lessequal x y)) + int32_le = (function x y (Int32.<= x y)) + int64_le = (function x y (Int64.<= x y)) + nativeint_le = (function x y (Nativeint.<= x y)) + gen_ge = (function x y (caml_greaterequal x y)) + int_ge = (function x y (>= x y)) + bool_ge = (function x y (>= x y)) + intlike_ge = (function x y (>= x y)) + float_ge = (function x y (>=. x y)) + string_ge = (function x y (caml_string_greaterequal x y)) + int32_ge = (function x y (Int32.>= x y)) + int64_ge = (function x y (Int64.>= x y)) + nativeint_ge = (function x y (Nativeint.>= x y)) + eta_gen_cmp = (function prim prim stub (caml_compare prim prim)) + eta_int_cmp = (function prim prim stub (caml_int_compare prim prim)) + eta_bool_cmp = (function prim prim stub (caml_int_compare prim prim)) + eta_intlike_cmp = (function prim prim stub (caml_int_compare prim prim)) + eta_float_cmp = (function prim prim stub (caml_float_compare prim prim)) + eta_string_cmp = + (function prim prim stub (caml_string_compare prim prim)) + eta_int32_cmp = (function prim prim stub (caml_int32_compare prim prim)) + eta_int64_cmp = (function prim prim stub (caml_int64_compare prim prim)) + eta_nativeint_cmp = + (function prim prim stub (caml_nativeint_compare prim prim)) + eta_gen_eq = (function prim prim stub (caml_equal prim prim)) + eta_int_eq = (function prim prim stub (== prim prim)) + eta_bool_eq = (function prim prim stub (== prim prim)) + eta_intlike_eq = (function prim prim stub (== prim prim)) + eta_float_eq = (function prim prim stub (==. prim prim)) + eta_string_eq = (function prim prim stub (caml_string_equal prim prim)) + eta_int32_eq = (function prim prim stub (Int32.== prim prim)) + eta_int64_eq = (function prim prim stub (Int64.== prim prim)) + eta_nativeint_eq = (function prim prim stub (Nativeint.== prim prim)) + eta_gen_ne = (function prim prim stub (caml_notequal prim prim)) + eta_int_ne = (function prim prim stub (!= prim prim)) + eta_bool_ne = (function prim prim stub (!= prim prim)) + eta_intlike_ne = (function prim prim stub (!= prim prim)) + eta_float_ne = (function prim prim stub (!=. prim prim)) + eta_string_ne = + (function prim prim stub (caml_string_notequal prim prim)) + eta_int32_ne = (function prim prim stub (Int32.!= prim prim)) + eta_int64_ne = (function prim prim stub (Int64.!= prim prim)) + eta_nativeint_ne = (function prim prim stub (Nativeint.!= prim prim)) + eta_gen_lt = (function prim prim stub (caml_lessthan prim prim)) + eta_int_lt = (function prim prim stub (< prim prim)) + eta_bool_lt = (function prim prim stub (< prim prim)) + eta_intlike_lt = (function prim prim stub (< prim prim)) + eta_float_lt = (function prim prim stub (<. prim prim)) + eta_string_lt = + (function prim prim stub (caml_string_lessthan prim prim)) + eta_int32_lt = (function prim prim stub (Int32.< prim prim)) + eta_int64_lt = (function prim prim stub (Int64.< prim prim)) + eta_nativeint_lt = (function prim prim stub (Nativeint.< prim prim)) + eta_gen_gt = (function prim prim stub (caml_greaterthan prim prim)) + eta_int_gt = (function prim prim stub (> prim prim)) + eta_bool_gt = (function prim prim stub (> prim prim)) + eta_intlike_gt = (function prim prim stub (> prim prim)) + eta_float_gt = (function prim prim stub (>. prim prim)) + eta_string_gt = + (function prim prim stub (caml_string_greaterthan prim prim)) + eta_int32_gt = (function prim prim stub (Int32.> prim prim)) + eta_int64_gt = (function prim prim stub (Int64.> prim prim)) + eta_nativeint_gt = (function prim prim stub (Nativeint.> prim prim)) + eta_gen_le = (function prim prim stub (caml_lessequal prim prim)) + eta_int_le = (function prim prim stub (<= prim prim)) + eta_bool_le = (function prim prim stub (<= prim prim)) + eta_intlike_le = (function prim prim stub (<= prim prim)) + eta_float_le = (function prim prim stub (<=. prim prim)) + eta_string_le = + (function prim prim stub (caml_string_lessequal prim prim)) + eta_int32_le = (function prim prim stub (Int32.<= prim prim)) + eta_int64_le = (function prim prim stub (Int64.<= prim prim)) + eta_nativeint_le = (function prim prim stub (Nativeint.<= prim prim)) + eta_gen_ge = (function prim prim stub (caml_greaterequal prim prim)) + eta_int_ge = (function prim prim stub (>= prim prim)) + eta_bool_ge = (function prim prim stub (>= prim prim)) + eta_intlike_ge = (function prim prim stub (>= prim prim)) + eta_float_ge = (function prim prim stub (>=. prim prim)) + eta_string_ge = + (function prim prim stub (caml_string_greaterequal prim prim)) + eta_int32_ge = (function prim prim stub (Int32.>= prim prim)) + eta_int64_ge = (function prim prim stub (Int64.>= prim prim)) + eta_nativeint_ge = (function prim prim stub (Nativeint.>= prim prim)) + int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]] + bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] + intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] + float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]] + string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]] + int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]] + int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]] + nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]] + test_vec = + (function cmp eq ne lt gt le ge vec + (let + (uncurry = + (function f param (apply f (field 0 param) (field 1 param))) + map = + (function f l + (apply (field 16 (global Stdlib__list!)) (apply uncurry f) l))) + (makeblock 0 + (makeblock 0 (apply map gen_cmp vec) (apply map cmp vec)) + (apply map + (function gen spec + (makeblock 0 (apply map gen vec) (apply map spec vec))) + (makeblock 0 (makeblock 0 gen_eq eq) + (makeblock 0 (makeblock 0 gen_ne ne) + (makeblock 0 (makeblock 0 gen_lt lt) + (makeblock 0 (makeblock 0 gen_gt gt) + (makeblock 0 (makeblock 0 gen_le le) + (makeblock 0 (makeblock 0 gen_ge ge) 0a))))))))))) + (seq + (apply test_vec int_cmp int_eq int_ne int_lt int_gt int_le int_ge + int_vec) + (apply test_vec bool_cmp bool_eq bool_ne bool_lt bool_gt bool_le + bool_ge bool_vec) + (apply test_vec intlike_cmp intlike_eq intlike_ne intlike_lt intlike_gt + intlike_le intlike_ge intlike_vec) + (apply test_vec float_cmp float_eq float_ne float_lt float_gt float_le + float_ge float_vec) + (apply test_vec string_cmp string_eq string_ne string_lt string_gt + string_le string_ge string_vec) + (apply test_vec int32_cmp int32_eq int32_ne int32_lt int32_gt int32_le + int32_ge int32_vec) + (apply test_vec int64_cmp int64_eq int64_ne int64_lt int64_gt int64_le + int64_ge int64_vec) + (apply test_vec nativeint_cmp nativeint_eq nativeint_ne nativeint_lt + nativeint_gt nativeint_le nativeint_ge nativeint_vec) + (let + (eta_test_vec = + (function cmp eq ne lt gt le ge vec + (let + (uncurry = + (function f param + (apply f (field 0 param) (field 1 param))) + map = + (function f l + (apply (field 16 (global Stdlib__list!)) + (apply uncurry f) l))) + (makeblock 0 + (makeblock 0 (apply map eta_gen_cmp vec) + (apply map cmp vec)) + (apply map + (function gen spec + (makeblock 0 (apply map gen vec) (apply map spec vec))) + (makeblock 0 (makeblock 0 eta_gen_eq eq) + (makeblock 0 (makeblock 0 eta_gen_ne ne) + (makeblock 0 (makeblock 0 eta_gen_lt lt) + (makeblock 0 (makeblock 0 eta_gen_gt gt) + (makeblock 0 (makeblock 0 eta_gen_le le) + (makeblock 0 (makeblock 0 eta_gen_ge ge) 0a))))))))))) + (seq + (apply eta_test_vec eta_int_cmp eta_int_eq eta_int_ne eta_int_lt + eta_int_gt eta_int_le eta_int_ge int_vec) + (apply eta_test_vec eta_bool_cmp eta_bool_eq eta_bool_ne + eta_bool_lt eta_bool_gt eta_bool_le eta_bool_ge bool_vec) + (apply eta_test_vec eta_intlike_cmp eta_intlike_eq eta_intlike_ne + eta_intlike_lt eta_intlike_gt eta_intlike_le eta_intlike_ge + intlike_vec) + (apply eta_test_vec eta_float_cmp eta_float_eq eta_float_ne + eta_float_lt eta_float_gt eta_float_le eta_float_ge float_vec) + (apply eta_test_vec eta_string_cmp eta_string_eq eta_string_ne + eta_string_lt eta_string_gt eta_string_le eta_string_ge + string_vec) + (apply eta_test_vec eta_int32_cmp eta_int32_eq eta_int32_ne + eta_int32_lt eta_int32_gt eta_int32_le eta_int32_ge int32_vec) + (apply eta_test_vec eta_int64_cmp eta_int64_eq eta_int64_ne + eta_int64_lt eta_int64_gt eta_int64_le eta_int64_ge int64_vec) + (apply eta_test_vec eta_nativeint_cmp eta_nativeint_eq + eta_nativeint_ne eta_nativeint_lt eta_nativeint_gt + eta_nativeint_le eta_nativeint_ge nativeint_vec) + (makeblock 0 gen_cmp int_cmp bool_cmp intlike_cmp float_cmp + string_cmp int32_cmp int64_cmp nativeint_cmp gen_eq int_eq + bool_eq intlike_eq float_eq string_eq int32_eq int64_eq + nativeint_eq gen_ne int_ne bool_ne intlike_ne float_ne string_ne + int32_ne int64_ne nativeint_ne gen_lt int_lt bool_lt intlike_lt + float_lt string_lt int32_lt int64_lt nativeint_lt gen_gt int_gt + bool_gt intlike_gt float_gt string_gt int32_gt int64_gt + nativeint_gt gen_le int_le bool_le intlike_le float_le string_le + int32_le int64_le nativeint_le gen_ge int_ge bool_ge intlike_ge + float_ge string_ge int32_ge int64_ge nativeint_ge eta_gen_cmp + eta_int_cmp eta_bool_cmp eta_intlike_cmp eta_float_cmp + eta_string_cmp eta_int32_cmp eta_int64_cmp eta_nativeint_cmp + eta_gen_eq eta_int_eq eta_bool_eq eta_intlike_eq eta_float_eq + eta_string_eq eta_int32_eq eta_int64_eq eta_nativeint_eq + eta_gen_ne eta_int_ne eta_bool_ne eta_intlike_ne eta_float_ne + eta_string_ne eta_int32_ne eta_int64_ne eta_nativeint_ne + eta_gen_lt eta_int_lt eta_bool_lt eta_intlike_lt eta_float_lt + eta_string_lt eta_int32_lt eta_int64_lt eta_nativeint_lt + eta_gen_gt eta_int_gt eta_bool_gt eta_intlike_gt eta_float_gt + eta_string_gt eta_int32_gt eta_int64_gt eta_nativeint_gt + eta_gen_le eta_int_le eta_bool_le eta_intlike_le eta_float_le + eta_string_le eta_int32_le eta_int64_le eta_nativeint_le + eta_gen_ge eta_int_ge eta_bool_ge eta_intlike_ge eta_float_ge + eta_string_ge eta_int32_ge eta_int64_ge eta_nativeint_ge int_vec + bool_vec intlike_vec float_vec string_vec int32_vec int64_vec + nativeint_vec test_vec eta_test_vec)))))) diff --git a/testsuite/tests/translprim/comparison_table.ml b/testsuite/tests/translprim/comparison_table.ml index 129ea5c55f..1a91430681 100644 --- a/testsuite/tests/translprim/comparison_table.ml +++ b/testsuite/tests/translprim/comparison_table.ml @@ -1,3 +1,10 @@ +(* TEST + * setup-ocamlc.byte-build-env + ** ocamlc.byte + flags = "-dlambda -dno-unique-ids" + *** check-ocamlc.byte-output +*) + external cmp : 'a -> 'a -> int = "%compare";; external eq : 'a -> 'a -> bool = "%equal";; external ne : 'a -> 'a -> bool = "%notequal";; diff --git a/testsuite/tests/translprim/comparison_table.ml.reference b/testsuite/tests/translprim/comparison_table.ml.reference deleted file mode 100644 index ac505e1578..0000000000 --- a/testsuite/tests/translprim/comparison_table.ml.reference +++ /dev/null @@ -1,377 +0,0 @@ -(setglobal Comparison_table! - (let - (gen_cmp = (function x y (caml_compare x y)) - int_cmp = (function x y (caml_int_compare x y)) - bool_cmp = - (function x y (caml_int_compare x y)) - intlike_cmp = - (function x y (caml_int_compare x y)) - float_cmp = - (function x y (caml_float_compare x y)) - string_cmp = - (function x y (caml_string_compare x y)) - int32_cmp = - (function x y (caml_int32_compare x y)) - int64_cmp = - (function x y (caml_int64_compare x y)) - nativeint_cmp = - (function x y (caml_nativeint_compare x y)) - gen_eq = (function x y (caml_equal x y)) - int_eq = (function x y (== x y)) - bool_eq = (function x y (== x y)) - intlike_eq = (function x y (== x y)) - float_eq = (function x y (==. x y)) - string_eq = - (function x y (caml_string_equal x y)) - int32_eq = (function x y (Int32.== x y)) - int64_eq = (function x y (Int64.== x y)) - nativeint_eq = - (function x y (Nativeint.== x y)) - gen_ne = (function x y (caml_notequal x y)) - int_ne = (function x y (!= x y)) - bool_ne = (function x y (!= x y)) - intlike_ne = (function x y (!= x y)) - float_ne = (function x y (!=. x y)) - string_ne = - (function x y (caml_string_notequal x y)) - int32_ne = (function x y (Int32.!= x y)) - int64_ne = (function x y (Int64.!= x y)) - nativeint_ne = - (function x y (Nativeint.!= x y)) - gen_lt = (function x y (caml_lessthan x y)) - int_lt = (function x y (< x y)) - bool_lt = (function x y (< x y)) - intlike_lt = (function x y (< x y)) - float_lt = (function x y (<. x y)) - string_lt = - (function x y (caml_string_lessthan x y)) - int32_lt = (function x y (Int32.< x y)) - int64_lt = (function x y (Int64.< x y)) - nativeint_lt = (function x y (Nativeint.< x y)) - gen_gt = (function x y (caml_greaterthan x y)) - int_gt = (function x y (> x y)) - bool_gt = (function x y (> x y)) - intlike_gt = (function x y (> x y)) - float_gt = (function x y (>. x y)) - string_gt = - (function x y (caml_string_greaterthan x y)) - int32_gt = (function x y (Int32.> x y)) - int64_gt = (function x y (Int64.> x y)) - nativeint_gt = (function x y (Nativeint.> x y)) - gen_le = (function x y (caml_lessequal x y)) - int_le = (function x y (<= x y)) - bool_le = (function x y (<= x y)) - intlike_le = (function x y (<= x y)) - float_le = (function x y (<=. x y)) - string_le = - (function x y (caml_string_lessequal x y)) - int32_le = (function x y (Int32.<= x y)) - int64_le = (function x y (Int64.<= x y)) - nativeint_le = - (function x y (Nativeint.<= x y)) - gen_ge = (function x y (caml_greaterequal x y)) - int_ge = (function x y (>= x y)) - bool_ge = (function x y (>= x y)) - intlike_ge = (function x y (>= x y)) - float_ge = (function x y (>=. x y)) - string_ge = - (function x y (caml_string_greaterequal x y)) - int32_ge = (function x y (Int32.>= x y)) - int64_ge = (function x y (Int64.>= x y)) - nativeint_ge = - (function x y (Nativeint.>= x y)) - eta_gen_cmp = - (function prim prim stub (caml_compare prim prim)) - eta_int_cmp = - (function prim prim stub - (caml_int_compare prim prim)) - eta_bool_cmp = - (function prim prim stub - (caml_int_compare prim prim)) - eta_intlike_cmp = - (function prim prim stub - (caml_int_compare prim prim)) - eta_float_cmp = - (function prim prim stub - (caml_float_compare prim prim)) - eta_string_cmp = - (function prim prim stub - (caml_string_compare prim prim)) - eta_int32_cmp = - (function prim prim stub - (caml_int32_compare prim prim)) - eta_int64_cmp = - (function prim prim stub - (caml_int64_compare prim prim)) - eta_nativeint_cmp = - (function prim prim stub - (caml_nativeint_compare prim prim)) - eta_gen_eq = - (function prim prim stub (caml_equal prim prim)) - eta_int_eq = - (function prim prim stub (== prim prim)) - eta_bool_eq = - (function prim prim stub (== prim prim)) - eta_intlike_eq = - (function prim prim stub (== prim prim)) - eta_float_eq = - (function prim prim stub (==. prim prim)) - eta_string_eq = - (function prim prim stub - (caml_string_equal prim prim)) - eta_int32_eq = - (function prim prim stub (Int32.== prim prim)) - eta_int64_eq = - (function prim prim stub (Int64.== prim prim)) - eta_nativeint_eq = - (function prim prim stub (Nativeint.== prim prim)) - eta_gen_ne = - (function prim prim stub - (caml_notequal prim prim)) - eta_int_ne = - (function prim prim stub (!= prim prim)) - eta_bool_ne = - (function prim prim stub (!= prim prim)) - eta_intlike_ne = - (function prim prim stub (!= prim prim)) - eta_float_ne = - (function prim prim stub (!=. prim prim)) - eta_string_ne = - (function prim prim stub - (caml_string_notequal prim prim)) - eta_int32_ne = - (function prim prim stub (Int32.!= prim prim)) - eta_int64_ne = - (function prim prim stub (Int64.!= prim prim)) - eta_nativeint_ne = - (function prim prim stub (Nativeint.!= prim prim)) - eta_gen_lt = - (function prim prim stub - (caml_lessthan prim prim)) - eta_int_lt = - (function prim prim stub (< prim prim)) - eta_bool_lt = - (function prim prim stub (< prim prim)) - eta_intlike_lt = - (function prim prim stub (< prim prim)) - eta_float_lt = - (function prim prim stub (<. prim prim)) - eta_string_lt = - (function prim prim stub - (caml_string_lessthan prim prim)) - eta_int32_lt = - (function prim prim stub (Int32.< prim prim)) - eta_int64_lt = - (function prim prim stub (Int64.< prim prim)) - eta_nativeint_lt = - (function prim prim stub (Nativeint.< prim prim)) - eta_gen_gt = - (function prim prim stub - (caml_greaterthan prim prim)) - eta_int_gt = - (function prim prim stub (> prim prim)) - eta_bool_gt = - (function prim prim stub (> prim prim)) - eta_intlike_gt = - (function prim prim stub (> prim prim)) - eta_float_gt = - (function prim prim stub (>. prim prim)) - eta_string_gt = - (function prim prim stub - (caml_string_greaterthan prim prim)) - eta_int32_gt = - (function prim prim stub (Int32.> prim prim)) - eta_int64_gt = - (function prim prim stub (Int64.> prim prim)) - eta_nativeint_gt = - (function prim prim stub (Nativeint.> prim prim)) - eta_gen_le = - (function prim prim stub - (caml_lessequal prim prim)) - eta_int_le = - (function prim prim stub (<= prim prim)) - eta_bool_le = - (function prim prim stub (<= prim prim)) - eta_intlike_le = - (function prim prim stub (<= prim prim)) - eta_float_le = - (function prim prim stub (<=. prim prim)) - eta_string_le = - (function prim prim stub - (caml_string_lessequal prim prim)) - eta_int32_le = - (function prim prim stub (Int32.<= prim prim)) - eta_int64_le = - (function prim prim stub (Int64.<= prim prim)) - eta_nativeint_le = - (function prim prim stub (Nativeint.<= prim prim)) - eta_gen_ge = - (function prim prim stub - (caml_greaterequal prim prim)) - eta_int_ge = - (function prim prim stub (>= prim prim)) - eta_bool_ge = - (function prim prim stub (>= prim prim)) - eta_intlike_ge = - (function prim prim stub (>= prim prim)) - eta_float_ge = - (function prim prim stub (>=. prim prim)) - eta_string_ge = - (function prim prim stub - (caml_string_greaterequal prim prim)) - eta_int32_ge = - (function prim prim stub (Int32.>= prim prim)) - eta_int64_ge = - (function prim prim stub (Int64.>= prim prim)) - eta_nativeint_ge = - (function prim prim stub (Nativeint.>= prim prim)) - int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]] - bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] - intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] - float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]] - string_vec = - [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]] - int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]] - int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]] - nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]] - test_vec = - (function cmp eq ne lt gt le ge - vec - (let - (uncurry = - (function f param - (apply f (field_imm 0 param) - (field_imm 1 param))) - map = - (function f l - (apply (field 16 (global Stdlib__list!)) - (apply uncurry f) l))) - (makeblock 0 - (makeblock 0 (apply map gen_cmp vec) - (apply map cmp vec)) - (apply map - (function gen spec - (makeblock 0 (apply map gen vec) - (apply map spec vec))) - (makeblock 0 (makeblock 0 gen_eq eq) - (makeblock 0 (makeblock 0 gen_ne ne) - (makeblock 0 (makeblock 0 gen_lt lt) - (makeblock 0 (makeblock 0 gen_gt gt) - (makeblock 0 (makeblock 0 gen_le le) - (makeblock 0 (makeblock 0 gen_ge ge) 0a))))))))))) - (seq - (apply test_vec int_cmp int_eq int_ne int_lt - int_gt int_le int_ge int_vec) - (apply test_vec bool_cmp bool_eq bool_ne - bool_lt bool_gt bool_le bool_ge bool_vec) - (apply test_vec intlike_cmp intlike_eq intlike_ne - intlike_lt intlike_gt intlike_le intlike_ge - intlike_vec) - (apply test_vec float_cmp float_eq float_ne - float_lt float_gt float_le float_ge - float_vec) - (apply test_vec string_cmp string_eq string_ne - string_lt string_gt string_le string_ge - string_vec) - (apply test_vec int32_cmp int32_eq int32_ne - int32_lt int32_gt int32_le int32_ge - int32_vec) - (apply test_vec int64_cmp int64_eq int64_ne - int64_lt int64_gt int64_le int64_ge - int64_vec) - (apply test_vec nativeint_cmp nativeint_eq - nativeint_ne nativeint_lt nativeint_gt - nativeint_le nativeint_ge nativeint_vec) - (let - (eta_test_vec = - (function cmp eq ne lt gt le ge - vec - (let - (uncurry = - (function f param - (apply f (field_imm 0 param) - (field_imm 1 param))) - map = - (function f l - (apply (field 16 (global Stdlib__list!)) - (apply uncurry f) l))) - (makeblock 0 - (makeblock 0 (apply map eta_gen_cmp vec) - (apply map cmp vec)) - (apply map - (function gen spec - (makeblock 0 (apply map gen vec) - (apply map spec vec))) - (makeblock 0 (makeblock 0 eta_gen_eq eq) - (makeblock 0 (makeblock 0 eta_gen_ne ne) - (makeblock 0 (makeblock 0 eta_gen_lt lt) - (makeblock 0 (makeblock 0 eta_gen_gt gt) - (makeblock 0 (makeblock 0 eta_gen_le le) - (makeblock 0 - (makeblock 0 eta_gen_ge ge) 0a))))))))))) - (seq - (apply eta_test_vec eta_int_cmp eta_int_eq - eta_int_ne eta_int_lt eta_int_gt eta_int_le - eta_int_ge int_vec) - (apply eta_test_vec eta_bool_cmp eta_bool_eq - eta_bool_ne eta_bool_lt eta_bool_gt - eta_bool_le eta_bool_ge bool_vec) - (apply eta_test_vec eta_intlike_cmp eta_intlike_eq - eta_intlike_ne eta_intlike_lt eta_intlike_gt - eta_intlike_le eta_intlike_ge intlike_vec) - (apply eta_test_vec eta_float_cmp eta_float_eq - eta_float_ne eta_float_lt eta_float_gt - eta_float_le eta_float_ge float_vec) - (apply eta_test_vec eta_string_cmp eta_string_eq - eta_string_ne eta_string_lt eta_string_gt - eta_string_le eta_string_ge string_vec) - (apply eta_test_vec eta_int32_cmp eta_int32_eq - eta_int32_ne eta_int32_lt eta_int32_gt - eta_int32_le eta_int32_ge int32_vec) - (apply eta_test_vec eta_int64_cmp eta_int64_eq - eta_int64_ne eta_int64_lt eta_int64_gt - eta_int64_le eta_int64_ge int64_vec) - (apply eta_test_vec eta_nativeint_cmp - eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt - eta_nativeint_gt eta_nativeint_le eta_nativeint_ge - nativeint_vec) - (makeblock 0 gen_cmp int_cmp bool_cmp - intlike_cmp float_cmp string_cmp int32_cmp - int64_cmp nativeint_cmp gen_eq int_eq - bool_eq intlike_eq float_eq string_eq - int32_eq int64_eq nativeint_eq gen_ne - int_ne bool_ne intlike_ne float_ne - string_ne int32_ne int64_ne nativeint_ne - gen_lt int_lt bool_lt intlike_lt - float_lt string_lt int32_lt int64_lt - nativeint_lt gen_gt int_gt bool_gt - intlike_gt float_gt string_gt int32_gt - int64_gt nativeint_gt gen_le int_le - bool_le intlike_le float_le string_le - int32_le int64_le nativeint_le gen_ge - int_ge bool_ge intlike_ge float_ge - string_ge int32_ge int64_ge nativeint_ge - eta_gen_cmp eta_int_cmp eta_bool_cmp - eta_intlike_cmp eta_float_cmp eta_string_cmp - eta_int32_cmp eta_int64_cmp eta_nativeint_cmp - eta_gen_eq eta_int_eq eta_bool_eq - eta_intlike_eq eta_float_eq eta_string_eq - eta_int32_eq eta_int64_eq eta_nativeint_eq - eta_gen_ne eta_int_ne eta_bool_ne - eta_intlike_ne eta_float_ne eta_string_ne - eta_int32_ne eta_int64_ne eta_nativeint_ne - eta_gen_lt eta_int_lt eta_bool_lt - eta_intlike_lt eta_float_lt eta_string_lt - eta_int32_lt eta_int64_lt eta_nativeint_lt - eta_gen_gt eta_int_gt eta_bool_gt - eta_intlike_gt eta_float_gt eta_string_gt - eta_int32_gt eta_int64_gt eta_nativeint_gt - eta_gen_le eta_int_le eta_bool_le - eta_intlike_le eta_float_le eta_string_le - eta_int32_le eta_int64_le eta_nativeint_le - eta_gen_ge eta_int_ge eta_bool_ge - eta_intlike_ge eta_float_ge eta_string_ge - eta_int32_ge eta_int64_ge eta_nativeint_ge - int_vec bool_vec intlike_vec float_vec - string_vec int32_vec int64_vec nativeint_vec - test_vec eta_test_vec)))))) diff --git a/testsuite/tests/translprim/module_coercion.compilers.reference.flat b/testsuite/tests/translprim/module_coercion.compilers.reference.flat new file mode 100644 index 0000000000..b70909ee83 --- /dev/null +++ b/testsuite/tests/translprim/module_coercion.compilers.reference.flat @@ -0,0 +1,87 @@ +(setglobal Module_coercion! + (let (M = (module-defn(M) module_coercion.ml(13):417-1116 (makeblock 0))) + (makeblock 0 M + (module-defn(M_int) module_coercion.ml(44):1533-1572 + (makeblock 0 (function prim stub (array.length[int] prim)) + (function prim prim stub (array.get[int] prim prim)) + (function prim prim stub (array.unsafe_get[int] prim prim)) + (function prim prim prim stub (array.set[int] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[int] prim prim prim)) + (function prim prim stub (caml_int_compare prim prim)) + (function prim prim stub (== prim prim)) + (function prim prim stub (!= prim prim)) + (function prim prim stub (< prim prim)) + (function prim prim stub (> prim prim)) + (function prim prim stub (<= prim prim)) + (function prim prim stub (>= prim prim)))) + (module-defn(M_float) module_coercion.ml(45):1575-1618 + (makeblock 0 (function prim stub (array.length[float] prim)) + (function prim prim stub (array.get[float] prim prim)) + (function prim prim stub (array.unsafe_get[float] prim prim)) + (function prim prim prim stub (array.set[float] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[float] prim prim prim)) + (function prim prim stub (caml_float_compare prim prim)) + (function prim prim stub (==. prim prim)) + (function prim prim stub (!=. prim prim)) + (function prim prim stub (<. prim prim)) + (function prim prim stub (>. prim prim)) + (function prim prim stub (<=. prim prim)) + (function prim prim stub (>=. prim prim)))) + (module-defn(M_string) module_coercion.ml(46):1621-1666 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_string_compare prim prim)) + (function prim prim stub (caml_string_equal prim prim)) + (function prim prim stub (caml_string_notequal prim prim)) + (function prim prim stub (caml_string_lessthan prim prim)) + (function prim prim stub (caml_string_greaterthan prim prim)) + (function prim prim stub (caml_string_lessequal prim prim)) + (function prim prim stub (caml_string_greaterequal prim prim)))) + (module-defn(M_int32) module_coercion.ml(47):1669-1712 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_int32_compare prim prim)) + (function prim prim stub (Int32.== prim prim)) + (function prim prim stub (Int32.!= prim prim)) + (function prim prim stub (Int32.< prim prim)) + (function prim prim stub (Int32.> prim prim)) + (function prim prim stub (Int32.<= prim prim)) + (function prim prim stub (Int32.>= prim prim)))) + (module-defn(M_int64) module_coercion.ml(48):1715-1758 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_int64_compare prim prim)) + (function prim prim stub (Int64.== prim prim)) + (function prim prim stub (Int64.!= prim prim)) + (function prim prim stub (Int64.< prim prim)) + (function prim prim stub (Int64.> prim prim)) + (function prim prim stub (Int64.<= prim prim)) + (function prim prim stub (Int64.>= prim prim)))) + (module-defn(M_nativeint) module_coercion.ml(49):1761-1812 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_nativeint_compare prim prim)) + (function prim prim stub (Nativeint.== prim prim)) + (function prim prim stub (Nativeint.!= prim prim)) + (function prim prim stub (Nativeint.< prim prim)) + (function prim prim stub (Nativeint.> prim prim)) + (function prim prim stub (Nativeint.<= prim prim)) + (function prim prim stub (Nativeint.>= prim prim))))))) diff --git a/testsuite/tests/translprim/module_coercion.compilers.reference.no-flat b/testsuite/tests/translprim/module_coercion.compilers.reference.no-flat new file mode 100644 index 0000000000..3a9503ee63 --- /dev/null +++ b/testsuite/tests/translprim/module_coercion.compilers.reference.no-flat @@ -0,0 +1,87 @@ +(setglobal Module_coercion! + (let (M = (module-defn(M) module_coercion.ml(13):417-1116 (makeblock 0))) + (makeblock 0 M + (module-defn(M_int) module_coercion.ml(44):1533-1572 + (makeblock 0 (function prim stub (array.length[int] prim)) + (function prim prim stub (array.get[int] prim prim)) + (function prim prim stub (array.unsafe_get[int] prim prim)) + (function prim prim prim stub (array.set[int] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[int] prim prim prim)) + (function prim prim stub (caml_int_compare prim prim)) + (function prim prim stub (== prim prim)) + (function prim prim stub (!= prim prim)) + (function prim prim stub (< prim prim)) + (function prim prim stub (> prim prim)) + (function prim prim stub (<= prim prim)) + (function prim prim stub (>= prim prim)))) + (module-defn(M_float) module_coercion.ml(45):1575-1618 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_float_compare prim prim)) + (function prim prim stub (==. prim prim)) + (function prim prim stub (!=. prim prim)) + (function prim prim stub (<. prim prim)) + (function prim prim stub (>. prim prim)) + (function prim prim stub (<=. prim prim)) + (function prim prim stub (>=. prim prim)))) + (module-defn(M_string) module_coercion.ml(46):1621-1666 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_string_compare prim prim)) + (function prim prim stub (caml_string_equal prim prim)) + (function prim prim stub (caml_string_notequal prim prim)) + (function prim prim stub (caml_string_lessthan prim prim)) + (function prim prim stub (caml_string_greaterthan prim prim)) + (function prim prim stub (caml_string_lessequal prim prim)) + (function prim prim stub (caml_string_greaterequal prim prim)))) + (module-defn(M_int32) module_coercion.ml(47):1669-1712 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_int32_compare prim prim)) + (function prim prim stub (Int32.== prim prim)) + (function prim prim stub (Int32.!= prim prim)) + (function prim prim stub (Int32.< prim prim)) + (function prim prim stub (Int32.> prim prim)) + (function prim prim stub (Int32.<= prim prim)) + (function prim prim stub (Int32.>= prim prim)))) + (module-defn(M_int64) module_coercion.ml(48):1715-1758 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_int64_compare prim prim)) + (function prim prim stub (Int64.== prim prim)) + (function prim prim stub (Int64.!= prim prim)) + (function prim prim stub (Int64.< prim prim)) + (function prim prim stub (Int64.> prim prim)) + (function prim prim stub (Int64.<= prim prim)) + (function prim prim stub (Int64.>= prim prim)))) + (module-defn(M_nativeint) module_coercion.ml(49):1761-1812 + (makeblock 0 (function prim stub (array.length[addr] prim)) + (function prim prim stub (array.get[addr] prim prim)) + (function prim prim stub (array.unsafe_get[addr] prim prim)) + (function prim prim prim stub (array.set[addr] prim prim prim)) + (function prim prim prim stub + (array.unsafe_set[addr] prim prim prim)) + (function prim prim stub (caml_nativeint_compare prim prim)) + (function prim prim stub (Nativeint.== prim prim)) + (function prim prim stub (Nativeint.!= prim prim)) + (function prim prim stub (Nativeint.< prim prim)) + (function prim prim stub (Nativeint.> prim prim)) + (function prim prim stub (Nativeint.<= prim prim)) + (function prim prim stub (Nativeint.>= prim prim))))))) diff --git a/testsuite/tests/translprim/module_coercion.ml b/testsuite/tests/translprim/module_coercion.ml index 041b30341f..86f2ae95bb 100644 --- a/testsuite/tests/translprim/module_coercion.ml +++ b/testsuite/tests/translprim/module_coercion.ml @@ -1,3 +1,15 @@ +(* TEST + * setup-ocamlc.byte-build-env + ** ocamlc.byte + flags = "-dlambda -dno-unique-ids" + *** flat-float-array + **** check-ocamlc.byte-output + compiler_reference = "${test_source_directory}/module_coercion.compilers.reference.flat" + *** no-flat-float-array + **** check-ocamlc.byte-output + compiler_reference = "${test_source_directory}/module_coercion.compilers.reference.no-flat" +*) + module M = struct external len : 'a array -> int = "%array_length" external safe_get : 'a array -> int -> 'a = "%array_safe_get" diff --git a/testsuite/tests/translprim/module_coercion.ml.reference-flat b/testsuite/tests/translprim/module_coercion.ml.reference-flat deleted file mode 100644 index 27cd3f7329..0000000000 --- a/testsuite/tests/translprim/module_coercion.ml.reference-flat +++ /dev/null @@ -1,125 +0,0 @@ -(setglobal Module_coercion! - (let - (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0))) - (makeblock 0 M - (module-defn(M_int) module_coercion.ml(32):1116-1155 - (makeblock 0 (function prim stub (array.length[int] prim)) - (function prim prim stub - (array.get[int] prim prim)) - (function prim prim stub - (array.unsafe_get[int] prim prim)) - (function prim prim prim stub - (array.set[int] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[int] prim prim prim)) - (function prim prim stub - (caml_int_compare prim prim)) - (function prim prim stub (== prim prim)) - (function prim prim stub (!= prim prim)) - (function prim prim stub (< prim prim)) - (function prim prim stub (> prim prim)) - (function prim prim stub (<= prim prim)) - (function prim prim stub (>= prim prim)))) - (module-defn(M_float) module_coercion.ml(33):1158-1201 - (makeblock 0 - (function prim stub (array.length[float] prim)) - (function prim prim stub - (array.get[float] prim prim)) - (function prim prim stub - (array.unsafe_get[float] prim prim)) - (function prim prim prim stub - (array.set[float] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[float] prim prim prim)) - (function prim prim stub - (caml_float_compare prim prim)) - (function prim prim stub (==. prim prim)) - (function prim prim stub (!=. prim prim)) - (function prim prim stub (<. prim prim)) - (function prim prim stub (>. prim prim)) - (function prim prim stub (<=. prim prim)) - (function prim prim stub (>=. prim prim)))) - (module-defn(M_string) module_coercion.ml(34):1204-1249 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_string_compare prim prim)) - (function prim prim stub - (caml_string_equal prim prim)) - (function prim prim stub - (caml_string_notequal prim prim)) - (function prim prim stub - (caml_string_lessthan prim prim)) - (function prim prim stub - (caml_string_greaterthan prim prim)) - (function prim prim stub - (caml_string_lessequal prim prim)) - (function prim prim stub - (caml_string_greaterequal prim prim)))) - (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_int32_compare prim prim)) - (function prim prim stub (Int32.== prim prim)) - (function prim prim stub (Int32.!= prim prim)) - (function prim prim stub (Int32.< prim prim)) - (function prim prim stub (Int32.> prim prim)) - (function prim prim stub (Int32.<= prim prim)) - (function prim prim stub (Int32.>= prim prim)))) - (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_int64_compare prim prim)) - (function prim prim stub (Int64.== prim prim)) - (function prim prim stub (Int64.!= prim prim)) - (function prim prim stub (Int64.< prim prim)) - (function prim prim stub (Int64.> prim prim)) - (function prim prim stub (Int64.<= prim prim)) - (function prim prim stub (Int64.>= prim prim)))) - (module-defn(M_nativeint) module_coercion.ml(37):1344-1395 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_nativeint_compare prim prim)) - (function prim prim stub - (Nativeint.== prim prim)) - (function prim prim stub - (Nativeint.!= prim prim)) - (function prim prim stub - (Nativeint.< prim prim)) - (function prim prim stub - (Nativeint.> prim prim)) - (function prim prim stub - (Nativeint.<= prim prim)) - (function prim prim stub - (Nativeint.>= prim prim))))))) diff --git a/testsuite/tests/translprim/module_coercion.ml.reference-noflat b/testsuite/tests/translprim/module_coercion.ml.reference-noflat deleted file mode 100644 index b3cc51bc0d..0000000000 --- a/testsuite/tests/translprim/module_coercion.ml.reference-noflat +++ /dev/null @@ -1,124 +0,0 @@ -(setglobal Module_coercion! - (let - (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0))) - (makeblock 0 M - (module-defn(M_int) module_coercion.ml(32):1116-1155 - (makeblock 0 (function prim stub (array.length[int] prim)) - (function prim prim stub - (array.get[int] prim prim)) - (function prim prim stub - (array.unsafe_get[int] prim prim)) - (function prim prim prim stub - (array.set[int] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[int] prim prim prim)) - (function prim prim stub - (caml_int_compare prim prim)) - (function prim prim stub (== prim prim)) - (function prim prim stub (!= prim prim)) - (function prim prim stub (< prim prim)) - (function prim prim stub (> prim prim)) - (function prim prim stub (<= prim prim)) - (function prim prim stub (>= prim prim)))) - (module-defn(M_float) module_coercion.ml(33):1158-1201 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_float_compare prim prim)) - (function prim prim stub (==. prim prim)) - (function prim prim stub (!=. prim prim)) - (function prim prim stub (<. prim prim)) - (function prim prim stub (>. prim prim)) - (function prim prim stub (<=. prim prim)) - (function prim prim stub (>=. prim prim)))) - (module-defn(M_string) module_coercion.ml(34):1204-1249 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_string_compare prim prim)) - (function prim prim stub - (caml_string_equal prim prim)) - (function prim prim stub - (caml_string_notequal prim prim)) - (function prim prim stub - (caml_string_lessthan prim prim)) - (function prim prim stub - (caml_string_greaterthan prim prim)) - (function prim prim stub - (caml_string_lessequal prim prim)) - (function prim prim stub - (caml_string_greaterequal prim prim)))) - (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_int32_compare prim prim)) - (function prim prim stub (Int32.== prim prim)) - (function prim prim stub (Int32.!= prim prim)) - (function prim prim stub (Int32.< prim prim)) - (function prim prim stub (Int32.> prim prim)) - (function prim prim stub (Int32.<= prim prim)) - (function prim prim stub (Int32.>= prim prim)))) - (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_int64_compare prim prim)) - (function prim prim stub (Int64.== prim prim)) - (function prim prim stub (Int64.!= prim prim)) - (function prim prim stub (Int64.< prim prim)) - (function prim prim stub (Int64.> prim prim)) - (function prim prim stub (Int64.<= prim prim)) - (function prim prim stub (Int64.>= prim prim)))) - (module-defn(M_nativeint) module_coercion.ml(37):1344-1395 - (makeblock 0 (function prim stub (array.length[addr] prim)) - (function prim prim stub - (array.get[addr] prim prim)) - (function prim prim stub - (array.unsafe_get[addr] prim prim)) - (function prim prim prim stub - (array.set[addr] prim prim prim)) - (function prim prim prim stub - (array.unsafe_set[addr] prim prim prim)) - (function prim prim stub - (caml_nativeint_compare prim prim)) - (function prim prim stub - (Nativeint.== prim prim)) - (function prim prim stub - (Nativeint.!= prim prim)) - (function prim prim stub - (Nativeint.< prim prim)) - (function prim prim stub - (Nativeint.> prim prim)) - (function prim prim stub - (Nativeint.<= prim prim)) - (function prim prim stub - (Nativeint.>= prim prim))))))) diff --git a/testsuite/tests/translprim/ocamltests b/testsuite/tests/translprim/ocamltests new file mode 100644 index 0000000000..790d6dac84 --- /dev/null +++ b/testsuite/tests/translprim/ocamltests @@ -0,0 +1,4 @@ +array_spec.ml +comparison_table.ml +module_coercion.ml +ref_spec.ml diff --git a/testsuite/tests/translprim/ref_spec.compilers.reference b/testsuite/tests/translprim/ref_spec.compilers.reference new file mode 100644 index 0000000000..72b48d4f0b --- /dev/null +++ b/testsuite/tests/translprim/ref_spec.compilers.reference @@ -0,0 +1,37 @@ +(setglobal Ref_spec! + (let + (int_ref = (makemutable 0 (int) 1) + var_ref = (makemutable 0 65a) + vargen_ref = (makemutable 0 65a) + cst_ref = (makemutable 0 0a) + gen_ref = (makemutable 0 0a) + flt_ref = (makemutable 0 (float) 0.)) + (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a) + (setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67a) + (setfield_imm 0 cst_ref 1a) (setfield_ptr 0 gen_ref [0: "foo"]) + (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.) + (let + (int_rec = (makemutable 0 (*,int) 0a 1) + var_rec = (makemutable 0 0a 65a) + vargen_rec = (makemutable 0 0a 65a) + cst_rec = (makemutable 0 0a 0a) + gen_rec = (makemutable 0 0a 0a) + flt_rec = (makemutable 0 (*,float) 0a 0.) + flt_rec' = (makearray[float] 0. 0.)) + (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66a) + (setfield_ptr 1 vargen_rec [0: 66 0]) + (setfield_ptr 1 vargen_rec 67a) (setfield_imm 1 cst_rec 1a) + (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0a) + (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.) + (let + (set_open_poly = (function r y (setfield_ptr 0 r y)) + set_open_poly = (function r y (setfield_imm 0 r y)) + set_open_poly = (function r y (setfield_imm 0 r y)) + set_open_poly = (function r y (setfield_imm 0 r y)) + set_open_poly = (function r y (setfield_ptr 0 r y)) + set_open_poly = (function r y (setfield_ptr 0 r y)) + set_open_poly = (function r y (setfield_ptr 0 r y)) + set_open_poly = (function r y (setfield_ptr 0 r y))) + (makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref + int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec' + set_open_poly))))))) diff --git a/testsuite/tests/translprim/ref_spec.ml b/testsuite/tests/translprim/ref_spec.ml index 068fa884f2..82cbd1eeef 100644 --- a/testsuite/tests/translprim/ref_spec.ml +++ b/testsuite/tests/translprim/ref_spec.ml @@ -1,3 +1,10 @@ +(* TEST + * setup-ocamlc.byte-build-env + ** ocamlc.byte + flags = "-dlambda -dno-unique-ids" + *** check-ocamlc.byte-output +*) + type 'a custom_rec = { x : unit; mutable y : 'a } type float_rec = { w : float; mutable z : float } diff --git a/testsuite/tests/translprim/ref_spec.ml.reference b/testsuite/tests/translprim/ref_spec.ml.reference deleted file mode 100644 index c21b100b90..0000000000 --- a/testsuite/tests/translprim/ref_spec.ml.reference +++ /dev/null @@ -1,50 +0,0 @@ -(setglobal Ref_spec! - (let - (int_ref = (makemutable 0 (int) 1) - var_ref = (makemutable 0 65a) - vargen_ref = (makemutable 0 65a) - cst_ref = (makemutable 0 0a) - gen_ref = (makemutable 0 0a) - flt_ref = (makemutable 0 (float) 0.)) - (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a) - (setfield_ptr 0 vargen_ref [0: 66 0]) - (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a) - (setfield_ptr 0 gen_ref [0: "foo"]) - (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.) - (let - (int_rec = (makemutable 0 (*,int) 0a 1) - var_rec = (makemutable 0 0a 65a) - vargen_rec = (makemutable 0 0a 65a) - cst_rec = (makemutable 0 0a 0a) - gen_rec = (makemutable 0 0a 0a) - flt_rec = (makemutable 0 (*,float) 0a 0.) - flt_rec' = (makearray[float] 0. 0.)) - (seq (setfield_imm 1 int_rec 2) - (setfield_imm 1 var_rec 66a) - (setfield_ptr 1 vargen_rec [0: 66 0]) - (setfield_ptr 1 vargen_rec 67a) - (setfield_imm 1 cst_rec 1a) - (setfield_ptr 1 gen_rec [0: "foo"]) - (setfield_ptr 1 gen_rec 0a) (setfield_ptr 1 flt_rec 1.) - (setfloatfield 1 flt_rec' 1.) - (let - (set_open_poly = - (function r y (setfield_ptr 0 r y)) - set_open_poly = - (function r y (setfield_imm 0 r y)) - set_open_poly = - (function r y (setfield_imm 0 r y)) - set_open_poly = - (function r y (setfield_imm 0 r y)) - set_open_poly = - (function r y (setfield_ptr 0 r y)) - set_open_poly = - (function r y (setfield_ptr 0 r y)) - set_open_poly = - (function r y (setfield_ptr 0 r y)) - set_open_poly = - (function r y (setfield_ptr 0 r y))) - (makeblock 0 int_ref var_ref vargen_ref - cst_ref gen_ref flt_ref int_rec - var_rec vargen_rec cst_rec gen_rec - flt_rec flt_rec' set_open_poly))))))) diff --git a/testsuite/tests/typing-gadts/ambiguity.ml b/testsuite/tests/typing-gadts/ambiguity.ml new file mode 100644 index 0000000000..20e923a014 --- /dev/null +++ b/testsuite/tests/typing-gadts/ambiguity.ml @@ -0,0 +1,198 @@ +(* TEST + * expect +*) + +[@@@warning "-8-11-12"] (* reduce the noise. *) + +type ('a, 'b) eq = Refl : ('a, 'a) eq;; +[%%expect{| +type ('a, 'b) eq = Refl : ('a, 'a) eq +|}];; + +let ret_e1 (type a b) (b : bool) (wit : (a, b) eq) (x : a) (y : b) = + match wit with + | Refl -> if b then x else y + | _ -> x +;; +[%%expect{| +Line _, characters 29-30: + | Refl -> if b then x else y + ^ +Error: This expression has type b = a but an expression was expected of type + a + This instance of a is ambiguous: + it would escape the scope of its equation +|}] + +let ret_e2 (type a b) (b : bool) (wit : (a, b) eq) (x : a) (y : b) = + match wit with + | Refl -> if b then x else y + | _ -> y +;; +[%%expect{| +Line _, characters 29-30: + | Refl -> if b then x else y + ^ +Error: This expression has type b = a but an expression was expected of type + a + This instance of a is ambiguous: + it would escape the scope of its equation +|}] + +let ret_ei1 (type a) (b : bool) (wit : (a, int) eq) (x : a) = + match wit with + | Refl -> if b then x else 0 + | _ -> x +;; +[%%expect{| +Line _, characters 29-30: + | Refl -> if b then x else 0 + ^ +Error: This expression has type int but an expression was expected of type + a = int + This instance of int is ambiguous: + it would escape the scope of its equation +|}] + +let ret_ei2 (type a) (b : bool) (wit : (a, int) eq) (x : a) = + match wit with + | Refl -> if b then x else 0 + | _ -> x +;; +[%%expect{| +Line _, characters 29-30: + | Refl -> if b then x else 0 + ^ +Error: This expression has type int but an expression was expected of type + a = int + This instance of int is ambiguous: + it would escape the scope of its equation +|}] + + +let ret_f (type a b) (wit : (a, b) eq) (x : a) (y : b) = + match wit with + | Refl -> [x; y] + | _ -> [x] +;; +[%%expect{| +Line _, characters 16-17: + | Refl -> [x; y] + ^ +Error: This expression has type b = a but an expression was expected of type + a + This instance of a is ambiguous: + it would escape the scope of its equation +|}] + +let ret_g1 (type a b) (wit : (a, b) eq) (x : a) (y : b) = + match wit with + | Refl -> [x; y] + | _ -> [y] +;; +[%%expect{| +Line _, characters 16-17: + | Refl -> [x; y] + ^ +Error: This expression has type b = a but an expression was expected of type + a + This instance of a is ambiguous: + it would escape the scope of its equation +|}] + +(* First reported in MPR#7617: the typechecker arbitrarily picks a + representative for an ambivalent type escaping its scope. + The commit that was implemented poses problems of its own: we are now + unifying the type of the patterns in the environment of each pattern, instead + of the outter one. The code discussed in PR#7617 passes because each branch + contains the same equation, but consider the following cases: *) + +let f (type a b) (x : (a, b) eq) = + match x, [] with + | Refl, [(_ : a) | (_ : b)] -> [] + | _, [(_ : a)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : a) | (_ : b)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] + +let g1 (type a b) (x : (a, b) eq) = + match x, [] with + | Refl, [(_ : a) | (_ : b)] -> [] + | _, [(_ : b)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : a) | (_ : b)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] + +let g2 (type a b) (x : (a, b) eq) = + match x, [] with + | Refl, [(_ : b) | (_ : a)] -> [] + | _, [(_ : a)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : b) | (_ : a)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] + +let h1 (type a b) (x : (a, b) eq) = + match x, [] with + | _, [(_ : a)] -> [] + | Refl, [(_ : a) | (_ : b)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : a) | (_ : b)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] + +let h2 (type a b) (x : (a, b) eq) = + match x, [] with + | _, [(_ : b)] -> [] + | Refl, [(_ : a) | (_ : b)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : a) | (_ : b)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] + +let h3 (type a b) (x : (a, b) eq) = + match x, [] with + | _, [(_ : a)] -> [] + | Refl, [(_ : b) | (_ : a)] -> [] +;; +[%%expect{| +Line _, characters 4-29: + | Refl, [(_ : b) | (_ : a)] -> [] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation +|}] diff --git a/testsuite/tests/typing-gadts/ocamltests b/testsuite/tests/typing-gadts/ocamltests index 214167dda9..ace6ac47cb 100644 --- a/testsuite/tests/typing-gadts/ocamltests +++ b/testsuite/tests/typing-gadts/ocamltests @@ -1,3 +1,4 @@ +ambiguity.ml didier.ml dynamic_frisch.ml nested_equations.ml @@ -38,7 +39,8 @@ pr7391.ml pr7397.ml pr7421.ml pr7432.ml -pr7518.ml +pr7618.ml +pr7747.ml term-conv.ml test.ml unify_mb.ml diff --git a/testsuite/tests/typing-gadts/pr5848.ml b/testsuite/tests/typing-gadts/pr5848.ml index c0332bb894..1c908d781d 100644 --- a/testsuite/tests/typing-gadts/pr5848.ml +++ b/testsuite/tests/typing-gadts/pr5848.ml @@ -19,8 +19,5 @@ let of_type: type a. a -> a = fun x -> [%%expect{| module B : sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end -Line _, characters 4-6: - | Eq -> 5 - ^^ -Error: The GADT constructor Eq of type B.t must be qualified in this pattern. +val of_type : 'a -> 'a = <fun> |}];; diff --git a/testsuite/tests/typing-gadts/pr7391.ml b/testsuite/tests/typing-gadts/pr7391.ml index 11bc04c7b4..f5ffc205f5 100644 --- a/testsuite/tests/typing-gadts/pr7391.ml +++ b/testsuite/tests/typing-gadts/pr7391.ml @@ -60,7 +60,7 @@ let _ = - : < child : unit -> child2; previous : child2 option > = <obj> |}] -(* Didn't work in 4.03 *) +(* Didn't work in 4.03, but works in 4.07 *) let _ = object(self) method previous = None @@ -73,10 +73,23 @@ let _ = in o end;; [%%expect{| -Line _, characters 16-22: - inherit child2 - ^^^^^^ -Error: The method parent has type < child : 'a; previous : 'b option > - but is expected to have type < previous : < .. > option; .. > - Self type cannot escape its class +- : < child : child2; previous : child2 option > = <obj> +|}] + +(* Also didn't work in 4.03 *) + +type gadt = Not_really_though : gadt + +let _ = + object(self) + method previous = None + method child Not_really_though = + object + inherit child1 self + inherit child2 + end + end;; +[%%expect{| +type gadt = Not_really_though : gadt +- : < child : gadt -> child2; previous : child2 option > = <obj> |}] diff --git a/testsuite/tests/typing-gadts/pr7518.ml b/testsuite/tests/typing-gadts/pr7618.ml index 7d536321b0..5227bd651b 100644 --- a/testsuite/tests/typing-gadts/pr7518.ml +++ b/testsuite/tests/typing-gadts/pr7618.ml @@ -19,17 +19,13 @@ let ok (type a b) (x : (a, b) eq) = ;; [%%expect{| type ('a, 'b) eq = Refl : ('a, 'a) eq -Line _, characters 2-54: - ..match x, [] with - | Refl, [(_ : a) | (_ : b)] -> [] -Warning 8: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -(Refl, _::_::_) -Line _, characters 22-23: +Line _, characters 4-29: | Refl, [(_ : a) | (_ : b)] -> [] - ^ -Warning 12: this sub-pattern is unused. -val ok : ('a, 'b) eq -> 'c list = <fun> + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation |}] let fails (type a b) (x : (a, b) eq) = match x, [] with @@ -37,22 +33,13 @@ let fails (type a b) (x : (a, b) eq) = | Refl, [(_ : b) | (_ : a)] -> [] ;; [%%expect{| -Line _, characters 2-90: - ..match x, [] with - | Refl, [(_ : a) | (_ : b)] -> [] - | Refl, [(_ : b) | (_ : a)] -> [] -Warning 8: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -(Refl, _::_::_) -Line _, characters 22-23: - | Refl, [(_ : a) | (_ : b)] -> [] - ^ -Warning 12: this sub-pattern is unused. Line _, characters 4-29: - | Refl, [(_ : b) | (_ : a)] -> [] + | Refl, [(_ : a) | (_ : b)] -> [] ^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 11: this match case is unused. -val fails : ('a, 'b) eq -> 'c list = <fun> +Error: This pattern matches values of type (a, b) eq * b list + but a pattern was expected which matches values of type 'a + This instance of b is ambiguous: + it would escape the scope of its equation |}] (* branches must be unified! *) diff --git a/testsuite/tests/typing-gadts/pr7747.ml b/testsuite/tests/typing-gadts/pr7747.ml new file mode 100644 index 0000000000..c3620e8ad0 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr7747.ml @@ -0,0 +1,35 @@ +(* TEST + * expect +*) + +type (_,_) eq = Refl : ('a,'a) eq + +module M = struct type t end +module N : sig type t = private M.t val eq : (t, M.t) eq end = + struct type t = M.t let eq = Refl end;; + +(* + as long as we are casting between M.t and N.t + there is no problem, this will type check. +*) + +let f x = match N.eq with Refl -> (x : N.t :> M.t);; +[%%expect{| +type (_, _) eq = Refl : ('a, 'a) eq +module M : sig type t end +module N : sig type t = private M.t val eq : (t, M.t) eq end +val f : N.t -> M.t = <fun> +|}] +let f x = match N.eq with Refl -> (x : M.t :> N.t);; +[%%expect{| +Line _, characters 34-50: + let f x = match N.eq with Refl -> (x : M.t :> N.t);; + ^^^^^^^^^^^^^^^^ +Error: Type M.t is not a subtype of N.t +|}] + +(* + but as soon we're trying to cast to another type, + the type checker will never return and memory + consumption will increase drastically. +*) diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index 4c5fb2e6ec..579dece8ce 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -1164,3 +1164,69 @@ let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b -> [%%expect{| val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun> |}];; + +let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b -> + let Eq = aint in + let x = + let Eq = ab in + if true then a else b + in ignore x +;; (* ok *) +[%%expect{| +Line _, characters 24-25: + if true then a else b + ^ +Error: This expression has type b = int + but an expression was expected of type a = int + Type b = int is not compatible with type int + This instance of int is ambiguous: + it would escape the scope of its equation +|}];; + +let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b -> + let Eq = bint in + let x = + let Eq = ab in + if true then a else b + in ignore x +;; (* ok *) +[%%expect{| +Line _, characters 24-25: + if true then a else b + ^ +Error: This expression has type b = int + but an expression was expected of type a = int + Type int is not compatible with type a = int + This instance of int is ambiguous: + it would escape the scope of its equation +|}];; + +let f (type a b c) (b : bool) (w1 : (a,b) eq) (w2 : (a,int) eq) (x : a) (y : b) = + let Eq = w1 in + let Eq = w2 in + if b then x else y +;; +[%%expect{| +Line _, characters 19-20: + if b then x else y + ^ +Error: This expression has type b = int + but an expression was expected of type a = int + Type a = int is not compatible with type a = int + This instance of int is ambiguous: + it would escape the scope of its equation +|}];; + +let f (type a b c) (b : bool) (w1 : (a,b) eq) (w2 : (a,int) eq) (x : a) (y : b) = + let Eq = w1 in + let Eq = w2 in + if b then y else x +[%%expect{| +Line _, characters 19-20: + if b then y else x + ^ +Error: This expression has type a = int + but an expression was expected of type b = int + This instance of int is ambiguous: + it would escape the scope of its equation +|}];; diff --git a/testsuite/tests/typing-misc/empty_variant.ml b/testsuite/tests/typing-misc/empty_variant.ml new file mode 100644 index 0000000000..88342711a7 --- /dev/null +++ b/testsuite/tests/typing-misc/empty_variant.ml @@ -0,0 +1,31 @@ +(* TEST + * expect +*) + +(* empty variant *) +type t = |;; +[%%expect{| +type t = | +|}];; + +let f (x:t) = match x with _ -> . +[%%expect{| +val f : t -> 'a = <fun> +|}];; + +type m = A of t | B of int * t | C of {g:t} +[%%expect{| +type m = A of t | B of int * t | C of { g : t; } +|}] + +let g (x:m) = + match x with + | A _ | B _ | C _ -> . +[%%expect{| +val g : m -> 'a = <fun> +|}] + +let f : t option -> int = function None -> 3 +[%%expect{| +val f : t option -> int = <fun> +|}] diff --git a/testsuite/tests/typing-misc/ocamltests b/testsuite/tests/typing-misc/ocamltests index f137cc85e2..461a301a34 100644 --- a/testsuite/tests/typing-misc/ocamltests +++ b/testsuite/tests/typing-misc/ocamltests @@ -11,3 +11,4 @@ printing.ml records.ml variant.ml wellfounded.ml +empty_variant.ml diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml index 4abc57a308..f14a9950a5 100644 --- a/testsuite/tests/typing-misc/polyvars.ml +++ b/testsuite/tests/typing-misc/polyvars.ml @@ -21,13 +21,6 @@ Line _, characters 31-34: Error: This pattern matches values of type [? `B ] but a pattern was expected which matches values of type [ `A ] The second variant type does not allow tag(s) `B -|}, Principal{| -Line _, characters 31-34: - let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);; - ^^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - Types for tag `B are incompatible |}];; let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; [%%expect{| @@ -37,13 +30,6 @@ Line _, characters 34-36: Error: This pattern matches values of type [? `B ] but a pattern was expected which matches values of type [ `A ] The second variant type does not allow tag(s) `B -|}, Principal{| -Line _, characters 34-36: - let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; - ^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - Types for tag `B are incompatible |}];; let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *) diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index f719c99b95..7a3340c096 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -758,3 +758,12 @@ R.M.f 3;; module rec R : sig module M = M end - : int = 3 |}];; + +module M = struct type t end +module type S = sig module N = M val x : N.t end +module type T = S with module N := M;; +[%%expect{| +module M : sig type t end +module type S = sig module N = M val x : N.t end +module type T = sig val x : M.t end +|}];; diff --git a/testsuite/tests/typing-objects/Exemples.compilers.reference b/testsuite/tests/typing-objects/Exemples.compilers.reference deleted file mode 100644 index 5dc7a51d53..0000000000 --- a/testsuite/tests/typing-objects/Exemples.compilers.reference +++ /dev/null @@ -1,359 +0,0 @@ -class point : - int -> - object val mutable x : int method get_x : int method move : int -> unit end -val p : point = <obj> -- : int = 7 -- : unit = () -- : int = 10 -val q : point = <obj> -- : int * int = (10, 17) -class color_point : - int -> - string -> - object - val c : string - val mutable x : int - method color : string - method get_x : int - method move : int -> unit - end -val p' : color_point = <obj> -- : int * string = (5, "red") -val l : point list = [<obj>; <obj>] -val get_x : < get_x : 'a; .. > -> 'a = <fun> -val set_x : < set_x : 'a; .. > -> 'a = <fun> -- : int list = [10; 5] -Characters 1-96: - class ref x_init = object - val mutable x = x_init - method get = x - method set y = x <- y - end.. -Error: Some type variables are unbound in this type: - class ref : - 'a -> - object - val mutable x : 'a - method get : 'a - method set : 'a -> unit - end - The method get has type 'a where 'a is unbound -class ref : - int -> - object val mutable x : int method get : int method set : int -> unit end -class ['a] ref : - 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end -- : int = 2 -class ['a] circle : - 'a -> - object - constraint 'a = < move : int -> unit; .. > - val mutable center : 'a - method center : 'a - method move : int -> unit - method set_center : 'a -> unit - end -class ['a] circle : - 'a -> - object - constraint 'a = #point - val mutable center : 'a - method center : 'a - method move : int -> unit - method set_center : 'a -> unit - end -val c : point circle = <obj> -val c' : color_point circle = <obj> -class ['a] color_circle : - 'a -> - object - constraint 'a = #color_point - val mutable center : 'a - method center : 'a - method color : string - method move : int -> unit - method set_center : 'a -> unit - end -Characters 28-29: - let c'' = new color_circle p;; - ^ -Error: This expression has type point but an expression was expected of type - #color_point - The first object type has no method color -val c'' : color_point color_circle = <obj> -- : color_point circle = <obj> -Characters 0-21: - (c'' :> point circle);; (* Fail *) - ^^^^^^^^^^^^^^^^^^^^^ -Error: Type - color_point color_circle = - < center : color_point; color : string; move : int -> unit; - set_center : color_point -> unit > - is not a subtype of - point circle = - < center : point; move : int -> unit; set_center : point -> unit > - Type point is not a subtype of color_point -Characters 9-55: - fun x -> (x : color_point color_circle :> point circle);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type - color_point color_circle = - < center : color_point; color : string; move : int -> unit; - set_center : color_point -> unit > - is not a subtype of - point circle = - < center : point; move : int -> unit; set_center : point -> unit > - Type point is not a subtype of color_point -class printable_point : - int -> - object - val mutable x : int - method get_x : int - method move : int -> unit - method print : unit - end -val p : printable_point = <obj> -7- : unit = () -Characters 85-102: - inherit printable_point y as super - ^^^^^^^^^^^^^^^^^ -Warning 13: the following instance variables are overridden by the class printable_point : - x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -class printable_color_point : - int -> - string -> - object - val c : string - val mutable x : int - method color : string - method get_x : int - method move : int -> unit - method print : unit - end -val p' : printable_color_point = <obj> -(7, red)- : unit = () -class functional_point : - int -> - object ('a) val x : int method get_x : int method move : int -> 'a end -val p : functional_point = <obj> -- : int = 7 -- : int = 10 -- : int = 7 -- : #functional_point -> functional_point = <fun> -class virtual ['a] lst : - unit -> - object - method virtual hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method virtual null : bool - method print : ('a -> unit) -> unit - method virtual tl : 'a lst - end -and ['a] nil : - unit -> - object - method hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method null : bool - method print : ('a -> unit) -> unit - method tl : 'a lst - end -and ['a] cons : - 'a -> - 'a lst -> - object - val h : 'a - val t : 'a lst - method hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method null : bool - method print : ('a -> unit) -> unit - method tl : 'a lst - end -val l1 : int lst = <obj> -(3::10::[])- : unit = () -val l2 : int lst = <obj> -(4::11::[])- : unit = () -val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun> -val p1 : printable_color_point lst = <obj> -((3, red)::(10, red)::[])- : unit = () -class virtual comparable : - unit -> object ('a) method virtual cmp : 'a -> int end -class int_comparable : - int -> object ('a) val x : int method cmp : 'a -> int method x : int end -class int_comparable2 : - int -> - object ('a) - val x : int - val mutable x' : int - method cmp : 'a -> int - method set_x : int -> unit - method x : int - end -class ['a] sorted_list : - unit -> - object - constraint 'a = #comparable - val mutable l : 'a list - method add : 'a -> unit - method hd : 'a - end -val l : _#comparable sorted_list = <obj> -val c : int_comparable = <obj> -- : unit = () -val c2 : int_comparable2 = <obj> -Characters 6-28: - l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *) - ^^^^^^^^^^^^^^^^^^^^^^ -Error: Type - int_comparable2 = - < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > - is not a subtype of - int_comparable = < cmp : int_comparable -> int; x : int > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not a subtype of - int_comparable2 = - < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > -- : unit = () -class int_comparable3 : - int -> - object - val mutable x : int - method cmp : int_comparable -> int - method setx : int -> unit - method x : int - end -val c3 : int_comparable3 = <obj> -- : unit = () -Characters 25-27: - (new sorted_list ())#add c3;; (* Error; strange message with -principal *) - ^^ -Error: This expression has type - int_comparable3 = - < cmp : int_comparable -> int; setx : int -> unit; x : int > - but an expression was expected of type - #comparable as 'a = < cmp : 'a -> int; .. > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not compatible with type - int_comparable3 = - < cmp : int_comparable -> int; setx : int -> unit; x : int > - The first object type has no method setx -val sort : (#comparable as 'a) list -> 'a list = <fun> -Characters 13-66: - List.map (fun c -> print_int c#x; print_string " ") l; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 10: this expression should have type unit. -val pr : < x : int; .. > list -> unit = <fun> -val l : int_comparable list = [<obj>; <obj>; <obj>] -5 2 4 -- : unit = () -2 4 5 -- : unit = () -val l : int_comparable2 list = [<obj>; <obj>] -2 0 -- : unit = () -0 2 -- : unit = () -val min : (#comparable as 'a) -> 'a -> 'a = <fun> -- : int = 7 -- : int = 3 -class ['a] link : - 'a -> - object ('b) - val mutable next : 'b option - val mutable x : 'a - method append : 'b option -> unit - method next : 'b option - method set_next : 'b option -> unit - method set_x : 'a -> unit - method x : 'a - end -class ['a] double_link : - 'a -> - object ('b) - val mutable next : 'b option - val mutable prev : 'b option - val mutable x : 'a - method append : 'b option -> unit - method next : 'b option - method prev : 'b option - method set_next : 'b option -> unit - method set_prev : 'b option -> unit - method set_x : 'a -> unit - method x : 'a - end -val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun> -class calculator : - unit -> - object ('a) - val mutable acc : float - val mutable arg : float - val mutable equals : 'a -> float - method acc : float - method add : 'a - method arg : float - method enter : float -> 'a - method equals : float - method sub : 'a - end -- : float = 5. -- : float = 1.5 -- : float = 15. -class calculator : - unit -> - object ('a) - val mutable acc : float - val mutable arg : float - val mutable equals : 'a -> float - method acc : float - method add : 'a - method arg : float - method enter : float -> 'a - method equals : float - method sub : 'a - end -- : float = 5. -- : float = 1.5 -- : float = 15. -class calculator : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -and calculator_add : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -and calculator_sub : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -val calculator : calculator = <obj> -- : float = 5. -- : float = 1.5 -- : float = 15. - diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index 569aa52c78..855ba34343 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -1,5 +1,5 @@ (* TEST - * toplevel + * expect *) class point x_init = object @@ -7,52 +7,136 @@ class point x_init = object method get_x = x method move d = x <- x + d end;; +[%%expect{| +class point : + int -> + object val mutable x : int method get_x : int method move : int -> unit end +|}];; let p = new point 7;; +[%%expect{| +val p : point = <obj> +|}];; p#get_x;; +[%%expect{| +- : int = 7 +|}];; p#move 3;; +[%%expect{| +- : unit = () +|}];; p#get_x;; +[%%expect{| +- : int = 10 +|}];; let q = Oo.copy p;; +[%%expect{| +val q : point = <obj> +|}, Principal{| +val q : < get_x : int; move : int -> unit > = <obj> +|}];; q#move 7; p#get_x, q#get_x;; +[%%expect{| +- : int * int = (10, 17) +|}];; class color_point x (c : string) = object inherit point x val c = c method color = c end;; +[%%expect{| +class color_point : + int -> + string -> + object + val c : string + val mutable x : int + method color : string + method get_x : int + method move : int -> unit + end +|}];; let p' = new color_point 5 "red";; +[%%expect{| +val p' : color_point = <obj> +|}];; p'#get_x, p'#color;; +[%%expect{| +- : int * string = (5, "red") +|}];; let l = [p; (p' :> point)];; +[%%expect{| +val l : point list = [<obj>; <obj>] +|}];; let get_x p = p#get_x;; +[%%expect{| +val get_x : < get_x : 'a; .. > -> 'a = <fun> +|}];; let set_x p = p#set_x;; +[%%expect{| +val set_x : < set_x : 'a; .. > -> 'a = <fun> +|}];; List.map get_x l;; +[%%expect{| +- : int list = [10; 5] +|}];; class ref x_init = object val mutable x = x_init method get = x method set y = x <- y end;; +[%%expect{| +Line _, characters 0-95: + class ref x_init = object + val mutable x = x_init + method get = x + method set y = x <- y + end.. +Error: Some type variables are unbound in this type: + class ref : + 'a -> + object + val mutable x : 'a + method get : 'a + method set : 'a -> unit + end + The method get has type 'a where 'a is unbound +|}];; class ref (x_init:int) = object val mutable x = x_init method get = x method set y = x <- y end;; +[%%expect{| +class ref : + int -> + object val mutable x : int method get : int method set : int -> unit end +|}];; class ['a] ref x_init = object val mutable x = (x_init : 'a) method get = x method set y = x <- y end;; +[%%expect{| +class ['a] ref : + 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end +|}];; let r = new ref 1 in r#set 2; (r#get);; +[%%expect{| +- : int = 2 +|}];; class ['a] circle (c : 'a) = object val mutable center = c @@ -60,6 +144,17 @@ class ['a] circle (c : 'a) = object method set_center c = center <- c method move = (center#move : int -> unit) end;; +[%%expect{| +class ['a] circle : + 'a -> + object + constraint 'a = < move : int -> unit; .. > + val mutable center : 'a + method center : 'a + method move : int -> unit + method set_center : 'a -> unit + end +|}];; class ['a] circle (c : 'a) = object constraint 'a = #point @@ -68,57 +163,188 @@ class ['a] circle (c : 'a) = object method set_center c = center <- c method move = center#move end;; +[%%expect{| +class ['a] circle : + 'a -> + object + constraint 'a = #point + val mutable center : 'a + method center : 'a + method move : int -> unit + method set_center : 'a -> unit + end +|}];; let (c, c') = (new circle p, new circle p');; +[%%expect{| +val c : point circle = <obj> +val c' : color_point circle = <obj> +|}, Principal{| +val c : point circle = <obj> +val c' : < color : string; get_x : int; move : int -> unit > circle = <obj> +|}];; class ['a] color_circle c = object constraint 'a = #color_point inherit ['a] circle c method color = center#color end;; +[%%expect{| +class ['a] color_circle : + 'a -> + object + constraint 'a = #color_point + val mutable center : 'a + method center : 'a + method color : string + method move : int -> unit + method set_center : 'a -> unit + end +|}];; let c'' = new color_circle p;; +[%%expect{| +Line _, characters 27-28: + let c'' = new color_circle p;; + ^ +Error: This expression has type point but an expression was expected of type + #color_point + The first object type has no method color +|}];; let c'' = new color_circle p';; +[%%expect{| +val c'' : color_point color_circle = <obj> +|}];; (c'' :> color_point circle);; -(c'' :> point circle);; (* Fail *) +[%%expect{| +- : color_point circle = <obj> +|}];; +(c'' :> point circle);; +[%%expect{| +Line _, characters 0-21: + (c'' :> point circle);; + ^^^^^^^^^^^^^^^^^^^^^ +Error: Type + color_point color_circle = + < center : color_point; color : string; move : int -> unit; + set_center : color_point -> unit > + is not a subtype of + point circle = + < center : point; move : int -> unit; set_center : point -> unit > + Type point is not a subtype of color_point +|}];; (* Fail *) fun x -> (x : color_point color_circle :> point circle);; +[%%expect{| +Line _, characters 9-55: + fun x -> (x : color_point color_circle :> point circle);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type + color_point color_circle = + < center : color_point; color : string; move : int -> unit; + set_center : color_point -> unit > + is not a subtype of + point circle = + < center : point; move : int -> unit; set_center : point -> unit > + Type point is not a subtype of color_point +|}];; class printable_point y = object (s) inherit point y - method print = print_int s#get_x + method print = Format.print_int s#get_x end;; +[%%expect{| +class printable_point : + int -> + object + val mutable x : int + method get_x : int + method move : int -> unit + method print : unit + end +|}];; let p = new printable_point 7;; +[%%expect{| +val p : printable_point = <obj> +|}];; p#print;; +[%%expect{| +- : unit = () +|}];; class printable_color_point y c = object (self) inherit color_point y c inherit printable_point y as super method print = - print_string "("; + Format.print_string "("; super#print; - print_string ", "; - print_string (self#color); - print_string ")" + Format.print_string ", "; + Format.print_string (self#color); + Format.print_string ")" end;; +[%%expect{| +Line _, characters 10-27: + inherit printable_point y as super + ^^^^^^^^^^^^^^^^^ +Warning 13: the following instance variables are overridden by the class printable_point : + x +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +class printable_color_point : + int -> + string -> + object + val c : string + val mutable x : int + method color : string + method get_x : int + method move : int -> unit + method print : unit + end +|}];; let p' = new printable_color_point 7 "red";; +[%%expect{| +val p' : printable_color_point = <obj> +|}];; p'#print;; +[%%expect{| +- : unit = () +|}];; class functional_point y = object val x = y method get_x = x method move d = {< x = x + d >} end;; +[%%expect{| +class functional_point : + int -> + object ('a) val x : int method get_x : int method move : int -> 'a end +|}];; let p = new functional_point 7;; +[%%expect{| +val p : functional_point = <obj> +|}];; p#get_x;; +[%%expect{| +- : int = 7 +|}];; (p#move 3)#get_x;; +[%%expect{| +- : int = 10 +|}];; p#get_x;; +[%%expect{| +- : int = 7 +|}];; fun x -> (x :> functional_point);; +[%%expect{| +- : #functional_point -> functional_point = <fun> +|}];; (*******************************************************************) @@ -139,10 +365,10 @@ class virtual ['a] lst () = object (self) self#tl#iter f end method print (f : 'a -> unit) = - print_string "("; - self#iter (fun x -> f x; print_string "::"); - print_string "[]"; - print_string ")" + Format.print_string "("; + self#iter (fun x -> f x; Format.print_string "::"); + Format.print_string "[]"; + Format.print_string ")" end and ['a] nil () = object inherit ['a] lst () method null = true @@ -155,26 +381,86 @@ end and ['a] cons h t = object method hd = h method tl = t end;; +[%%expect{| +class virtual ['a] lst : + unit -> + object + method virtual hd : 'a + method iter : ('a -> unit) -> unit + method map : ('a -> 'a) -> 'a lst + method virtual null : bool + method print : ('a -> unit) -> unit + method virtual tl : 'a lst + end +and ['a] nil : + unit -> + object + method hd : 'a + method iter : ('a -> unit) -> unit + method map : ('a -> 'a) -> 'a lst + method null : bool + method print : ('a -> unit) -> unit + method tl : 'a lst + end +and ['a] cons : + 'a -> + 'a lst -> + object + val h : 'a + val t : 'a lst + method hd : 'a + method iter : ('a -> unit) -> unit + method map : ('a -> 'a) -> 'a lst + method null : bool + method print : ('a -> unit) -> unit + method tl : 'a lst + end +|}];; let l1 = new cons 3 (new cons 10 (new nil ()));; +[%%expect{| +val l1 : int lst = <obj> +|}];; -l1#print print_int;; +l1#print Format.print_int;; +[%%expect{| +- : unit = () +|}];; let l2 = l1#map (fun x -> x + 1);; -l2#print print_int;; +[%%expect{| +val l2 : int lst = <obj> +|}];; +l2#print Format.print_int;; +[%%expect{| +- : unit = () +|}];; let rec map_list f (x:'a lst) = if x#null then new nil() else new cons (f x#hd) (map_list f x#tl);; +[%%expect{| +val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun> +|}];; let p1 = (map_list (fun x -> new printable_color_point x "red") l1);; +[%%expect{| +val p1 : printable_color_point lst = <obj> +|}];; p1#print (fun x -> x#print);; +[%%expect{| +- : unit = () +|}];; (*******************************************************************) class virtual comparable () = object (self : 'a) method virtual cmp : 'a -> int end;; +[%%expect{| +class virtual comparable : + unit -> object ('a) method virtual cmp : 'a -> int end +|}];; class int_comparable (x : int) = object inherit comparable () @@ -182,12 +468,27 @@ class int_comparable (x : int) = object method x = x method cmp p = compare x p#x end;; +[%%expect{| +class int_comparable : + int -> object ('a) val x : int method cmp : 'a -> int method x : int end +|}];; class int_comparable2 xi = object inherit int_comparable xi val mutable x' = xi method set_x y = x' <- y end;; +[%%expect{| +class int_comparable2 : + int -> + object ('a) + val x : int + val mutable x' : int + method cmp : 'a -> int + method set_x : int -> unit + method x : int + end +|}];; class ['a] sorted_list () = object constraint 'a = #comparable @@ -201,14 +502,53 @@ class ['a] sorted_list () = object l <- insert l method hd = List.hd l end;; +[%%expect{| +class ['a] sorted_list : + unit -> + object + constraint 'a = #comparable + val mutable l : 'a list + method add : 'a -> unit + method hd : 'a + end +|}];; let l = new sorted_list ();; +[%%expect{| +val l : _#comparable sorted_list = <obj> +|}];; let c = new int_comparable 10;; +[%%expect{| +val c : int_comparable = <obj> +|}];; l#add c;; +[%%expect{| +- : unit = () +|}];; let c2 = new int_comparable2 15;; -l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *) +[%%expect{| +val c2 : int_comparable2 = <obj> +|}];; +l#add (c2 :> int_comparable);; +[%%expect{| +Line _, characters 6-28: + l#add (c2 :> int_comparable);; + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type + int_comparable2 = + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > + is not a subtype of + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > + is not a subtype of + int_comparable2 = + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > +|}];; (* Fail : 'a comp2 is not a subtype *) (new sorted_list ())#add c2;; +[%%expect{| +- : unit = () +|}];; class int_comparable3 (x : int) = object val mutable x = x @@ -216,28 +556,112 @@ class int_comparable3 (x : int) = object method x = x method setx y = x <- y end;; +[%%expect{| +class int_comparable3 : + int -> + object + val mutable x : int + method cmp : int_comparable -> int + method setx : int -> unit + method x : int + end +|}];; let c3 = new int_comparable3 15;; +[%%expect{| +val c3 : int_comparable3 = <obj> +|}];; l#add (c3 :> int_comparable);; -(new sorted_list ())#add c3;; (* Error; strange message with -principal *) +[%%expect{| +- : unit = () +|}];; +(new sorted_list ())#add c3;; +[%%expect{| +Line _, characters 25-27: + (new sorted_list ())#add c3;; + ^^ +Error: This expression has type + int_comparable3 = + < cmp : int_comparable -> int; setx : int -> unit; x : int > + but an expression was expected of type + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > + is not compatible with type + int_comparable3 = + < cmp : int_comparable -> int; setx : int -> unit; x : int > + The first object type has no method setx +|}, Principal{| +Line _, characters 25-27: + (new sorted_list ())#add c3;; + ^^ +Error: This expression has type + int_comparable3 = + < cmp : int_comparable -> int; setx : int -> unit; x : int > + but an expression was expected of type + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > + is not compatible with type 'a = < cmp : 'a -> int; .. > + The first object type has no method setx +|}];; (* Error; strange message with -principal *) let sort (l : #comparable list) = List.sort (fun x -> x#cmp) l;; +[%%expect{| +val sort : (#comparable as 'a) list -> 'a list = <fun> +|}];; let pr l = - List.map (fun c -> print_int c#x; print_string " ") l; - print_newline ();; + List.map (fun c -> Format.print_int c#x; Format.print_string " ") l; + Format.print_newline ();; +[%%expect{| +Line _, characters 2-69: + List.map (fun c -> Format.print_int c#x; Format.print_string " ") l; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 10: this expression should have type unit. +val pr : < x : int; .. > list -> unit = <fun> +|}];; let l = [new int_comparable 5; (new int_comparable3 2 :> int_comparable); new int_comparable 4];; +[%%expect{| +val l : int_comparable list = [<obj>; <obj>; <obj>] +|}];; pr l;; +[%%expect{| +7(7, red)(3::10::[])(4::11::[])((3, red)::(10, red)::[])5 2 4 +- : unit = () +|}];; pr (sort l);; +[%%expect{| +2 4 5 +- : unit = () +|}];; let l = [new int_comparable2 2; new int_comparable2 0];; +[%%expect{| +val l : int_comparable2 list = [<obj>; <obj>] +|}];; pr l;; +[%%expect{| +2 0 +- : unit = () +|}];; pr (sort l);; +[%%expect{| +0 2 +- : unit = () +|}];; let min (x : #comparable) y = if x#cmp y <= 0 then x else y;; +[%%expect{| +val min : (#comparable as 'a) -> 'a -> 'a = <fun> +|}];; (min (new int_comparable 7) (new int_comparable 11))#x;; +[%%expect{| +- : int = 7 +|}];; (min (new int_comparable2 5) (new int_comparable2 3))#x;; +[%%expect{| +- : int = 3 +|}];; (*******************************************************************) @@ -255,6 +679,19 @@ class ['a] link (x : 'a) = object (self : 'b) | Some l' -> l'#append l end;; +[%%expect{| +class ['a] link : + 'a -> + object ('b) + val mutable next : 'b option + val mutable x : 'a + method append : 'b option -> unit + method next : 'b option + method set_next : 'b option -> unit + method set_x : 'a -> unit + method x : 'a + end +|}];; class ['a] double_link x = object (self) inherit ['a] link x @@ -265,12 +702,31 @@ class ['a] double_link x = object (self) match l with Some l -> l#set_prev (Some self) | None -> () method set_prev l = prev <- l end;; +[%%expect{| +class ['a] double_link : + 'a -> + object ('b) + val mutable next : 'b option + val mutable prev : 'b option + val mutable x : 'a + method append : 'b option -> unit + method next : 'b option + method prev : 'b option + method set_next : 'b option -> unit + method set_prev : 'b option -> unit + method set_x : 'a -> unit + method x : 'a + end +|}];; let rec fold_right f (l : 'a #link option) accu = match l with None -> accu | Some l -> f l#x (fold_right f l#next accu);; +[%%expect{| +val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun> +|}];; (*******************************************************************) @@ -291,10 +747,34 @@ class calculator () = object (self) self method equals = equals self end;; +[%%expect{| +class calculator : + unit -> + object ('a) + val mutable acc : float + val mutable arg : float + val mutable equals : 'a -> float + method acc : float + method add : 'a + method arg : float + method enter : float -> 'a + method equals : float + method sub : 'a + end +|}];; ((new calculator ())#enter 5.)#equals;; +[%%expect{| +- : float = 5. +|}];; (((new calculator ())#enter 5.)#sub#enter 3.5)#equals;; +[%%expect{| +- : float = 1.5 +|}];; ((new calculator ())#enter 5.)#add#add#equals;; +[%%expect{| +- : float = 15. +|}];; class calculator () = object (self) val mutable arg = 0. @@ -307,10 +787,34 @@ class calculator () = object (self) method sub = {< acc = equals self; equals = function s -> s#acc -. s#arg >} method equals = equals self end;; +[%%expect{| +class calculator : + unit -> + object ('a) + val mutable acc : float + val mutable arg : float + val mutable equals : 'a -> float + method acc : float + method add : 'a + method arg : float + method enter : float -> 'a + method equals : float + method sub : 'a + end +|}];; ((new calculator ())#enter 5.)#equals;; +[%%expect{| +- : float = 5. +|}];; (((new calculator ())#enter 5.)#sub#enter 3.5)#equals;; +[%%expect{| +- : float = 1.5 +|}];; ((new calculator ())#enter 5.)#add#add#equals;; +[%%expect{| +- : float = 15. +|}];; class calculator arg acc = object (self) val arg = arg @@ -328,9 +832,56 @@ end and calculator_sub arg acc = object method enter n = new calculator_sub n acc method equals = acc -. arg end;; +[%%expect{| +class calculator : + float -> + float -> + object + val acc : float + val arg : float + method add : calculator + method enter : float -> calculator + method equals : float + method sub : calculator + end +and calculator_add : + float -> + float -> + object + val acc : float + val arg : float + method add : calculator + method enter : float -> calculator + method equals : float + method sub : calculator + end +and calculator_sub : + float -> + float -> + object + val acc : float + val arg : float + method add : calculator + method enter : float -> calculator + method equals : float + method sub : calculator + end +|}];; let calculator = new calculator 0. 0.;; +[%%expect{| +val calculator : calculator = <obj> +|}];; (calculator#enter 5.)#equals;; +[%%expect{| +- : float = 5. +|}];; ((calculator#enter 5.)#sub#enter 3.5)#equals;; +[%%expect{| +- : float = 1.5 +|}];; (calculator#enter 5.)#add#add#equals;; +[%%expect{| +- : float = 15. +|}];; diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference deleted file mode 100644 index 67090461d6..0000000000 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ /dev/null @@ -1,358 +0,0 @@ - -# class point : - int -> - object val mutable x : int method get_x : int method move : int -> unit end -# val p : point = <obj> -# - : int = 7 -# - : unit = () -# - : int = 10 -# val q : < get_x : int; move : int -> unit > = <obj> -# - : int * int = (10, 17) -# class color_point : - int -> - string -> - object - val c : string - val mutable x : int - method color : string - method get_x : int - method move : int -> unit - end -# val p' : color_point = <obj> -# - : int * string = (5, "red") -# val l : point list = [<obj>; <obj>] -# val get_x : < get_x : 'a; .. > -> 'a = <fun> -# val set_x : < set_x : 'a; .. > -> 'a = <fun> -# - : int list = [10; 5] -# Characters 1-96: - class ref x_init = object - val mutable x = x_init - method get = x - method set y = x <- y - end.. -Error: Some type variables are unbound in this type: - class ref : - 'a -> - object - val mutable x : 'a - method get : 'a - method set : 'a -> unit - end - The method get has type 'a where 'a is unbound -# class ref : - int -> - object val mutable x : int method get : int method set : int -> unit end -# class ['a] ref : - 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end -# - : int = 2 -# class ['a] circle : - 'a -> - object - constraint 'a = < move : int -> unit; .. > - val mutable center : 'a - method center : 'a - method move : int -> unit - method set_center : 'a -> unit - end -# class ['a] circle : - 'a -> - object - constraint 'a = #point - val mutable center : 'a - method center : 'a - method move : int -> unit - method set_center : 'a -> unit - end -# val c : point circle = <obj> -val c' : < color : string; get_x : int; move : int -> unit > circle = <obj> -# class ['a] color_circle : - 'a -> - object - constraint 'a = #color_point - val mutable center : 'a - method center : 'a - method color : string - method move : int -> unit - method set_center : 'a -> unit - end -# Characters 28-29: - let c'' = new color_circle p;; - ^ -Error: This expression has type point but an expression was expected of type - #color_point - The first object type has no method color -# val c'' : color_point color_circle = <obj> -# - : color_point circle = <obj> -# Characters 0-21: - (c'' :> point circle);; (* Fail *) - ^^^^^^^^^^^^^^^^^^^^^ -Error: Type - color_point color_circle = - < center : color_point; color : string; move : int -> unit; - set_center : color_point -> unit > - is not a subtype of - point circle = - < center : point; move : int -> unit; set_center : point -> unit > - Type point is not a subtype of color_point -# Characters 9-55: - fun x -> (x : color_point color_circle :> point circle);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type - color_point color_circle = - < center : color_point; color : string; move : int -> unit; - set_center : color_point -> unit > - is not a subtype of - point circle = - < center : point; move : int -> unit; set_center : point -> unit > - Type point is not a subtype of color_point -# class printable_point : - int -> - object - val mutable x : int - method get_x : int - method move : int -> unit - method print : unit - end -# val p : printable_point = <obj> -# 7- : unit = () -# Characters 85-102: - inherit printable_point y as super - ^^^^^^^^^^^^^^^^^ -Warning 13: the following instance variables are overridden by the class printable_point : - x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -class printable_color_point : - int -> - string -> - object - val c : string - val mutable x : int - method color : string - method get_x : int - method move : int -> unit - method print : unit - end -# val p' : printable_color_point = <obj> -# (7, red)- : unit = () -# class functional_point : - int -> - object ('a) val x : int method get_x : int method move : int -> 'a end -# val p : functional_point = <obj> -# - : int = 7 -# - : int = 10 -# - : int = 7 -# - : #functional_point -> functional_point = <fun> -# class virtual ['a] lst : - unit -> - object - method virtual hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method virtual null : bool - method print : ('a -> unit) -> unit - method virtual tl : 'a lst - end -and ['a] nil : - unit -> - object - method hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method null : bool - method print : ('a -> unit) -> unit - method tl : 'a lst - end -and ['a] cons : - 'a -> - 'a lst -> - object - val h : 'a - val t : 'a lst - method hd : 'a - method iter : ('a -> unit) -> unit - method map : ('a -> 'a) -> 'a lst - method null : bool - method print : ('a -> unit) -> unit - method tl : 'a lst - end -# val l1 : int lst = <obj> -# (3::10::[])- : unit = () -# val l2 : int lst = <obj> -# (4::11::[])- : unit = () -# val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun> -# val p1 : printable_color_point lst = <obj> -# ((3, red)::(10, red)::[])- : unit = () -# class virtual comparable : - unit -> object ('a) method virtual cmp : 'a -> int end -# class int_comparable : - int -> object ('a) val x : int method cmp : 'a -> int method x : int end -# class int_comparable2 : - int -> - object ('a) - val x : int - val mutable x' : int - method cmp : 'a -> int - method set_x : int -> unit - method x : int - end -# class ['a] sorted_list : - unit -> - object - constraint 'a = #comparable - val mutable l : 'a list - method add : 'a -> unit - method hd : 'a - end -# val l : _#comparable sorted_list = <obj> -# val c : int_comparable = <obj> -# - : unit = () -# val c2 : int_comparable2 = <obj> -# Characters 6-28: - l#add (c2 :> int_comparable);; (* Fail : 'a comp2 is not a subtype *) - ^^^^^^^^^^^^^^^^^^^^^^ -Error: Type - int_comparable2 = - < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > - is not a subtype of - int_comparable = < cmp : int_comparable -> int; x : int > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not a subtype of - int_comparable2 = - < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > -# - : unit = () -# class int_comparable3 : - int -> - object - val mutable x : int - method cmp : int_comparable -> int - method setx : int -> unit - method x : int - end -# val c3 : int_comparable3 = <obj> -# - : unit = () -# Characters 25-27: - (new sorted_list ())#add c3;; (* Error; strange message with -principal *) - ^^ -Error: This expression has type - int_comparable3 = - < cmp : int_comparable -> int; setx : int -> unit; x : int > - but an expression was expected of type - #comparable as 'a = < cmp : 'a -> int; .. > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not compatible with type 'a = < cmp : 'a -> int; .. > - The first object type has no method setx -# val sort : (#comparable as 'a) list -> 'a list = <fun> -# Characters 13-66: - List.map (fun c -> print_int c#x; print_string " ") l; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 10: this expression should have type unit. -val pr : < x : int; .. > list -> unit = <fun> -# val l : int_comparable list = [<obj>; <obj>; <obj>] -# 5 2 4 -- : unit = () -# 2 4 5 -- : unit = () -# val l : int_comparable2 list = [<obj>; <obj>] -# 2 0 -- : unit = () -# 0 2 -- : unit = () -# val min : (#comparable as 'a) -> 'a -> 'a = <fun> -# - : int = 7 -# - : int = 3 -# class ['a] link : - 'a -> - object ('b) - val mutable next : 'b option - val mutable x : 'a - method append : 'b option -> unit - method next : 'b option - method set_next : 'b option -> unit - method set_x : 'a -> unit - method x : 'a - end -# class ['a] double_link : - 'a -> - object ('b) - val mutable next : 'b option - val mutable prev : 'b option - val mutable x : 'a - method append : 'b option -> unit - method next : 'b option - method prev : 'b option - method set_next : 'b option -> unit - method set_prev : 'b option -> unit - method set_x : 'a -> unit - method x : 'a - end -# val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun> -# class calculator : - unit -> - object ('a) - val mutable acc : float - val mutable arg : float - val mutable equals : 'a -> float - method acc : float - method add : 'a - method arg : float - method enter : float -> 'a - method equals : float - method sub : 'a - end -# - : float = 5. -# - : float = 1.5 -# - : float = 15. -# class calculator : - unit -> - object ('a) - val mutable acc : float - val mutable arg : float - val mutable equals : 'a -> float - method acc : float - method add : 'a - method arg : float - method enter : float -> 'a - method equals : float - method sub : 'a - end -# - : float = 5. -# - : float = 1.5 -# - : float = 15. -# class calculator : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -and calculator_add : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -and calculator_sub : - float -> - float -> - object - val acc : float - val arg : float - method add : calculator - method enter : float -> calculator - method equals : float - method sub : calculator - end -# val calculator : calculator = <obj> -# - : float = 5. -# - : float = 1.5 -# - : float = 15. -# diff --git a/testsuite/tests/typing-objects/Tests.compilers.reference b/testsuite/tests/typing-objects/Tests.compilers.reference deleted file mode 100644 index 3c287ec0b2..0000000000 --- a/testsuite/tests/typing-objects/Tests.compilers.reference +++ /dev/null @@ -1,316 +0,0 @@ -- : < x : int > -> - < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > -= <fun> -class ['a] c : unit -> object constraint 'a = int method f : int c end -and ['a] d : unit -> object constraint 'a = int method f : int c end -Characters 230-271: - ....and d () = object - inherit ['a] c () - end.. -Error: Some type variables are unbound in this type: - class d : unit -> object method f : 'a -> unit end - The method f has type 'a -> unit where 'a is unbound -class virtual c : unit -> object end -and ['a] d : - unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end -class ['a] c : unit -> object constraint 'a = int end -and ['a] d : unit -> object constraint 'a = int #c end -class ['a] c : - 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end -- : ('a c as 'a) -> 'a = <fun> -Characters 128-176: - class x () = object - method virtual f : int - end.. -Error: This class should be virtual. The following methods are undefined : f -Characters 144-152: - class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end - ^^^^^^^^ -Error: This pattern cannot match self: it only matches values of type - < f : int > -Characters 32-110: - class ['a] c () = object - constraint 'a = int - method f x = (x : bool c) - end.. -Error: The abbreviation c is used with parameters bool c - which are incompatible with constraints int c -class ['a, 'b] c : - unit -> - object - constraint 'a = int -> 'c - constraint 'b = 'a * < x : 'b > * 'c * 'd - method f : 'a -> 'b -> unit - end -class ['a, 'b] d : - unit -> - object - constraint 'a = int -> 'c - constraint 'b = 'a * < x : 'b > * 'c * 'd - method f : 'a -> 'b -> unit - end -val x : '_weak1 list ref = {contents = []} -Characters 0-50: - class ['a] c () = object - method f = (x : 'a) - end.. -Error: The type of this class, - class ['a] c : - unit -> object constraint 'a = '_weak1 list ref method f : 'a end, - contains type variables that cannot be generalized -Characters 21-53: - type 'a c = <f : 'a c; g : 'a d> - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: In the definition of d, type int c should be 'a c -type 'a c = < f : 'a c; g : 'a d > -and 'a d = < f : 'a c > -type 'a c = < f : 'a c > -and 'a d = < f : int c > -Characters 22-39: - and 'a t = 'a t u;; (* fails since 4.04 *) - ^^^^^^^^^^^^^^^^^ -Error: The definition of t contains a cycle: - 'a t u -Characters 15-32: - and 'a t = 'a t u;; - ^^^^^^^^^^^^^^^^^ -Error: The type abbreviation t is cyclic -type 'a u = 'a -Characters 0-18: - type t = t u * t u;; - ^^^^^^^^^^^^^^^^^^ -Error: The type abbreviation t is cyclic -type t = < x : 'a > as 'a -type 'a u = 'a -- : t -> t u -> bool = <fun> -- : t -> t u -> bool = <fun> -module M : - sig - class ['a, 'b] c : - int -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end - end -module M' : - sig - class virtual ['a, 'b] c : - int -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end - end -class ['a, 'b] d : - unit -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end -class ['a, 'b] e : - unit -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end -- : string = "a" -- : int = 10 -- : float = 7.1 -- : bool = true -module M : sig class ['a] c : unit -> object method f : 'a -> unit end end -module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end -- : ('a #M.c as 'b) -> 'b = <fun> -- : ('a #M'.c as 'b) -> 'b = <fun> -class ['a] c : 'a #c -> object end -class ['a] c : 'a #c -> object end -class c : unit -> object method f : int end -and d : unit -> object method f : int end -class e : unit -> object method f : int end -- : int = 2 -Characters 30-34: - class c () = object val x = - true val y = -. () end;; - ^^^^ -Error: This expression has type bool but an expression was expected of type - int -class c : unit -> object method f : int method g : int method h : int end -class d : unit -> object method h : int method i : int method j : int end -class e : - unit -> - object - method f : int - method g : int - method h : int - method i : int - method j : int - end -val e : e = <obj> -- : int * int * int * int * int = (1, 3, 2, 2, 3) -class c : 'a -> object val a : 'a val x : int val y : int val z : int end -class d : 'a -> object val b : 'a val t : int val u : int val z : int end -Characters 42-45: - inherit c 5 - ^^^ -Warning 13: the following instance variables are overridden by the class c : - x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 52-53: - val y = 3 - ^ -Warning 13: the instance variable y is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 80-83: - inherit d 7 - ^^^ -Warning 13: the following instance variables are overridden by the class d : - t z -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 90-91: - val u = 3 - ^ -Warning 13: the instance variable u is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -class e : - unit -> - object - val a : int - val b : int - val t : int - val u : int - val x : int - val y : int - val z : int - method a : int - method b : int - method t : int - method u : int - method x : int - method y : int - method z : int - end -val e : e = <obj> -- : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7) -class c : - int -> - int -> object val x : int val y : int method x : int method y : int end -class d : - int -> - int -> object val x : int val y : int method x : int method y : int end -- : int * int = (1, 2) -- : int * int = (1, 2) -class ['a] c : 'a -> object end -- : 'a -> 'a c = <fun> -module M : sig class c : unit -> object method xc : int end end -class d : unit -> object val x : int method xc : int method xd : int end -- : int * int = (1, 2) -Characters 1-154: - class virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.make_matrix sz sz init - method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) - end.. -Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > - but is used with type < m : 'a array array; .. > -class c : unit -> object method m : c end -- : c = <obj> -module M : sig class c : unit -> object method m : c end end -- : M.c = <obj> -type uu = A of int | B of (< leq : 'a > as 'a) -class virtual c : unit -> object ('a) method virtual m : 'a end -module S : sig val f : (#c as 'a) -> 'a end -Characters 12-43: - ............struct - let f (x : #c) = x - end...... -Error: Signature mismatch: - Modules do not match: - sig val f : (#c as 'a) -> 'a end - is not included in - sig val f : #c -> #c end - Values do not match: - val f : (#c as 'a) -> 'a - is not included in - val f : #c -> #c -Characters 38-39: - module M = struct type t = int class t () = object end end;; - ^ -Error: Multiple definition of the type name t. - Names must be unique in a given structure or signature. -- : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun> -Characters 10-39: - fun x -> (x : int -> bool :> 'a -> 'a);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type int -> bool is not a subtype of int -> int - Type bool is not a subtype of int -Characters 9-40: - fun x -> (x : int -> bool :> int -> int);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type int -> bool is not a subtype of int -> int - Type bool is not a subtype of int -- : < > -> < > = <fun> -- : < .. > -> < > = <fun> -val x : '_weak2 list ref = {contents = []} -module F : functor (X : sig end) -> sig type t = int end -- : < m : int > list ref = {contents = []} -type 'a t -Characters 9-19: - fun (x : 'a t as 'a) -> ();; - ^^^^^^^^^^ -Error: This alias is bound to type 'a t but is used as an instance of type 'a - The type variable 'a occurs inside 'a t -Characters 19-20: - fun (x : 'a t) -> (x : 'a); ();; - ^ -Error: This expression has type 'a t but an expression was expected of type - 'a - The type variable 'a occurs inside 'a t -type 'a t = < x : 'a > -- : ('a t as 'a) -> unit = <fun> -Characters 18-26: - fun (x : 'a t) -> (x : 'a); ();; - ^^^^^^^^ -Warning 10: this expression should have type unit. -- : ('a t as 'a) t -> unit = <fun> -class ['a] c : - unit -> - object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end -class ['a] c : - unit -> - object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end -class c : unit -> object method private m : int method n : int end -class d : - unit -> object method private m : int method n : int method o : int end -- : int * int = (1, 1) -class c : unit -> object method m : int end -val r : int ref = {contents = 0} -val id : < .. > -> int = <fun> -- : unit = () -- : int = 1 -- : int = 2 -- : int * int * int = (3, 4, 5) -- : int * int * int * int * int = (6, 7, 8, 33, 33) -- : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) -Characters 42-69: - class a = let _ = new b in object end - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This kind of recursive class expression is not allowed -Characters 11-38: - class a = let _ = new a in object end;; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This kind of recursive class expression is not allowed - diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 4014d33611..0777d1d45c 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -1,9 +1,14 @@ (* TEST - * toplevel + * expect *) (* Subtyping is "syntactic" *) fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);; +[%%expect{| +- : < x : int > -> + < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > += <fun> +|}];; (* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *) (* Quirks of class typing. *) @@ -12,6 +17,10 @@ class ['a] c () = object end and ['a] d () = object inherit ['a] c () end;; +[%%expect{| +class ['a] c : unit -> object constraint 'a = int method f : int c end +and ['a] d : unit -> object constraint 'a = int method f : int c end +|}];; (* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *) (* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *) @@ -21,6 +30,15 @@ class ['a] c () = object end and d () = object inherit ['a] c () end;; +[%%expect{| +Line _, characters 4-45: + ....and d () = object + inherit ['a] c () + end.. +Error: Some type variables are unbound in this type: + class d : unit -> object method f : 'a -> unit end + The method f has type 'a -> unit where 'a is unbound +|}];; (* Create instance #c *) class virtual c () = object @@ -28,6 +46,11 @@ end and ['a] d () = object constraint 'a = #c method f (x : #c) = (x#x : int) end;; +[%%expect{| +class virtual c : unit -> object end +and ['a] d : + unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end +|}];; (* class virtual c : unit -> object end *) (* and ['a] d : *) (* unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end *) @@ -37,6 +60,10 @@ class ['a] c () = object end and ['a] d () = object constraint 'a = 'b #c end;; +[%%expect{| +class ['a] c : unit -> object constraint 'a = int end +and ['a] d : unit -> object constraint 'a = int #c end +|}];; (* class ['a] c : unit -> object constraint 'a = int end and ['a] d : unit -> object constraint 'a = int #c end *) @@ -45,7 +72,14 @@ class ['a] c (x : 'a) = object (self : 'b) constraint 'a = 'b method f = self end;; +[%%expect{| +class ['a] c : + 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end +|}];; new c;; +[%%expect{| +- : ('a c as 'a) -> 'a = <fun> +|}];; (* class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end *) (* - : ('a c as 'a) -> 'a = <fun> *) @@ -53,6 +87,13 @@ new c;; class x () = object method virtual f : int end;; +[%%expect{| +Line _, characters 0-48: + class x () = object + method virtual f : int + end.. +Error: This class should be virtual. The following methods are undefined : f +|}];; (* The class x should be virtual: its methods f is undefined *) (* Supplementary method g *) @@ -61,12 +102,28 @@ and virtual d x = object (_ : 'a) inherit c x method g = true end;; +[%%expect{| +Line _, characters 49-57: + class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end + ^^^^^^^^ +Error: This pattern cannot match self: it only matches values of type + < f : int > +|}];; (* Constraint not respected *) class ['a] c () = object constraint 'a = int method f x = (x : bool c) end;; +[%%expect{| +Line _, characters 0-78: + class ['a] c () = object + constraint 'a = int + method f x = (x : bool c) + end.. +Error: The abbreviation c is used with parameters bool c + which are incompatible with constraints int c +|}];; (* Different constraints *) class ['a, 'b] c () = object @@ -74,34 +131,113 @@ class ['a, 'b] c () = object constraint 'b = 'a * <x : 'b> * 'c * 'd method f (x : 'a) (y : 'b) = () end;; +[%%expect{| +class ['a, 'b] c : + unit -> + object + constraint 'a = int -> 'c + constraint 'b = 'a * < x : 'b > * 'c * 'd + method f : 'a -> 'b -> unit + end +|}];; class ['a, 'b] d () = object inherit ['a, 'b] c () end;; +[%%expect{| +class ['a, 'b] d : + unit -> + object + constraint 'a = int -> 'c + constraint 'b = 'a * < x : 'b > * 'c * 'd + method f : 'a -> 'b -> unit + end +|}];; (* Non-generic constraint *) let x = ref [];; +[%%expect{| +val x : '_weak1 list ref = {contents = []} +|}];; class ['a] c () = object method f = (x : 'a) end;; +[%%expect{| +Line _, characters 0-50: + class ['a] c () = object + method f = (x : 'a) + end.. +Error: The type of this class, + class ['a] c : + unit -> object constraint 'a = '_weak1 list ref method f : 'a end, + contains type variables that cannot be generalized +|}];; (* Abbreviations *) type 'a c = <f : 'a c; g : 'a d> and 'a d = <f : int c>;; +[%%expect{| +Line _, characters 0-32: + type 'a c = <f : 'a c; g : 'a d> + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of d, type int c should be 'a c +|}];; type 'a c = <f : 'a c; g : 'a d> and 'a d = <f : 'a c>;; +[%%expect{| +type 'a c = < f : 'a c; g : 'a d > +and 'a d = < f : 'a c > +|}];; type 'a c = <f : 'a c> and 'a d = <f : int c>;; +[%%expect{| +type 'a c = < f : 'a c > +and 'a d = < f : int c > +|}];; type 'a u = < x : 'a> -and 'a t = 'a t u;; (* fails since 4.04 *) +and 'a t = 'a t u;; +[%%expect{| +Line _, characters 0-17: + and 'a t = 'a t u;; + ^^^^^^^^^^^^^^^^^ +Error: The definition of t contains a cycle: + 'a t u +|}];; (* fails since 4.04 *) type 'a u = 'a and 'a t = 'a t u;; +[%%expect{| +Line _, characters 0-17: + and 'a t = 'a t u;; + ^^^^^^^^^^^^^^^^^ +Error: The type abbreviation t is cyclic +|}];; type 'a u = 'a;; +[%%expect{| +type 'a u = 'a +|}];; type t = t u * t u;; +[%%expect{| +Line _, characters 0-18: + type t = t u * t u;; + ^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation t is cyclic +|}];; type t = <x : 'a> as 'a;; +[%%expect{| +type t = < x : 'a > as 'a +|}];; type 'a u = 'a;; +[%%expect{| +type 'a u = 'a +|}];; fun (x : t) (y : 'a u) -> x = y;; +[%%expect{| +- : t -> t u -> bool = <fun> +|}];; fun (x : t) (y : 'a u) -> y = x;; +[%%expect{| +- : t -> t u -> bool = <fun> +|}];; (* - : t -> t u -> bool = <fun> *) (* Modules *) @@ -115,6 +251,21 @@ module M = method g = y end end;; +[%%expect{| +module M : + sig + class ['a, 'b] c : + int -> + 'b -> + object + constraint 'a = int -> bool + val x : float list + val y : 'b + method f : 'a -> unit + method g : 'b + end + end +|}];; module M' = (M : sig class virtual ['a, 'b] c : int -> 'b -> object @@ -125,31 +276,125 @@ module M' = (M : method g : 'b end end);; +[%%expect{| +module M' : + sig + class virtual ['a, 'b] c : + int -> + 'b -> + object + constraint 'a = int -> bool + val x : float list + val y : 'b + method f : 'a -> unit + method g : 'b + end + end +|}];; class ['a, 'b] d () y = object inherit ['a, 'b] M.c 7 y end;; +[%%expect{| +class ['a, 'b] d : + unit -> + 'b -> + object + constraint 'a = int -> bool + val x : float list + val y : 'b + method f : 'a -> unit + method g : 'b + end +|}];; class ['a, 'b] e () y = object inherit ['a, 'b] M'.c 1 y end;; +[%%expect{| +class ['a, 'b] e : + unit -> + 'b -> + object + constraint 'a = int -> bool + val x : float list + val y : 'b + method f : 'a -> unit + method g : 'b + end +|}];; (new M.c 3 "a")#g;; +[%%expect{| +- : string = "a" +|}];; (new d () 10)#g;; +[%%expect{| +- : int = 10 +|}];; (new e () 7.1)#g;; +[%%expect{| +- : float = 7.1 +|}];; open M;; +[%%expect{| +|}];; (new c 5 true)#g;; +[%%expect{| +- : bool = true +|}];; (* #cl when cl is closed *) module M = struct class ['a] c () = object method f (x : 'a) = () end end;; +[%%expect{| +module M : sig class ['a] c : unit -> object method f : 'a -> unit end end +|}];; module M' = (M : sig class ['a] c : unit -> object method f : 'a -> unit end end);; +[%%expect{| +module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end +|}];; fun x -> (x :> 'a #M.c);; +[%%expect{| +- : ('a #M.c as 'b) -> 'b = <fun> +|}];; fun x -> (x :> 'a #M'.c);; +[%%expect{| +- : ('a #M'.c as 'b) -> 'b = <fun> +|}];; class ['a] c (x : 'b #c) = object end;; +[%%expect{| +class ['a] c : 'a #c -> object end +|}];; class ['a] c (x : 'b #c) = object end;; +[%%expect{| +class ['a] c : 'a #c -> object end +|}];; (* Computation order *) class c () = object method f = 1 end and d () = object method f = 2 end;; +[%%expect{| +class c : unit -> object method f : int end +and d : unit -> object method f : int end +|}];; class e () = object inherit c () inherit d () end;; +[%%expect{| +class e : unit -> object method f : int end +|}];; (new e ())#f;; +[%%expect{| +- : int = 2 +|}];; class c () = object val x = - true val y = -. () end;; +[%%expect{| +Line _, characters 30-34: + class c () = object val x = - true val y = -. () end;; + ^^^^ +Error: This expression has type bool but an expression was expected of type + int +|}];; class c () = object method f = 1 method g = 1 method h = 1 end;; +[%%expect{| +class c : unit -> object method f : int method g : int method h : int end +|}];; class d () = object method h = 2 method i = 2 method j = 2 end;; +[%%expect{| +class d : unit -> object method h : int method i : int method j : int end +|}];; class e () = object method f = 3 inherit c () @@ -158,11 +403,34 @@ class e () = object inherit d () method j = 3 end;; +[%%expect{| +class e : + unit -> + object + method f : int + method g : int + method h : int + method i : int + method j : int + end +|}];; let e = new e ();; +[%%expect{| +val e : e = <obj> +|}];; e#f, e#g, e#h, e#i, e#j;; +[%%expect{| +- : int * int * int * int * int = (1, 3, 2, 2, 3) +|}];; class c a = object val x = 1 val y = 1 val z = 1 val a = a end;; +[%%expect{| +class c : 'a -> object val a : 'a val x : int val y : int val z : int end +|}];; class d b = object val z = 2 val t = 2 val u = 2 val b = b end;; +[%%expect{| +class d : 'a -> object val b : 'a val t : int val u : int val z : int end +|}];; class e () = object val x = 3 inherit c 5 @@ -178,8 +446,56 @@ class e () = object method a = a method b = b end;; +[%%expect{| +Line _, characters 10-13: + inherit c 5 + ^^^ +Warning 13: the following instance variables are overridden by the class c : + x +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +Line _, characters 6-7: + val y = 3 + ^ +Warning 13: the instance variable y is overridden. +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +Line _, characters 10-13: + inherit d 7 + ^^^ +Warning 13: the following instance variables are overridden by the class d : + t z +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +Line _, characters 6-7: + val u = 3 + ^ +Warning 13: the instance variable u is overridden. +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +class e : + unit -> + object + val a : int + val b : int + val t : int + val u : int + val x : int + val y : int + val z : int + method a : int + method b : int + method t : int + method u : int + method x : int + method y : int + method z : int + end +|}];; let e = new e ();; +[%%expect{| +val e : e = <obj> +|}];; e#x, e#y, e#z, e#t, e#u, e#a, e#b;; +[%%expect{| +- : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7) +|}];; class c (x : int) (y : int) = object val x = x @@ -187,13 +503,35 @@ class c (x : int) (y : int) = object method x = x method y = y end;; +[%%expect{| +class c : + int -> + int -> object val x : int val y : int method x : int method y : int end +|}];; class d x y = object inherit c x y end;; +[%%expect{| +class d : + int -> + int -> object val x : int val y : int method x : int method y : int end +|}];; let c = new c 1 2 in c#x, c#y;; +[%%expect{| +- : int * int = (1, 2) +|}];; let d = new d 1 2 in d#x, d#y;; +[%%expect{| +- : int * int = (1, 2) +|}];; (* Parameters which does not appear in the object type *) class ['a] c (x : 'a) = object end;; +[%%expect{| +class ['a] c : 'a -> object end +|}];; new c;; +[%%expect{| +- : 'a -> 'a c = <fun> +|}];; (* Private variables *) (* @@ -201,22 +539,49 @@ module type M = sig class c : unit -> object val x : int end class d : unit -> object inherit c val private x : int val x : bool end end;; +[%%expect{| +foo +|}];; class c (x : int) = val private mutable x = x method get = x method set y = x <- y end;; +[%%expect{| +foo +|}];; let c = new c 5;; +[%%expect{| +foo +|}];; c#get;; +[%%expect{| +foo +|}];; c#set 7; c#get;; +[%%expect{| +foo +|}];; class c () = val x = 1 val y = 1 method c = x end;; +[%%expect{| +foo +|}];; class d () = inherit c () val private x method d = x end;; +[%%expect{| +foo +|}];; class e () = val x = 2 val y = 2 inherit d () method x = x method y = y end;; +[%%expect{| +foo +|}];; let e = new e () in e#x, e#y, e#c, e#d;; +[%%expect{| +foo +|}];; *) (* Forgotten variables in interfaces *) @@ -232,109 +597,292 @@ module M : method xc = x end end;; +[%%expect{| +module M : sig class c : unit -> object method xc : int end end +|}];; class d () = object val x = 2 method xd = x inherit M.c () end;; +[%%expect{| +class d : unit -> object val x : int method xc : int method xd : int end +|}];; let d = new d () in d#xc, d#xd;; +[%%expect{| +- : int * int = (1, 2) +|}];; class virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; +[%%expect{| +Line _, characters 0-153: + class virtual ['a] matrix (sz, init : int * 'a) = object + val m = Array.make_matrix sz sz init + method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) + end.. +Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > + but is used with type < m : 'a array array; .. > +|}];; class c () = object method m = new c () end;; +[%%expect{| +class c : unit -> object method m : c end +|}];; (new c ())#m;; +[%%expect{| +- : c = <obj> +|}];; module M = struct class c () = object method m = new c () end end;; +[%%expect{| +module M : sig class c : unit -> object method m : c end end +|}];; (new M.c ())#m;; +[%%expect{| +- : M.c = <obj> +|}];; type uu = A of int | B of (<leq: 'a> as 'a);; +[%%expect{| +type uu = A of int | B of (< leq : 'a > as 'a) +|}];; class virtual c () = object (_ : 'a) method virtual m : 'a end;; +[%%expect{| +class virtual c : unit -> object ('a) method virtual m : 'a end +|}];; module S = (struct let f (x : #c) = x end : sig val f : (#c as 'a) -> 'a end);; +[%%expect{| +module S : sig val f : (#c as 'a) -> 'a end +|}];; module S = (struct let f (x : #c) = x end : sig val f : #c -> #c end);; +[%%expect{| +Line _, characters 12-43: + ............struct + let f (x : #c) = x + end...... +Error: Signature mismatch: + Modules do not match: + sig val f : (#c as 'a) -> 'a end + is not included in + sig val f : #c -> #c end + Values do not match: + val f : (#c as 'a) -> 'a + is not included in + val f : #c -> #c +|}];; module M = struct type t = int class t () = object end end;; +[%%expect{| +Line _, characters 37-38: + module M = struct type t = int class t () = object end end;; + ^ +Error: Multiple definition of the type name t. + Names must be unique in a given structure or signature. +|}];; fun x -> (x :> < m : 'a -> 'a > as 'a);; +[%%expect{| +- : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun> +|}];; fun x -> (x : int -> bool :> 'a -> 'a);; +[%%expect{| +Line _, characters 9-38: + fun x -> (x : int -> bool :> 'a -> 'a);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int +|}];; fun x -> (x : int -> bool :> int -> int);; +[%%expect{| +Line _, characters 9-40: + fun x -> (x : int -> bool :> int -> int);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int +|}];; fun x -> (x : < > :> < .. >);; +[%%expect{| +- : < > -> < > = <fun> +|}];; fun x -> (x : < .. > :> < >);; +[%%expect{| +- : < .. > -> < > = <fun> +|}];; let x = ref [];; +[%%expect{| +val x : '_weak2 list ref = {contents = []} +|}];; module F(X : sig end) = struct type t = int let _ = (x : < m : t> list ref) end;; +[%%expect{| +module F : functor (X : sig end) -> sig type t = int end +|}];; x;; +[%%expect{| +- : < m : int > list ref = {contents = []} +|}];; type 'a t;; +[%%expect{| +type 'a t +|}];; fun (x : 'a t as 'a) -> ();; +[%%expect{| +Line _, characters 9-19: + fun (x : 'a t as 'a) -> ();; + ^^^^^^^^^^ +Error: This alias is bound to type 'a t but is used as an instance of type 'a + The type variable 'a occurs inside 'a t +|}];; fun (x : 'a t) -> (x : 'a); ();; +[%%expect{| +Line _, characters 19-20: + fun (x : 'a t) -> (x : 'a); ();; + ^ +Error: This expression has type 'a t but an expression was expected of type + 'a + The type variable 'a occurs inside 'a t +|}];; type 'a t = < x : 'a >;; +[%%expect{| +type 'a t = < x : 'a > +|}];; fun (x : 'a t as 'a) -> ();; +[%%expect{| +- : ('a t as 'a) -> unit = <fun> +|}];; fun (x : 'a t) -> (x : 'a); ();; +[%%expect{| +Line _, characters 18-26: + fun (x : 'a t) -> (x : 'a); ();; + ^^^^^^^^ +Warning 10: this expression should have type unit. +- : ('a t as 'a) t -> unit = <fun> +|}];; class ['a] c () = object constraint 'a = < .. > -> unit method m = (fun x -> () : 'a) end;; +[%%expect{| +class ['a] c : + unit -> + object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end +|}];; class ['a] c () = object constraint 'a = unit -> < .. > method m (f : 'a) = f () end;; +[%%expect{| +class ['a] c : + unit -> + object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end +|}];; class c () = object (self) method private m = 1 method n = self#m end;; +[%%expect{| +class c : unit -> object method private m : int method n : int end +|}];; class d () = object (self) inherit c () method o = self#m end;; +[%%expect{| +class d : + unit -> object method private m : int method n : int method o : int end +|}];; let x = new d () in x#n, x#o;; +[%%expect{| +- : int * int = (1, 1) +|}];; class c () = object method virtual m : int method private m = 1 end;; +[%%expect{| +class c : unit -> object method m : int end +|}];; (* Marshaling (cf. PR#5436) *) let r = ref 0;; +[%%expect{| +val r : int ref = {contents = 0} +|}];; let id o = Oo.id o - !r;; +[%%expect{| +val id : < .. > -> int = <fun> +|}];; r := Oo.id (object end);; +[%%expect{| +- : unit = () +|}];; id (object end);; +[%%expect{| +- : int = 1 +|}];; id (object end);; +[%%expect{| +- : int = 2 +|}];; let o = object end in let s = Marshal.to_string o [] in let o' : < > = Marshal.from_string s 0 in let o'' : < > = Marshal.from_string s 0 in (id o, id o', id o'');; +[%%expect{| +- : int * int * int = (3, 4, 5) +|}];; let o = object val x = 33 method m = x end in let s = Marshal.to_string o [Marshal.Closures] in let o' : <m:int> = Marshal.from_string s 0 in let o'' : <m:int> = Marshal.from_string s 0 in (id o, id o', id o'', o#m, o'#m);; +[%%expect{| +- : int * int * int * int * int = (6, 7, 8, 33, 33) +|}];; let o = object val x = 33 val y = 44 method m = x end in let s = Marshal.to_string (o,o) [Marshal.Closures] in let (o1, o2) : (<m:int> * <m:int>) = Marshal.from_string s 0 in let (o3, o4) : (<m:int> * <m:int>) = Marshal.from_string s 0 in (id o, id o1, id o2, id o3, id o4, o#m, o1#m);; +[%%expect{| +- : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) +|}];; (* Recursion (cf. PR#5291) *) class a = let _ = new b in object end and b = let _ = new a in object end;; +[%%expect{| +Line _, characters 10-37: + class a = let _ = new b in object end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed +|}];; class a = let _ = new a in object end;; +[%%expect{| +Line _, characters 10-37: + class a = let _ = new a in object end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed +|}];; diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference deleted file mode 100644 index ba027f1de8..0000000000 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ /dev/null @@ -1,317 +0,0 @@ - -# - : < x : int > -> - < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > -= <fun> -# class ['a] c : unit -> object constraint 'a = int method f : int c end -and ['a] d : unit -> object constraint 'a = int method f : int c end -# Characters 230-271: - ....and d () = object - inherit ['a] c () - end.. -Error: Some type variables are unbound in this type: - class d : unit -> object method f : 'a -> unit end - The method f has type 'a -> unit where 'a is unbound -# class virtual c : unit -> object end -and ['a] d : - unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end -# class ['a] c : unit -> object constraint 'a = int end -and ['a] d : unit -> object constraint 'a = int #c end -# * class ['a] c : - 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end -# - : ('a c as 'a) -> 'a = <fun> -# * Characters 128-176: - class x () = object - method virtual f : int - end.. -Error: This class should be virtual. The following methods are undefined : f -# Characters 144-152: - class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end - ^^^^^^^^ -Error: This pattern cannot match self: it only matches values of type - < f : int > -# Characters 32-110: - class ['a] c () = object - constraint 'a = int - method f x = (x : bool c) - end.. -Error: The abbreviation c is used with parameters bool c - which are incompatible with constraints int c -# class ['a, 'b] c : - unit -> - object - constraint 'a = int -> 'c - constraint 'b = 'a * < x : 'b > * 'c * 'd - method f : 'a -> 'b -> unit - end -# class ['a, 'b] d : - unit -> - object - constraint 'a = int -> 'c - constraint 'b = 'a * < x : 'b > * 'c * 'd - method f : 'a -> 'b -> unit - end -# val x : '_weak1 list ref = {contents = []} -# Characters 0-50: - class ['a] c () = object - method f = (x : 'a) - end.. -Error: The type of this class, - class ['a] c : - unit -> object constraint 'a = '_weak1 list ref method f : 'a end, - contains type variables that cannot be generalized -# Characters 21-53: - type 'a c = <f : 'a c; g : 'a d> - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: In the definition of d, type int c should be 'a c -# type 'a c = < f : 'a c; g : 'a d > -and 'a d = < f : 'a c > -# type 'a c = < f : 'a c > -and 'a d = < f : int c > -# Characters 22-39: - and 'a t = 'a t u;; (* fails since 4.04 *) - ^^^^^^^^^^^^^^^^^ -Error: The definition of t contains a cycle: - 'a t u -# Characters 15-32: - and 'a t = 'a t u;; - ^^^^^^^^^^^^^^^^^ -Error: The type abbreviation t is cyclic -# type 'a u = 'a -# Characters 0-18: - type t = t u * t u;; - ^^^^^^^^^^^^^^^^^^ -Error: The type abbreviation t is cyclic -# type t = < x : 'a > as 'a -# type 'a u = 'a -# - : t -> t u -> bool = <fun> -# - : t -> t u -> bool = <fun> -# module M : - sig - class ['a, 'b] c : - int -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end - end -# module M' : - sig - class virtual ['a, 'b] c : - int -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end - end -# class ['a, 'b] d : - unit -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end -# class ['a, 'b] e : - unit -> - 'b -> - object - constraint 'a = int -> bool - val x : float list - val y : 'b - method f : 'a -> unit - method g : 'b - end -# - : string = "a" -# - : int = 10 -# - : float = 7.1 -# # - : bool = true -# module M : sig class ['a] c : unit -> object method f : 'a -> unit end end -# module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end -# - : ('a #M.c as 'b) -> 'b = <fun> -# - : ('a #M'.c as 'b) -> 'b = <fun> -# class ['a] c : 'a #c -> object end -# class ['a] c : 'a #c -> object end -# class c : unit -> object method f : int end -and d : unit -> object method f : int end -# class e : unit -> object method f : int end -# - : int = 2 -# Characters 30-34: - class c () = object val x = - true val y = -. () end;; - ^^^^ -Error: This expression has type bool but an expression was expected of type - int -# class c : unit -> object method f : int method g : int method h : int end -# class d : unit -> object method h : int method i : int method j : int end -# class e : - unit -> - object - method f : int - method g : int - method h : int - method i : int - method j : int - end -# val e : e = <obj> -# - : int * int * int * int * int = (1, 3, 2, 2, 3) -# class c : 'a -> object val a : 'a val x : int val y : int val z : int end -# class d : 'a -> object val b : 'a val t : int val u : int val z : int end -# Characters 42-45: - inherit c 5 - ^^^ -Warning 13: the following instance variables are overridden by the class c : - x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 52-53: - val y = 3 - ^ -Warning 13: the instance variable y is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 80-83: - inherit d 7 - ^^^ -Warning 13: the following instance variables are overridden by the class d : - t z -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 90-91: - val u = 3 - ^ -Warning 13: the instance variable u is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -class e : - unit -> - object - val a : int - val b : int - val t : int - val u : int - val x : int - val y : int - val z : int - method a : int - method b : int - method t : int - method u : int - method x : int - method y : int - method z : int - end -# val e : e = <obj> -# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7) -# class c : - int -> - int -> object val x : int val y : int method x : int method y : int end -# class d : - int -> - int -> object val x : int val y : int method x : int method y : int end -# - : int * int = (1, 2) -# - : int * int = (1, 2) -# class ['a] c : 'a -> object end -# - : 'a -> 'a c = <fun> -# * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end -# class d : unit -> object val x : int method xc : int method xd : int end -# - : int * int = (1, 2) -# Characters 1-154: - class virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.make_matrix sz sz init - method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) - end.. -Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > - but is used with type < m : 'a array array; .. > -# class c : unit -> object method m : c end -# - : c = <obj> -# module M : sig class c : unit -> object method m : c end end -# - : M.c = <obj> -# type uu = A of int | B of (< leq : 'a > as 'a) -# class virtual c : unit -> object ('a) method virtual m : 'a end -# module S : sig val f : (#c as 'a) -> 'a end -# Characters 12-43: - ............struct - let f (x : #c) = x - end...... -Error: Signature mismatch: - Modules do not match: - sig val f : (#c as 'a) -> 'a end - is not included in - sig val f : #c -> #c end - Values do not match: - val f : (#c as 'a) -> 'a - is not included in - val f : #c -> #c -# Characters 38-39: - module M = struct type t = int class t () = object end end;; - ^ -Error: Multiple definition of the type name t. - Names must be unique in a given structure or signature. -# - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun> -# Characters 10-39: - fun x -> (x : int -> bool :> 'a -> 'a);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type int -> bool is not a subtype of int -> int - Type bool is not a subtype of int -# Characters 9-40: - fun x -> (x : int -> bool :> int -> int);; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type int -> bool is not a subtype of int -> int - Type bool is not a subtype of int -# - : < > -> < > = <fun> -# - : < .. > -> < > = <fun> -# val x : '_weak2 list ref = {contents = []} -# module F : functor (X : sig end) -> sig type t = int end -# - : < m : int > list ref = {contents = []} -# type 'a t -# Characters 9-19: - fun (x : 'a t as 'a) -> ();; - ^^^^^^^^^^ -Error: This alias is bound to type 'a t but is used as an instance of type 'a - The type variable 'a occurs inside 'a t -# Characters 19-20: - fun (x : 'a t) -> (x : 'a); ();; - ^ -Error: This expression has type 'a t but an expression was expected of type - 'a - The type variable 'a occurs inside 'a t -# type 'a t = < x : 'a > -# - : ('a t as 'a) -> unit = <fun> -# Characters 18-26: - fun (x : 'a t) -> (x : 'a); ();; - ^^^^^^^^ -Warning 10: this expression should have type unit. -- : ('a t as 'a) t -> unit = <fun> -# class ['a] c : - unit -> - object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end -# class ['a] c : - unit -> - object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end -# class c : unit -> object method private m : int method n : int end -# class d : - unit -> object method private m : int method n : int method o : int end -# - : int * int = (1, 1) -# class c : unit -> object method m : int end -# val r : int ref = {contents = 0} -# val id : < .. > -> int = <fun> -# - : unit = () -# - : int = 1 -# - : int = 2 -# - : int * int * int = (3, 4, 5) -# - : int * int * int * int * int = (6, 7, 8, 33, 33) -# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) -# Characters 42-69: - class a = let _ = new b in object end - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This kind of recursive class expression is not allowed -# Characters 11-38: - class a = let _ = new a in object end;; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This kind of recursive class expression is not allowed -# diff --git a/testsuite/tests/typing-objects/dummy.ml b/testsuite/tests/typing-objects/dummy.ml new file mode 100644 index 0000000000..f0be9e9bff --- /dev/null +++ b/testsuite/tests/typing-objects/dummy.ml @@ -0,0 +1,177 @@ +(* TEST + * expect +*) + +class virtual child1 parent = + object + method private parent = parent + end + +and virtual child2 = + object(_ : 'self) + constraint 'parent = < previous: 'self option; .. > + method private virtual parent: 'parent + end + +[%%expect{| +class virtual child1 : 'a -> object method private parent : 'a end +and virtual child2 : + object ('a) + method private virtual parent : < previous : 'a option; .. > + end +|}] + +class virtual child1' parent = + object + method private parent = parent + end + +and virtual child2' = + object(_ : 'self) + constraint 'parent = < previous: 'self option; .. > + method private virtual parent: 'parent + end + +and foo = object(self) + method previous = None + method child = + object + inherit child1' self + inherit child2' + end +end;; + +[%%expect{| +Line _, characters 22-26: + inherit child1' self + ^^^^ +Error: This expression has type < child : 'a; previous : 'b option; .. > + but an expression was expected of type 'c + Self type cannot escape its class +|}] + +(* Whether we have [class foo1] or [let foo1] doesn't change a thing. *) +class foo1 = object(self) + method previous = None + method child = + object + inherit child1 self + inherit child2 + end +end;; +[%%expect{| +class foo1 : object method child : child2 method previous : child2 option end +|}] + +class nested = object + method obj = object(self) + method previous = None + method child () = + object + inherit child1 self + inherit child2 + end + end +end;; +[%%expect{| +class nested : + object + method obj : < child : unit -> child2; previous : child2 option > + end +|}] + +class just_to_see = object(self) + method previous = None + method child = + let o = + object + inherit child1 self + inherit child2 + end + in + o +end;; +[%%expect{| +class just_to_see : + object method child : child2 method previous : child2 option end +|}] + +class just_to_see2 = object + method obj = object(self) + method previous = None + method child = + let o = + object + inherit child1 self + inherit child2 + end + in + o + end +end;; +[%%expect{| +class just_to_see2 : + object method obj : < child : child2; previous : child2 option > end +|}] + +type gadt = Not_really_though : gadt + +class just_to_see3 = object(self) + method previous = None + method child Not_really_though = + object + inherit child1 self + inherit child2 + end +end;; +[%%expect{| +type gadt = Not_really_though : gadt +class just_to_see3 : + object method child : gadt -> child2 method previous : child2 option end +|}] + +class leading_up_to = object(self : 'a) + method previous : 'a option = None + method child = + object + inherit child1 self + inherit child2 + end +end;; +[%%expect{| +Line _, characters 4-65: + ....object + inherit child1 self + inherit child2 + end +Error: Cannot close type of object literal: + < child : '_weak1; previous : 'a option; _.. > as 'a + it has been unified with the self type of a class that is not yet + completely defined. +|}] + +class assertion_failure = object(self : 'a) + method previous : 'a option = None + method child = + object + inherit child1 self + inherit child2 + + method previous = None + method child = assert false + end +end;; +[%%expect{| +Line _, characters 4-129: + ....object + inherit child1 self + inherit child2 + + method previous = None + method child = assert false + end +Error: Cannot close type of object literal: + < child : '_weak2; previous : 'a option; _.. > as 'a + it has been unified with the self type of a class that is not yet + completely defined. +|}] diff --git a/testsuite/tests/typing-objects/ocamltests b/testsuite/tests/typing-objects/ocamltests index 89f578b082..fcada94998 100644 --- a/testsuite/tests/typing-objects/ocamltests +++ b/testsuite/tests/typing-objects/ocamltests @@ -1,3 +1,4 @@ +dummy.ml Exemples.ml open_in_classes.ml pr5545.ml diff --git a/testsuite/tests/typing-objects/open_in_classes.compilers.reference b/testsuite/tests/typing-objects/open_in_classes.compilers.reference deleted file mode 100644 index 111c3f6d7e..0000000000 --- a/testsuite/tests/typing-objects/open_in_classes.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -module M : sig type t = int val x : int end -class c : object method f : M.t end -class type ct = object method f : M.t end - diff --git a/testsuite/tests/typing-objects/open_in_classes.ml b/testsuite/tests/typing-objects/open_in_classes.ml index b5cf79f619..05f33b9192 100644 --- a/testsuite/tests/typing-objects/open_in_classes.ml +++ b/testsuite/tests/typing-objects/open_in_classes.ml @@ -1,5 +1,5 @@ (* TEST - * toplevel + * expect *) module M = struct @@ -7,15 +7,24 @@ module M = struct let x = 42 end ;; +[%%expect{| +module M : sig type t = int val x : int end +|}] class c = let open M in object method f : t = x end ;; +[%%expect{| +class c : object method f : M.t end +|}] class type ct = let open M in object method f : t end ;; +[%%expect{| +class type ct = object method f : M.t end +|}] diff --git a/testsuite/tests/typing-objects/pr5545.compilers.reference b/testsuite/tests/typing-objects/pr5545.compilers.reference deleted file mode 100644 index 29cbecd087..0000000000 --- a/testsuite/tests/typing-objects/pr5545.compilers.reference +++ /dev/null @@ -1,5 +0,0 @@ -type foo = int -class o : object method x : foo method y : int end -class o : object method x : foo method y : int end -class o : object method x : int method y : foo end - diff --git a/testsuite/tests/typing-objects/pr5545.ml b/testsuite/tests/typing-objects/pr5545.ml index e1c7e6dee3..8bb92adfda 100644 --- a/testsuite/tests/typing-objects/pr5545.ml +++ b/testsuite/tests/typing-objects/pr5545.ml @@ -1,14 +1,20 @@ (* TEST - * toplevel + * expect *) type foo = int;; +[%%expect{| +type foo = int +|}] class o = object(this) method x : foo = 10 method y : int = this # x end;; +[%%expect{| +class o : object method x : foo method y : int end +|}] class o = @@ -16,6 +22,9 @@ class o = method x : foo = 10 method y = (this # x : int) end;; +[%%expect{| +class o : object method x : foo method y : int end +|}] @@ -24,3 +33,6 @@ class o = method x : int = (10 : int) method y = (this # x : foo) end;; +[%%expect{| +class o : object method x : int method y : foo end +|}] diff --git a/testsuite/tests/typing-objects/pr5545.ml.principal.reference b/testsuite/tests/typing-objects/pr5545.ml.principal.reference deleted file mode 100644 index 4f7fda9661..0000000000 --- a/testsuite/tests/typing-objects/pr5545.ml.principal.reference +++ /dev/null @@ -1,6 +0,0 @@ - -# type foo = int -# class o : object method x : foo method y : int end -# class o : object method x : foo method y : int end -# class o : object method x : int method y : foo end -# diff --git a/testsuite/tests/typing-objects/pr5619_bad.compilers.reference b/testsuite/tests/typing-objects/pr5619_bad.compilers.reference deleted file mode 100644 index bb7557fe63..0000000000 --- a/testsuite/tests/typing-objects/pr5619_bad.compilers.reference +++ /dev/null @@ -1,17 +0,0 @@ -class type foo_t = object method foo : string end -type 'a name = Foo : foo_t name | Int : int name -class foo : - object method cast : foo_t name -> < foo : string > method foo : string end -Characters 22-176: - ..object(self) - method foo = "foo" - method cast: type a. a name -> a = - function - Foo -> (self :> foo_t) - | _ -> raise Exit - end -Error: The class type - object method cast : 'a name -> 'a method foo : string end - is not matched by the class type foo_t - The public method cast cannot be hidden - diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml b/testsuite/tests/typing-objects/pr5619_bad.ml index 73b8feb23a..bd23693ca0 100644 --- a/testsuite/tests/typing-objects/pr5619_bad.ml +++ b/testsuite/tests/typing-objects/pr5619_bad.ml @@ -1,5 +1,5 @@ (* TEST - * toplevel + * expect *) class type foo_t = @@ -12,6 +12,11 @@ type 'a name = | Int: int name ;; +[%%expect{| +class type foo_t = object method foo : string end +type 'a name = Foo : foo_t name | Int : int name +|}] + class foo = object(self) method foo = "foo" @@ -20,6 +25,10 @@ class foo = Foo -> (self :> <foo : string>) end ;; +[%%expect{| +class foo : + object method cast : foo_t name -> < foo : string > method foo : string end +|}] class foo: foo_t = object(self) @@ -30,3 +39,17 @@ class foo: foo_t = | _ -> raise Exit end ;; +[%%expect{| +Line _, characters 2-156: + ..object(self) + method foo = "foo" + method cast: type a. a name -> a = + function + Foo -> (self :> foo_t) + | _ -> raise Exit + end +Error: The class type + object method cast : 'a name -> 'a method foo : string end + is not matched by the class type foo_t + The public method cast cannot be hidden +|}] diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference deleted file mode 100644 index 0b50417a66..0000000000 --- a/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference +++ /dev/null @@ -1,18 +0,0 @@ - -# class type foo_t = object method foo : string end -type 'a name = Foo : foo_t name | Int : int name -# class foo : - object method cast : foo_t name -> < foo : string > method foo : string end -# Characters 22-176: - ..object(self) - method foo = "foo" - method cast: type a. a name -> a = - function - Foo -> (self :> foo_t) - | _ -> raise Exit - end -Error: The class type - object method cast : 'a name -> 'a method foo : string end - is not matched by the class type foo_t - The public method cast cannot be hidden -# diff --git a/testsuite/tests/typing-objects/pr5858.compilers.reference b/testsuite/tests/typing-objects/pr5858.compilers.reference deleted file mode 100644 index 05ceb35bce..0000000000 --- a/testsuite/tests/typing-objects/pr5858.compilers.reference +++ /dev/null @@ -1,6 +0,0 @@ -class type c = object end -Characters 29-30: - module type S = sig class c: c end;; - ^ -Error: The class type c is not yet completely defined - diff --git a/testsuite/tests/typing-objects/pr5858.ml b/testsuite/tests/typing-objects/pr5858.ml index 8089546505..4b92cb1de3 100644 --- a/testsuite/tests/typing-objects/pr5858.ml +++ b/testsuite/tests/typing-objects/pr5858.ml @@ -1,6 +1,16 @@ (* TEST - * toplevel + * expect *) class type c = object end;; +[%%expect{| +class type c = object end +|}] + module type S = sig class c: c end;; +[%%expect{| +Line _, characters 29-30: + module type S = sig class c: c end;; + ^ +Error: The class type c is not yet completely defined +|}] diff --git a/testsuite/tests/typing-objects/pr6123_bad.compilers.reference b/testsuite/tests/typing-objects/pr6123_bad.compilers.reference deleted file mode 100644 index 6b6d8fc0bc..0000000000 --- a/testsuite/tests/typing-objects/pr6123_bad.compilers.reference +++ /dev/null @@ -1,7 +0,0 @@ -Characters 279-283: - let args = List.map (fun ty -> new argument(self, ty)) args_ty in - ^^^^ -Error: This expression has type < arguments : 'a; .. > - but an expression was expected of type 'b - Self type cannot escape its class - diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml b/testsuite/tests/typing-objects/pr6123_bad.ml index f311f607b2..55a8b8b083 100644 --- a/testsuite/tests/typing-objects/pr6123_bad.ml +++ b/testsuite/tests/typing-objects/pr6123_bad.ml @@ -1,5 +1,5 @@ (* TEST - * toplevel + * expect *) class virtual name = @@ -25,3 +25,11 @@ object inherit name end ;; +[%%expect{| +Line _, characters 50-54: + let args = List.map (fun ty -> new argument(self, ty)) args_ty in + ^^^^ +Error: This expression has type < arguments : 'a; .. > + but an expression was expected of type 'b + Self type cannot escape its class +|}] diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference deleted file mode 100644 index eb3b05c083..0000000000 --- a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference +++ /dev/null @@ -1,8 +0,0 @@ - -# Characters 253-257: - let args = List.map (fun ty -> new argument(self, ty)) args_ty in - ^^^^ -Error: This expression has type < arguments : 'a; .. > - but an expression was expected of type 'b - Self type cannot escape its class -# diff --git a/testsuite/tests/typing-objects/pr6383.compilers.reference b/testsuite/tests/typing-objects/pr6383.compilers.reference deleted file mode 100644 index ae74071ba7..0000000000 --- a/testsuite/tests/typing-objects/pr6383.compilers.reference +++ /dev/null @@ -1,5 +0,0 @@ -Characters 37-42: - let f (x: #M.foo) = 0;; - ^^^^^ -Error: Unbound module M - diff --git a/testsuite/tests/typing-objects/pr6383.ml b/testsuite/tests/typing-objects/pr6383.ml index b47e382490..c039de87de 100644 --- a/testsuite/tests/typing-objects/pr6383.ml +++ b/testsuite/tests/typing-objects/pr6383.ml @@ -1,5 +1,11 @@ (* TEST - * toplevel + * expect *) let f (x: #M.foo) = 0;; +[%%expect{| +Line _, characters 11-16: + let f (x: #M.foo) = 0;; + ^^^^^ +Error: Unbound module M +|}];; diff --git a/testsuite/tests/typing-objects/pr6907_bad.compilers.reference b/testsuite/tests/typing-objects/pr6907_bad.compilers.reference deleted file mode 100644 index ffe1e02624..0000000000 --- a/testsuite/tests/typing-objects/pr6907_bad.compilers.reference +++ /dev/null @@ -1,9 +0,0 @@ -class type ['e] t = object ('a) method update : 'e -> 'a end -Characters 23-48: - class base : 'e -> ['e] t - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Some type variables are unbound in this type: - class base : 'e -> ['e] t - The method update has type 'e -> < update : 'a; .. > as 'a where 'e - is unbound - diff --git a/testsuite/tests/typing-objects/pr6907_bad.ml b/testsuite/tests/typing-objects/pr6907_bad.ml index 44a15fe1ea..afdfc971f1 100644 --- a/testsuite/tests/typing-objects/pr6907_bad.ml +++ b/testsuite/tests/typing-objects/pr6907_bad.ml @@ -1,11 +1,23 @@ (* TEST - * toplevel + * expect *) class type ['e] t = object('s) method update : 'e -> 's end;; +[%%expect{| +class type ['e] t = object ('a) method update : 'e -> 'a end +|}];; module type S = sig class base : 'e -> ['e] t end;; +[%%expect{| +Line _, characters 2-27: + class base : 'e -> ['e] t + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Some type variables are unbound in this type: + class base : 'e -> ['e] t + The method update has type 'e -> < update : 'a; .. > as 'a where 'e + is unbound +|}];; diff --git a/testsuite/tests/typing-objects/pr7711_ok.compilers.reference b/testsuite/tests/typing-objects/pr7711_ok.compilers.reference deleted file mode 100644 index d459f90497..0000000000 --- a/testsuite/tests/typing-objects/pr7711_ok.compilers.reference +++ /dev/null @@ -1,3 +0,0 @@ -type 'a r = 'a constraint 'a = < w : int -> int; .. > -class type virtual ct = object method virtual w : int -> int end - diff --git a/testsuite/tests/typing-objects/pr7711_ok.ml b/testsuite/tests/typing-objects/pr7711_ok.ml index 178e6ba137..7f188cf59b 100644 --- a/testsuite/tests/typing-objects/pr7711_ok.ml +++ b/testsuite/tests/typing-objects/pr7711_ok.ml @@ -1,9 +1,15 @@ (* TEST - * toplevel + * expect *) type 'a r = <w: int -> int; .. > as 'a;; +[%%expect{| +type 'a r = 'a constraint 'a = < w : int -> int; .. > +|}];; class type virtual ct = object('self) constraint 'self = 'not_self r end;; +[%%expect{| +class type virtual ct = object method virtual w : int -> int end +|}];; diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 939de3fe3d..c589bb5950 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -1631,11 +1631,23 @@ type 'a t = < m : 'a > constraint 'a = int |}] (* GPR#1142 *) +external reraise : exn -> 'a = "%reraise" + module M () = struct let f : 'a -> 'a = assert false let g : 'a -> 'a = raise Not_found + let h : 'a -> 'a = reraise Not_found + let i : 'a -> 'a = raise_notrace Not_found end [%%expect{| -module M : functor () -> sig val f : 'a -> 'a val g : 'a -> 'a end +external reraise : exn -> 'a = "%reraise" +module M : + functor () -> + sig + val f : 'a -> 'a + val g : 'a -> 'a + val h : 'a -> 'a + val i : 'a -> 'a + end |}] diff --git a/testsuite/tests/warnings/w47_inline.reference b/testsuite/tests/warnings/w47_inline.reference index edc2d48bcd..ce987c6a9d 100644 --- a/testsuite/tests/warnings/w47_inline.reference +++ b/testsuite/tests/warnings/w47_inline.reference @@ -1,15 +1,15 @@ -File "w47_inline.ml", line 13, characters 15-22: -Warning 47: illegal payload for attribute 'inlined'. +File "w47_inline.ml", line 5, characters 23-29: +Warning 47: illegal payload for attribute 'inline'. It must be either empty, 'always' or 'never' -File "w47_inline.ml", line 8, characters 23-29: +File "w47_inline.ml", line 6, characters 23-29: Warning 47: illegal payload for attribute 'inline'. It must be either empty, 'always' or 'never' File "w47_inline.ml", line 7, characters 23-29: Warning 47: illegal payload for attribute 'inline'. It must be either empty, 'always' or 'never' -File "w47_inline.ml", line 6, characters 23-29: +File "w47_inline.ml", line 8, characters 23-29: Warning 47: illegal payload for attribute 'inline'. It must be either empty, 'always' or 'never' -File "w47_inline.ml", line 5, characters 23-29: -Warning 47: illegal payload for attribute 'inline'. +File "w47_inline.ml", line 13, characters 15-22: +Warning 47: illegal payload for attribute 'inlined'. It must be either empty, 'always' or 'never' diff --git a/testsuite/tests/warnings/w53.reference b/testsuite/tests/warnings/w53.reference index 0f70e50406..e28ad24ca5 100644 --- a/testsuite/tests/warnings/w53.reference +++ b/testsuite/tests/warnings/w53.reference @@ -1,26 +1,26 @@ File "w53.ml", line 2, characters 4-5: Warning 32: unused value h. -File "w53.ml", line 31, characters 17-29: -Warning 53: the "ocaml.inline" attribute cannot appear in this context -File "w53.ml", line 30, characters 16-22: -Warning 53: the "inline" attribute cannot appear in this context -File "w53.ml", line 24, characters 0-39: -Warning 53: the "inline" attribute cannot appear in this context -File "w53.ml", line 23, characters 0-32: +File "w53.ml", line 2, characters 14-20: Warning 53: the "inline" attribute cannot appear in this context -File "w53.ml", line 15, characters 16-24: -Warning 53: the "tailcall" attribute cannot appear in this context -File "w53.ml", line 12, characters 14-28: -Warning 53: the "ocaml.tailcall" attribute cannot appear in this context -File "w53.ml", line 11, characters 14-22: -Warning 53: the "tailcall" attribute cannot appear in this context -File "w53.ml", line 9, characters 16-23: +File "w53.ml", line 3, characters 14-26: +Warning 53: the "ocaml.inline" attribute cannot appear in this context +File "w53.ml", line 5, characters 14-21: Warning 53: the "inlined" attribute cannot appear in this context File "w53.ml", line 6, characters 14-27: Warning 53: the "ocaml.inlined" attribute cannot appear in this context -File "w53.ml", line 5, characters 14-21: +File "w53.ml", line 9, characters 16-23: Warning 53: the "inlined" attribute cannot appear in this context -File "w53.ml", line 3, characters 14-26: -Warning 53: the "ocaml.inline" attribute cannot appear in this context -File "w53.ml", line 2, characters 14-20: +File "w53.ml", line 11, characters 14-22: +Warning 53: the "tailcall" attribute cannot appear in this context +File "w53.ml", line 12, characters 14-28: +Warning 53: the "ocaml.tailcall" attribute cannot appear in this context +File "w53.ml", line 15, characters 16-24: +Warning 53: the "tailcall" attribute cannot appear in this context +File "w53.ml", line 23, characters 0-32: +Warning 53: the "inline" attribute cannot appear in this context +File "w53.ml", line 24, characters 0-39: Warning 53: the "inline" attribute cannot appear in this context +File "w53.ml", line 30, characters 16-22: +Warning 53: the "inline" attribute cannot appear in this context +File "w53.ml", line 31, characters 17-29: +Warning 53: the "ocaml.inline" attribute cannot appear in this context diff --git a/testsuite/tests/warnings/w54.reference b/testsuite/tests/warnings/w54.reference index 39c5d75d43..fe1281bce7 100644 --- a/testsuite/tests/warnings/w54.reference +++ b/testsuite/tests/warnings/w54.reference @@ -1,8 +1,8 @@ -File "w54.ml", line 9, characters 0-43: +File "w54.ml", line 2, characters 33-39: Warning 54: the "inline" attribute is used more than once on this expression -File "w54.ml", line 5, characters 26-39: -Warning 54: the "ocaml.inlined" attribute is used more than once on this expression File "w54.ml", line 3, characters 51-63: Warning 54: the "ocaml.inline" attribute is used more than once on this expression -File "w54.ml", line 2, characters 33-39: +File "w54.ml", line 5, characters 26-39: +Warning 54: the "ocaml.inlined" attribute is used more than once on this expression +File "w54.ml", line 9, characters 0-43: Warning 54: the "inline" attribute is used more than once on this expression diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml index 7d8d05b836..497328cf03 100644 --- a/testsuite/tools/expect_test.ml +++ b/testsuite/tools/expect_test.ml @@ -253,8 +253,15 @@ let eval_expect_file _fname ~file_contents = try exec_phrase ppf phrase with exn -> - Location.report_exception ppf exn; - false) + let bt = Printexc.get_raw_backtrace () in + begin try Location.report_exception ppf exn + with _ -> + Format.fprintf ppf "Uncaught exception: %s\n%s\n" + (Printexc.to_string exn) + (Printexc.raw_backtrace_to_string bt) + end; + false + ) in Format.pp_print_flush ppf (); let len = Buffer.length buf in @@ -321,7 +328,7 @@ let process_expect_file fname = let correction = eval_expect_file fname ~file_contents in write_corrected ~file:corrected_fname ~file_contents correction -let repo_root = ref "" +let repo_root = ref None let main fname = Toploop.override_sys_argv @@ -329,8 +336,18 @@ let main fname = ~len:(Array.length Sys.argv - !Arg.current)); (* Ignore OCAMLRUNPARAM=b to be reproducible *) Printexc.record_backtrace false; - List.iter [ "stdlib" ] ~f:(fun s -> - Topdirs.dir_directory (Filename.concat !repo_root s)); + if not !Clflags.no_std_include then begin + match !repo_root with + | None -> () + | Some dir -> + (* If we pass [-repo-root], use the stdlib from inside the + compiler, not the installed one. We use + [Compenv.last_include_dirs] to make sure that the stdlib + directory is the last one. *) + Clflags.no_std_include := true; + Compenv.last_include_dirs := [Filename.concat dir "stdlib"] + end; + Compmisc.init_path false; Toploop.initialize_toplevel_env (); Sys.interactive := false; process_expect_file fname; @@ -381,6 +398,8 @@ module Options = Main_args.Make_bytetop_options (struct let _warn_help = Warnings.help_warnings let _dparsetree = set dump_parsetree let _dtypedtree = set dump_typedtree + let _dno_unique_ids = clear unique_ids + let _dunique_ids = set unique_ids let _dsource = set dump_source let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda @@ -397,8 +416,9 @@ end);; let args = Arg.align - ( [ "-repo-root", Arg.Set_string repo_root, - "<dir> root of the OCaml repository" + ( [ "-repo-root", Arg.String (fun s -> repo_root := Some s), + "<dir> root of the OCaml repository. This causes the tool to use \ + the stdlib from the current source tree rather than the installed one." ] @ Options.list ) diff --git a/tools/Makefile b/tools/Makefile index 281ec483ca..88c88e386f 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -128,6 +128,7 @@ clean:: CSLPROF=ocamlprof.cmo CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \ arg_helper.cmo clflags.cmo terminfo.cmo \ + build_path_prefix_map.cmo \ warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo @@ -178,7 +179,7 @@ $(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),) # Converter olabl/ocaml 2.99 to ocaml 3 OCAML299TO3= lexer299.cmo ocaml299to3.cmo -LIBRARY3= misc.cmo warnings.cmo location.cmo +LIBRARY3= misc.cmo warnings.cmo build_path_prefix_map.cmo location.cmo ocaml299to3: $(OCAML299TO3) $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) @@ -212,6 +213,7 @@ clean:: ADDLABELS_IMPORTS=misc.cmo config.cmo arg_helper.cmo clflags.cmo \ identifiable.cmo numbers.cmo terminfo.cmo \ + build_path_prefix_map.cmo \ warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo @@ -287,9 +289,9 @@ install:: DUMPOBJ=opnames.cmo dumpobj.cmo -$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \ - config.cmo ident.cmo opcodes.cmo bytesections.cmo \ - $(DUMPOBJ),) +$(call byte_and_opt,dumpobj,misc.cmo config.cmo identifiable.cmo \ + numbers.cmo arg_helper.cmo clflags.cmo tbl.cmo \ + ident.cmo opcodes.cmo bytesections.cmo $(DUMPOBJ),) make_opcodes.ml: make_opcodes.mll $(CAMLLEX) make_opcodes.mll diff --git a/tools/ci-build b/tools/ci-build index 9d91db3bfa..b6d6001caa 100755 --- a/tools/ci-build +++ b/tools/ci-build @@ -50,7 +50,7 @@ arch_error() { kill_task() { task=$1 - taskkill /f /im ${task} || true + taskkill /f /im ${task} /t || true } quote1 () { @@ -161,7 +161,7 @@ esac # On Windows, cleanup processes that may remain from previous run if $cleanup; then - tasks="tee ocamlrun program" + tasks="tee ocamlrun program ocamltest.byte ocamltest.opt" for task in ${tasks}; do kill_task ${task}.exe; done fi diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 0aeaf2ce1b..eed2935966 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -118,6 +118,8 @@ module Options = Main_args.Make_bytecomp_options (struct let _color s = option_with_arg "-color" s let _where = option "-where" let _nopervasives = option "-nopervasives" + let _dno_unique_ids = option "-dno-unique-ids" + let _dunique_ids = option "-dunique-ids" let _dsource = option "-dsource" let _dparsetree = option "-dparsetree" let _dtypedtree = option "-dtypedtree" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 4683cc0348..0f82e96f0d 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -146,6 +146,8 @@ module Options = Main_args.Make_optcomp_options (struct let _linscan = option "-linscan" let _nopervasives = option "-nopervasives" + let _dno_unique_ids = option "-dno-unique_ids" + let _dunique_ids = option "-dunique_ids" let _dsource = option "-dsource" let _dparsetree = option "-dparsetree" let _dtypedtree = option "-dtypedtree" diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index f199d44d95..7b6cbd4f5c 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -210,6 +210,8 @@ module Options = Main_args.Make_opttop_options (struct let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings + let _dno_unique_ids = clear unique_ids + let _dunique_ids = set unique_ids let _dsource = set dump_source let _dparsetree = set dump_parsetree let _dtypedtree = set dump_typedtree diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 083b427eee..4b1a06a60f 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -139,6 +139,8 @@ module Options = Main_args.Make_bytetop_options (struct let _warn_help = Warnings.help_warnings let _dparsetree = set dump_parsetree let _dtypedtree = set dump_typedtree + let _dno_unique_ids = clear unique_ids + let _dunique_ids = set unique_ids let _dsource = set dump_source let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda diff --git a/typing/btype.ml b/typing/btype.ml index f17cc7b5f0..9d08967576 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -44,7 +44,7 @@ let pivot_level = 2 * lowest_level - 1 let new_id = ref (-1) let newty2 level desc = - incr new_id; { desc; level; id = !new_id } + incr new_id; { desc; level; scope = None; id = !new_id } let newgenty desc = newty2 generic_level desc let newgenvar ?name () = newgenty (Tvar name) (* @@ -72,6 +72,7 @@ type change = Ctype of type_expr * type_desc | Ccompress of type_expr * type_desc * type_desc | Clevel of type_expr * int + | Cscope of type_expr * int option | Cname of (Path.t * type_expr list) option ref * (Path.t * type_expr list) option | Crow of row_field option ref * row_field option @@ -639,6 +640,7 @@ let undo_change = function Ctype (ty, desc) -> ty.desc <- desc | Ccompress (ty, desc, _) -> ty.desc <- desc | Clevel (ty, level) -> ty.level <- level + | Cscope (ty, scope) -> ty.scope <- scope | Cname (r, v) -> r := v | Crow (r, v) -> r := v | Ckind (r, v) -> r := v @@ -672,6 +674,9 @@ let link_type ty ty' = let set_level ty level = if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); ty.level <- level +let set_scope ty scope = + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + ty.scope <- scope let set_univar rty ty = log_change (Cuniv (rty, !rty)); rty := Some ty let set_name nm v = diff --git a/typing/btype.mli b/typing/btype.mli index aaa426a8ab..630f259841 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -198,6 +198,7 @@ val link_type: type_expr -> type_expr -> unit (* Set the desc field of [t1] to [Tlink t2], logging the old value if there is an active snapshot *) val set_level: type_expr -> int -> unit +val set_scope: type_expr -> int option -> unit val set_name: (Path.t * type_expr list) option ref -> (Path.t * type_expr list) option -> unit diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index fda1a4a56f..e0cc55ad45 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -182,7 +182,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_comments = Lexer.comments (); cmt_args = Sys.argv; cmt_sourcefile = sourcefile; - cmt_builddir = Sys.getcwd (); + cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); cmt_loadpath = !Config.load_path; cmt_source_digest = source_digest; cmt_initial_env = if need_to_clear_env then diff --git a/typing/ctype.ml b/typing/ctype.ml index 42569ca6b7..f24e46d15a 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -329,6 +329,7 @@ let close_object ty = match ty.desc with Tvar _ -> link_type ty (newty2 ty.level Tnil) + | Tfield(lab, _, _, _) when lab = dummy_method -> raise (Unify []) | Tfield(_, _, _, ty') -> close ty' | _ -> assert false in @@ -683,15 +684,8 @@ let forward_try_expand_once = (* Forward declaration *) module M = struct type t let _ = (x : t list ref) end (without this constraint, the type system would actually be unsound.) *) -let get_level env p = - try - match (Env.find_type p env).type_newtype_level with - | None -> Path.binding_time p - | Some (x, _) -> x - with - | Not_found -> - (* no newtypes in predef *) - Path.binding_time p +let get_path_scope p = + Path.binding_time p let rec normalize_package_path env p = let t = @@ -709,25 +703,55 @@ let rec normalize_package_path env p = normalize_package_path env (Path.Pdot (p1', s, n)) | _ -> p +let check_scope_escape level ty = + let rec aux ty = + let ty = repr ty in + if ty.level >= lowest_level then begin + ty.level <- pivot_level - ty.level; + begin match ty.scope with + Some lv -> + let var = newvar2 level in + if level < lv then raise (Unify [(ty,ty); (var, var)]) + | None -> () + end; + iter_type_expr aux ty + end + in + try + aux ty; + unmark_type ty + with Unify trace -> + let var = newvar2 level in + raise (Unify ((ty, ty) :: (var, var) :: trace)) + +let update_scope scope ty = + match scope with + | None -> () + | Some lvl -> + let ty = repr ty in + let scope = + match ty.scope with + | None -> lvl + | Some lvl' -> max lvl lvl' + in + if ty.level < scope then raise (Unify [(ty, newvar2 ty.level)]); + set_scope ty (Some scope) + let rec update_level env level expand ty = let ty = repr ty in if ty.level > level then begin - begin match Env.gadt_instance_level env ty with + begin match ty.scope with Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) | None -> () end; match ty.desc with - Tconstr(p, _tl, _abbrev) when level < get_level env p -> + Tconstr(p, _tl, _abbrev) when level < get_path_scope p -> (* Try first to replace an abbreviation by its expansion. *) begin try - (* if is_newtype env p then raise Cannot_expand; *) link_type ty (!forward_try_expand_once env ty); update_level env level expand ty with Cannot_expand -> - (* +++ Levels should be restored... *) - (* Format.printf "update_level: %i < %i@." level (get_level env p); *) - if level < get_level env p then raise (Unify [(ty, newvar2 level)]); - iter_type_expr (update_level env level expand) ty + raise (Unify [(ty, newvar2 level)]) end | Tconstr(_, _ :: _, _) when expand -> begin try @@ -736,20 +760,20 @@ let rec update_level env level expand ty = with Cannot_expand -> set_level ty level; iter_type_expr (update_level env level expand) ty - end + end | Tpackage (p, nl, tl) when level < Path.binding_time p -> let p' = normalize_package_path env p in if Path.same p p' then raise (Unify [(ty, newvar2 level)]); log_type ty; ty.desc <- Tpackage (p', nl, tl); update_level env level expand ty | Tobject(_, ({contents=Some(p, _tl)} as nm)) - when level < get_level env p -> + when level < get_path_scope p -> set_name nm None; update_level env level expand ty | Tvariant row -> let row = row_repr row in begin match row.row_name with - | Some (p, _tl) when level < get_level env p -> + | Some (p, _tl) when level < get_path_scope p -> log_type ty; ty.desc <- Tvariant {row with row_name = None} | _ -> () @@ -940,8 +964,8 @@ let abbreviations = ref (ref Mnil) (* partial: we may not wish to copy the non generic types before we call type_pat *) -let rec copy ?env ?partial ?keep_names ty = - let copy = copy ?env ?partial ?keep_names in +let rec copy ?partial ?keep_names ty = + let copy = copy ?partial ?keep_names in let ty = repr ty in match ty.desc with Tsubst ty -> ty @@ -962,14 +986,7 @@ let rec copy ?env ?partial ?keep_names ty = let desc = ty.desc in save_desc ty desc; let t = newvar() in (* Stub *) - begin match env with - Some env when Env.has_local_constraints env -> - begin match Env.gadt_instance_level env ty with - Some lv -> Env.add_gadt_instances env lv [t] - | None -> () - end - | _ -> () - end; + set_scope t ty.scope; ty.desc <- Tsubst t; t.desc <- begin match desc with @@ -1070,19 +1087,13 @@ let simple_copy t = copy t (**** Variants of instantiations ****) -let gadt_env env = - if Env.has_local_constraints env - then Some env - else None - -let instance ?partial env sch = - let env = gadt_env env in +let instance ?partial sch = let partial = match partial with None -> None | Some keep -> Some (compute_univars sch, keep) in - let ty = copy ?env ?partial sch in + let ty = copy ?partial sch in cleanup_types (); ty @@ -1091,16 +1102,15 @@ let instance_def sch = cleanup_types (); ty -let generic_instance env sch = +let generic_instance sch = let old = !current_level in current_level := generic_level; - let ty = instance env sch in + let ty = instance sch in current_level := old; ty -let instance_list env schl = - let env = gadt_env env in - let tyl = List.map (fun t -> copy ?env t) schl in +let instance_list schl = + let tyl = List.map (fun t -> copy t) schl in cleanup_types (); tyl @@ -1119,7 +1129,7 @@ let get_new_abstract_name s = if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else Printf.sprintf "%s%d" s index -let new_declaration newtype manifest = +let new_declaration expansion_scope manifest = { type_params = []; type_arity = 0; @@ -1127,7 +1137,8 @@ let new_declaration newtype manifest = type_private = Public; type_manifest = manifest; type_variance = []; - type_newtype_level = newtype; + type_is_newtype = true; + type_expansion_scope = expansion_scope; type_loc = Location.none; type_attributes = []; type_immediate = false; @@ -1137,9 +1148,9 @@ let new_declaration newtype manifest = let instance_constructor ?in_pattern cstr = begin match in_pattern with | None -> () - | Some (env, newtype_lev) -> + | Some (env, expansion_scope) -> let process existential = - let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + let decl = new_declaration (Some expansion_scope) None in let name = match repr existential with {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name @@ -1400,7 +1411,7 @@ let check_abbrev_env env = let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; match ty with - {desc = Tconstr (path, args, abbrev); level = level} -> + {desc = Tconstr (path, args, abbrev); level = level; scope} -> let lookup_abbrev = proper_abbrevs path args abbrev in begin match find_expans kind path !lookup_abbrev with Some ty' -> @@ -1415,6 +1426,14 @@ let expand_abbrev_gen kind find_type_expansion env ty = typing error *) () end; + begin try + update_scope scope ty'; + with Unify _ -> + (* XXX This should not happen. + However, levels are not correctly restored after a + typing error *) + () + end; let ty' = repr ty' in (* assert (ty != ty'); *) (* PR#7324 *) ty' @@ -1432,11 +1451,12 @@ let expand_abbrev_gen kind find_type_expansion env ty = (* For gadts, remember type as non exportable *) (* The ambiguous level registered for ty' should be the highest *) if !trace_gadt_instances then begin - match max lv (Env.gadt_instance_level env ty) with + match max lv ty.scope with None -> () | Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]); - Env.add_gadt_instances env lv [ty; ty'] + set_scope ty (Some lv); + set_scope ty' (Some lv) end; ty' end @@ -1481,14 +1501,6 @@ let rec try_expand_head try_once env ty = try try_expand_head try_once env ty' with Cannot_expand -> ty' -let try_expand_head try_once env ty = - let ty' = try_expand_head try_once env ty in - begin match Env.gadt_instance_level env ty' with - None -> () - | Some lv -> Env.add_gadt_instance_chain env lv ty - end; - ty' - (* Unsafe full expansion, may raise Unify. *) let expand_head_unif env ty = try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty @@ -1674,7 +1686,7 @@ let rec local_non_recursive_abbrev strict visited env p ty = begin try (* try expanding, since [p] could be hidden *) local_non_recursive_abbrev strict visited env p - (try_expand_head try_expand_once env ty) + (try_expand_head try_expand_once_opt env ty) with Cannot_expand -> let params = try (Env.find_type p' env).type_params @@ -1839,7 +1851,7 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f = let univar_pairs = ref [] (* assumption: [ty] is fully generalized. *) -let reify_univars env ty = +let reify_univars ty = let rec subst_univar vars ty = let ty = repr ty in if ty.level >= lowest_level then begin @@ -1857,7 +1869,7 @@ let reify_univars env ty = let vars = ref [] in subst_univar vars ty; unmark_type ty; - let ty = copy ~env ty in + let ty = copy ty in cleanup_types (); newty2 ty.level (Tpoly(repr ty, !vars)) @@ -1931,26 +1943,19 @@ let deep_occur t0 ty = information is indeed lost, but it probably does not worth it. *) -let newtype_level = ref None - -let get_newtype_level () = - match !newtype_level with - | None -> assert false - | Some x -> x - (* a local constraint can be added only if the rhs of the constraint does not contain any Tvars. They need to be removed using this function *) let reify env t = - let newtype_level = get_newtype_level () in let create_fresh_constr lev name = - let decl = new_declaration (Some (newtype_level, newtype_level)) None in let name = match name with Some s -> "$'"^s | _ -> "$" in let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let binding_time = Ident.current_time () in + let decl = new_declaration (Some binding_time) None in let new_env = Env.add_local_type path decl !env in let t = newty2 lev (Tconstr (path,[],ref Mnil)) in env := new_env; - t + t, binding_time in let visited = ref TypeSet.empty in let rec iterator ty = @@ -1959,9 +1964,9 @@ let reify env t = visited := TypeSet.add ty !visited; match ty.desc with Tvar o -> - let t = create_fresh_constr ty.level o in + let t, binding_time = create_fresh_constr ty.level o in link_type ty t; - if ty.level < newtype_level then + if ty.level < binding_time then raise (Unify [t, newvar2 ty.level]) | Tvariant r -> let r = row_repr r in @@ -1970,11 +1975,11 @@ let reify env t = let m = r.row_more in match m.desc with Tvar o -> - let t = create_fresh_constr m.level o in + let t, binding_time = create_fresh_constr m.level o in let row = {r with row_fields=[]; row_fixed=true; row_more = t} in link_type m (newty2 m.level (Tvariant row)); - if m.level < newtype_level then + if m.level < binding_time then raise (Unify [t, newvar2 m.level]) | _ -> assert false end; @@ -1990,14 +1995,14 @@ let reify env t = let is_newtype env p = try let decl = Env.find_type p env in - decl.type_newtype_level <> None && + decl.type_expansion_scope <> None && decl.type_kind = Type_abstract && decl.type_private = Public with Not_found -> false let non_aliasable p decl = (* in_pervasives p || (subsumed by in_current_module) *) - in_current_module p && decl.type_newtype_level = None + in_current_module p && not decl.type_is_newtype let is_instantiable env p = try @@ -2240,19 +2245,28 @@ let find_lowest_level ty = end in find ty; unmark_type ty; !lowest -let find_newtype_level env path = - try match (Env.find_type path env).type_newtype_level with - Some x -> x - | None -> raise Not_found - with Not_found -> let lev = Path.binding_time path in (lev, lev) +let find_expansion_scope env path = + match (Env.find_type path env).type_expansion_scope with + | Some x -> x + | None -> assert false + +let gadt_equations_level = ref None + +let get_gadt_equations_level () = + match !gadt_equations_level with + | None -> assert false + | Some x -> x let add_gadt_equation env source destination = + (* Format.eprintf "@[add_gadt_equation %s %a@]@." + (Path.name source) !Btype.print_raw destination; *) if local_non_recursive_abbrev !env source destination then begin let destination = duplicate_type destination in - let source_lev = find_newtype_level !env source in - let decl = new_declaration (Some source_lev) (Some destination) in - let newtype_level = get_newtype_level () in - env := Env.add_local_constraint source decl newtype_level !env; + let expansion_scope = + max (Path.binding_time source) (get_gadt_equations_level ()) + in + let decl = new_declaration (Some expansion_scope) (Some destination) in + env := Env.add_local_type source decl !env; cleanup_abbrev () end @@ -2283,7 +2297,7 @@ let nondep_instance env level id ty = if level = generic_level then duplicate_type ty else let old = !current_level in current_level := level; - let ty = instance env ty in + let ty = instance ty in current_level := old; ty @@ -2353,7 +2367,8 @@ let unify1_var env t1 t2 = let d1 = t1.desc in link_type t1 t2; try - update_level env t1.level t2 + update_level env t1.level t2; + update_scope t1.scope t2 with Unify _ as e -> t1.desc <- d1; raise e @@ -2380,6 +2395,7 @@ let rec unify (env:Env.t ref) t1 t2 = | (Tunivar _, Tunivar _) -> unify_univar t1 t2 !univar_pairs; update_level !env t1.level t2; + update_scope t1.scope t2; link_type t1 t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) when Path.same p1 p2 (* && actual_mode !env = Old *) @@ -2389,13 +2405,14 @@ let rec unify (env:Env.t ref) t1 t2 = && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) -> update_level !env t1.level t2; + update_scope t1.scope t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Env.has_local_constraints !env && is_newtype !env p1 && is_newtype !env p2 -> (* Do not use local constraints more than necessary *) begin try - if find_newtype_level !env p1 < find_newtype_level !env p2 then + if find_expansion_scope !env p1 > find_expansion_scope !env p2 then unify env t1 (try_expand_once !env t2) else unify env (try_expand_once !env t1) t2 @@ -2418,19 +2435,14 @@ and unify2 env t1 t2 = let t1' = expand_head_unif !env t1 in let t2' = expand_head_unif !env t2 in let lv = min t1'.level t2'.level in + let scope = max t1'.scope t2'.scope in update_level !env lv t2; update_level !env lv t1; + update_scope scope t2; + update_scope scope t1; if unify_eq t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in - if !trace_gadt_instances then begin - (* All types in chains already have the same ambiguity levels *) - let ilevel t = - match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in - let lv1 = ilevel t1 and lv2 = ilevel t2 in - if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else - if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1 - end; let t1, t2 = if !Clflags.principal && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then @@ -2471,7 +2483,7 @@ and unify3 env t1 t1' t2 t2' = | Expression -> occur !env t1' t2'; if is_self_type d1 (* PR#7711: do not abbreviate self type *) - then link_type t1' t2' + then link_type t1' t2' else link_type t1' t2 | Pattern -> add_type_equality t1' t2' @@ -2520,7 +2532,7 @@ and unify3 env t1 t1' t2 t2' = when is_instantiable !env path && is_instantiable !env path' && !generate_equations -> let source, destination = - if find_newtype_level !env path > find_newtype_level !env path' + if get_path_scope path > get_path_scope path' then path , t2' else path', t1' in @@ -2641,7 +2653,10 @@ and unify_fields env ty1 ty2 = (* Optimization *) (fun (n, k1, t1, k2, t2) -> unify_kind k1 k2; try - if !trace_gadt_instances then update_level !env va.level t1; + if !trace_gadt_instances then begin + update_level !env va.level t1; + update_scope va.scope t1 + end; unify env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), @@ -2731,6 +2746,7 @@ and unify_row env row1 row2 = else let ty = newgenty (Tvariant {row0 with row_fields = rest}) in update_level !env rm.level ty; + update_scope rm.scope ty; link_type rm ty in let md1 = rm1.desc and md2 = rm2.desc in @@ -2799,7 +2815,11 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | (tu::_, []) | ([], tu::_) -> occur_univar !env tu end; (* Is this handling of levels really principal? *) - List.iter (update_level !env (repr more).level) (tl1' @ tl2'); + List.iter (fun ty -> + let rm = repr more in + update_level !env rm.level ty; + update_scope rm.scope ty; + ) (tl1' @ tl2'); let e = ref None in let f1' = Reither(c1 || c2, tl1', m1 || m2, e) and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in @@ -2809,12 +2829,16 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | Rabsent, Rabsent -> () | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; - update_level !env (repr more).level t2; + let rm = repr more in + update_level !env rm.level t2; + update_scope rm.scope t2; (try List.iter (fun t1 -> unify env t1 t2) tl with exn -> e1 := None; raise exn) | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> set_row_field e2 f1; - update_level !env (repr more).level t1; + let rm = repr more in + update_level !env rm.level t1; + update_scope rm.scope t1; (try List.iter (unify env t1) tl with exn -> e2 := None; raise exn) | Reither(true, [], _, e1), Rpresent None when not fixed1 -> @@ -2836,16 +2860,16 @@ let unify env ty1 ty2 = undo_compress snap; raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)])) -let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = +let unify_gadt ~equations_level:lev (env:Env.t ref) ty1 ty2 = try univar_pairs := []; - newtype_level := Some lev; + gadt_equations_level := Some lev; set_mode_pattern ~generate:true ~injective:true (fun () -> unify env ty1 ty2); - newtype_level := None; + gadt_equations_level := None; TypePairs.clear unify_eq_set; with e -> - newtype_level := None; + gadt_equations_level := None; TypePairs.clear unify_eq_set; raise e @@ -2860,6 +2884,7 @@ let unify_var env t1 t2 = begin try occur env t1 t2; update_level env t1.level t2; + update_scope t1.scope t2; link_type t1 t2; reset_trace_gadt_instances reset_tracing; with Unify trace -> @@ -2946,6 +2971,7 @@ let filter_method env name priv ty = let ty1 = newvar () in let ty' = newobj ty1 in update_level env ty.level ty'; + update_scope ty.scope ty'; link_type ty ty'; filter_method_field env name priv ty1 | Tobject(f, _) -> @@ -3010,6 +3036,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = match (t1.desc, t2.desc) with (Tvar _, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1.level t2; + update_scope t1.scope t2; occur env t1 t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> @@ -3027,6 +3054,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = match (t1'.desc, t2'.desc) with (Tvar _, _) when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; + update_scope t1'.scope t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> @@ -3118,6 +3146,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) in moregen_occur env rm1.level ext; + update_scope rm1.scope ext; link_type rm1 ext | Tconstr _, Tconstr _ -> moregen inst_nongen type_pairs env rm1 rm2 @@ -3177,10 +3206,10 @@ let moregeneral env inst_nongen pat_sch subj_sch = then copied with [duplicate_type]. That way, its levels won't be changed. *) - let subj = duplicate_type (instance env subj_sch) in + let subj = duplicate_type (instance subj_sch) in current_level := generic_level; (* Duplicate generic variables *) - let patt = instance env pat_sch in + let patt = instance pat_sch in let res = try moregen inst_nongen (TypePairs.create 13) env patt subj; true with Unify _ -> false @@ -3519,7 +3548,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = | _ -> CM_Hide_public lab::err end in - if Concr.mem lab sign1.csig_concr then err + if lab = dummy_method || Concr.mem lab sign1.csig_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in @@ -4454,7 +4483,8 @@ let nondep_type_decl env mid id is_covariant decl = type_manifest = tm; type_private = priv; type_variance = decl.type_variance; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = decl.type_loc; type_attributes = decl.type_attributes; type_immediate = decl.type_immediate; diff --git a/typing/ctype.mli b/typing/ctype.mli index 1675636314..b71fe3e096 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -109,16 +109,21 @@ val limited_generalize: type_expr -> type_expr -> unit (* Only generalize some part of the type Make the remaining of the type non-generalizable *) -val instance: ?partial:bool -> Env.t -> type_expr -> type_expr +val check_scope_escape : int -> type_expr -> unit + (* [check_scope_escape lvl ty] ensures that [ty] could be raised + to the level [lvl] without any scope escape. + Raises [Unify] otherwise *) + +val instance: ?partial:bool -> type_expr -> type_expr (* Take an instance of a type scheme *) (* partial=None -> normal partial=false -> newvar() for non generic subterms partial=true -> newty2 ty.level Tvar for non generic subterms *) val instance_def: type_expr -> type_expr (* use defaults *) -val generic_instance: Env.t -> type_expr -> type_expr +val generic_instance: type_expr -> type_expr (* Same as instance, but new nodes at generic_level *) -val instance_list: Env.t -> type_expr list -> type_expr list +val instance_list: type_expr list -> type_expr list (* Take an instance of a list of type schemes *) val instance_constructor: ?in_pattern:Env.t ref * int -> @@ -166,7 +171,7 @@ val get_new_abstract_name : string -> string val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) -val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit +val unify_gadt: equations_level:int -> Env.t ref -> type_expr -> type_expr -> unit (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. *) val unify_var: Env.t -> type_expr -> type_expr -> unit @@ -196,7 +201,7 @@ val matches: Env.t -> type_expr -> type_expr -> bool (* Same as [moregeneral false], implemented using the two above functions and backtracking. Ignore levels *) -val reify_univars : Env.t -> Types.type_expr -> Types.type_expr +val reify_univars : Types.type_expr -> Types.type_expr (* Replaces all the variables of a type by a univar. *) type class_match_failure = diff --git a/typing/datarepr.ml b/typing/datarepr.ml index bce6ff212f..7bef64c9f2 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -85,7 +85,8 @@ let constructor_args priv cd_args cd_res path rep = type_private = priv; type_manifest = None; type_variance = List.map (fun _ -> Variance.full) type_params; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = Location.none; type_attributes = []; type_immediate = false; @@ -176,7 +177,7 @@ let extension_descr path_ext ext = cstr_inlined; } -let none = {desc = Ttuple []; level = -1; id = -1} +let none = {desc = Ttuple []; level = -1; scope = None; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; diff --git a/typing/env.ml b/typing/env.ml index 3833b79ad0..0039860aab 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -451,7 +451,6 @@ type t = { functor_args: unit Ident.tbl; summary: summary; local_constraints: type_declaration PathMap.t; - gadt_instances: (int * TypeSet.t ref) list; flags: int; } @@ -494,7 +493,6 @@ and functor_components = { let copy_local ~from env = { env with local_constraints = from.local_constraints; - gadt_instances = from.gadt_instances; flags = from.flags } let same_constr = ref (fun _ _ _ -> assert false) @@ -534,7 +532,7 @@ let empty = { modules = IdTbl.empty; modtypes = IdTbl.empty; components = IdTbl.empty; classes = IdTbl.empty; cltypes = IdTbl.empty; - summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = []; + summary = Env_empty; local_constraints = PathMap.empty; flags = 0; functor_args = Ident.empty; } @@ -1058,7 +1056,7 @@ let find_type_expansion path env = | Some body when decl.type_private = Public || decl.type_kind <> Type_abstract || Btype.has_constr_row body -> - (decl.type_params, body, may_map snd decl.type_newtype_level) + (decl.type_params, body, decl.type_expansion_scope) (* The manifest type of Private abstract data types without private row are still considered unknown to the type system. Hence, this case is caught by the following clause that also handles @@ -1074,7 +1072,8 @@ let find_type_expansion_opt path env = match decl.type_manifest with (* The manifest type of Private abstract data types can still get an approximation using their manifest type. *) - | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) + | Some body -> + (decl.type_params, body, decl.type_expansion_scope) | _ -> raise Not_found let find_modtype_expansion path env = @@ -1537,52 +1536,6 @@ let find_shadowed_types path env = (find_shadowed (fun env -> env.types) (fun comps -> comps.comp_types) path env) - -(* GADT instance tracking *) - -let add_gadt_instance_level lv env = - {env with - gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} - -let is_Tlink = function {desc = Tlink _} -> true | _ -> false - -let gadt_instance_level env t = - let rec find_instance = function - [] -> None - | (lv, r) :: rem -> - if TypeSet.exists is_Tlink !r then - (* Should we use set_typeset ? *) - r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; - if TypeSet.mem t !r then Some lv else find_instance rem - in find_instance env.gadt_instances - -let add_gadt_instances env lv tl = - let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in - (* Format.eprintf "Added"; - List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; - Format.eprintf "@."; *) - set_typeset r (List.fold_right TypeSet.add tl !r) - -(* Only use this after expand_head! *) -let add_gadt_instance_chain env lv t = - let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in - let rec add_instance t = - let t = repr t in - if not (TypeSet.mem t !r) then begin - (* Format.eprintf "@ %a" !Btype.print_raw t; *) - set_typeset r (TypeSet.add t !r); - match t.desc with - Tconstr (p, _, memo) -> - may add_instance (find_expans Private p !memo) - | _ -> () - end - in - (* Format.eprintf "Added chain"; *) - add_instance t - (* Format.eprintf "@." *) - (* Expand manifest module type names at the top of the given module type *) let rec scrape_alias env ?path mty = @@ -1984,14 +1937,6 @@ let add_local_type path info env = { env with local_constraints = PathMap.add path info env.local_constraints } -let add_local_constraint path info elv env = - match info with - {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> - (* elv is the expansion level, lv is the definition level *) - let info = {info with type_newtype_level = Some (lv, elv)} in - add_local_type path info env - | _ -> assert false - (* Insertion of bindings by name *) diff --git a/typing/env.mli b/typing/env.mli index 78eb3bab40..a5a3ea644e 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -91,10 +91,6 @@ val get_required_globals: unit -> Ident.t list val add_required_global: Ident.t -> unit val has_local_constraints: t -> bool -val add_gadt_instance_level: int -> t -> t -val gadt_instance_level: t -> type_expr -> int option -val add_gadt_instances: t -> int -> type_expr list -> unit -val add_gadt_instance_chain: t -> int -> type_expr -> unit (* Lookup by long identifiers *) @@ -151,7 +147,6 @@ val add_module_declaration: ?arg:bool -> check:bool -> Ident.t -> val add_modtype: Ident.t -> modtype_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t val add_cltype: Ident.t -> class_type_declaration -> t -> t -val add_local_constraint: Path.t -> type_declaration -> int -> t -> t val add_local_type: Path.t -> type_declaration -> t -> t (* Insertion of all fields of a signature. *) diff --git a/typing/ident.ml b/typing/ident.ml index c5556cb833..d510fa8c23 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -85,7 +85,11 @@ let print ppf i = match i.stamp with | 0 -> fprintf ppf "%s!" i.name | -1 -> fprintf ppf "%s#" i.name - | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "") + | n -> + let stampstr = + if !Clflags.unique_ids then Printf.sprintf "/%i" n else "" + in + fprintf ppf "%s%s%s" i.name stampstr (if global i then "g" else "") type 'a tbl = Empty diff --git a/typing/mtype.ml b/typing/mtype.ml index 4df7487621..1d99f64fdf 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -185,11 +185,11 @@ let enrich_typedecl env p id decl = decl else let orig_ty = - Ctype.reify_univars env + Ctype.reify_univars (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil))) in let new_ty = - Ctype.reify_univars env + Ctype.reify_univars (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil))) in let env = Env.add_type ~check:false id decl env in diff --git a/typing/oprint.ml b/typing/oprint.ml index 614a78b3b7..9ae5ad48ca 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -596,9 +596,12 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private print_record_decl lbls | Otyp_sum constrs -> + let variants fmt constrs = + if constrs = [] then fprintf fmt "|" else + fprintf fmt "%a" (print_list print_out_constr + (fun ppf -> fprintf ppf "@ | ")) constrs in fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs + print_private td.otype_private variants constrs | Otyp_open -> fprintf ppf " =%a .." print_private td.otype_private diff --git a/typing/parmatch.ml b/typing/parmatch.ml index edce111c21..adc758626c 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -1920,7 +1920,8 @@ let contains_extension pat = (* Build an untyped or-pattern from its expected type *) let ppat_of_type env ty = match pats_of_type env ty with - [{pat_desc = Tpat_any}] -> + | [] -> raise Empty + | [{pat_desc = Tpat_any}] -> (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) | pats -> Conv.conv (orify_many pats) diff --git a/typing/parmatch.mli b/typing/parmatch.mli index 7371230efc..4426795c9e 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -81,6 +81,9 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : pattern -> constructor_tag list -> constructor_description list + +(** [ppat_of_type] builds an untyped or-pattern from its expected type. + May raise [Empty] when [type_expr] is an empty variant *) val ppat_of_type : Env.t -> type_expr -> Parsetree.pattern * diff --git a/typing/predef.ml b/typing/predef.ml index 53ac7f21be..3ad76d9fc5 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -133,7 +133,8 @@ let decl_abstr = type_private = Asttypes.Public; type_manifest = None; type_variance = []; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; diff --git a/typing/printtyp.ml b/typing/printtyp.ml index b96d8b2118..37c9be0639 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1284,7 +1284,8 @@ let filter_rem_sig item rem = let dummy = { type_params = []; type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = None; type_loc = Location.none; + type_is_newtype = false; type_expansion_scope = None; + type_loc = Location.none; type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; diff --git a/typing/subst.ml b/typing/subst.ml index fb5f901945..ad9d8d6863 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -131,7 +131,7 @@ let reset_for_saving () = new_id := -1 let newpersty desc = decr new_id; - { desc = desc; level = generic_level; id = !new_id } + { desc = desc; level = generic_level; scope = None; id = !new_id } (* ensure that all occurrences of 'Tvar None' are physically shared *) let tvar_none = Tvar None @@ -299,7 +299,8 @@ let type_declaration s decl = end; type_private = decl.type_private; type_variance = decl.type_variance; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = loc s decl.type_loc; type_attributes = attrs s decl.type_attributes; type_immediate = decl.type_immediate; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index b31cbe609f..595ff13b93 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -75,6 +75,7 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string + | Closing_self_type of type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -252,13 +253,12 @@ let enter_met_env ?check loc lab kind ty val_env met_env par_env = (* Enter an instance variable in the environment *) let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = - let instance = Ctype.instance val_env in let (id, virt) = try let (id, mut', virt', ty') = Vars.find lab !vars in if mut' <> mut then raise (Error(loc, val_env, Mutability_mismatch(lab, mut))); - Ctype.unify val_env (instance ty) (instance ty'); + Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty'); (if not inh then Some id else None), (if virt' = Concrete then virt' else virt) with @@ -783,6 +783,15 @@ and class_field_aux self_loc cl_num self_type meths vars | Pcf_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) +(* N.B. the self type of a final object type doesn't contain a dummy method in + the beginning. + We only explicitely add a dummy method to class definitions (and class (type) + declarations)), which are later removed (made absent) by [final_decl]. + + If we ever find a dummy method in a final object self type, it means that + somehow we've unified the self type of the object with the self type of a not + yet finished class. + When this happens, we cannot close the object type and must error. *) and class_structure cl_num final val_env met_env loc { pcstr_self = spat; pcstr_fields = str } = (* Environment for substructures *) @@ -791,11 +800,15 @@ and class_structure cl_num final val_env met_env loc (* Location of self. Used for locations of self arguments *) let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in - (* Self type, with a dummy method preventing it from being closed/escaped. *) - let self_type = Ctype.newvar () in - Ctype.unify val_env - (Ctype.filter_method val_env dummy_method Private self_type) - (Ctype.newty (Ttuple [])); + let self_type = Ctype.newobj (Ctype.newvar ()) in + + (* Adding a dummy method to the self type prevents it from being closed / + escaping. + That isn't needed for objects though. *) + if not final then + Ctype.unify val_env + (Ctype.filter_method val_env dummy_method Private self_type) + (Ctype.newty (Ttuple [])); (* Private self is used for private method calls *) let private_self = if final then Ctype.newvar () else self_type in @@ -852,7 +865,10 @@ and class_structure cl_num final val_env met_env loc if final then begin (* Unify private_self and a copy of self_type. self_type will not be modified after this point *) - Ctype.close_object self_type; + begin try Ctype.close_object self_type + with Ctype.Unify [] -> + raise(Error(loc, val_env, Closing_self_type self_type)) + end; let mets = virtual_methods {sign with csig_self = self_type} in let vals = Vars.fold @@ -863,13 +879,7 @@ and class_structure cl_num final val_env met_env loc let self_methods = List.fold_right (fun (lab,kind,ty) rem -> - if lab = dummy_method then - (* allow public self and private self to be unified *) - match Btype.field_kind_repr kind with - Fvar r -> Btype.set_kind r Fabsent; rem - | _ -> rem - else - Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem))) + Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem))) methods (Ctype.newty Tnil) in begin try Ctype.unify val_env private_self @@ -885,7 +895,7 @@ and class_structure cl_num final val_env met_env loc (* Generalize the spine of methods accessed through self *) Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms; meths := - Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms; + Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms; (* But keep levels correct on the type of self *) Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms end; @@ -1010,7 +1020,7 @@ and class_expr_aux cl_num val_env met_env scl = {exp_desc = Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); exp_loc = Location.none; exp_extra = []; - exp_type = Ctype.instance val_env' vd.val_type; + exp_type = Ctype.instance vd.val_type; exp_attributes = []; (* check *) exp_env = val_env'}) end @@ -1165,7 +1175,7 @@ and class_expr_aux cl_num val_env met_env scl = {exp_desc = Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); exp_loc = Location.none; exp_extra = []; - exp_type = Ctype.instance val_env vd.val_type; + exp_type = Ctype.instance vd.val_type; exp_attributes = []; exp_env = val_env; } @@ -1283,7 +1293,8 @@ let temp_abbrev loc env id arity = type_private = Public; type_manifest = Some ty; type_variance = Misc.replicate_list Variance.full arity; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = loc; type_attributes = []; (* or keep attrs from the class decl? *) type_immediate = false; @@ -1402,7 +1413,9 @@ let class_infos define_class kind begin let ty = Ctype.self_type obj_type in Ctype.hide_private_methods ty; - Ctype.close_object ty; + begin try Ctype.close_object ty + with Ctype.Unify [] -> raise(Error(cl.pci_loc, env, Closing_self_type ty)) + end; begin try List.iter2 (Ctype.unify env) obj_params obj_params' with Ctype.Unify _ -> @@ -1447,7 +1460,7 @@ let class_infos define_class kind begin try Ctype.unify env (constructor_type constr obj_type) - (Ctype.instance env constr_type) + (Ctype.instance constr_type) with Ctype.Unify trace -> raise(Error(cl.pci_loc, env, Constructor_type_mismatch (cl.pci_name.txt, trace))) @@ -1518,7 +1531,7 @@ let class_infos define_class kind cty_new = begin match cl.pci_virt with | Virtual -> None - | Concrete -> Some (Ctype.instance env constr_type) + | Concrete -> Some (Ctype.instance constr_type) end; cty_loc = cl.pci_loc; cty_attributes = cl.pci_attributes; @@ -1531,7 +1544,8 @@ let class_infos define_class kind type_private = Public; type_manifest = Some obj_ty; type_variance = List.map (fun _ -> Variance.full) obj_params; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = cl.pci_loc; type_attributes = []; (* or keep attrs from cl? *) type_immediate = false; @@ -1550,7 +1564,8 @@ let class_infos define_class kind type_private = Public; type_manifest = Some cl_ty; type_variance = List.map (fun _ -> Variance.full) cl_params; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = cl.pci_loc; type_attributes = []; (* or keep attrs from cl? *) type_immediate = false; @@ -1570,6 +1585,21 @@ let final_decl env define_class raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) end; + (* make the dummy method disappear *) + begin + let self_type = Ctype.self_type clty.cty_type in + let methods, _ = + Ctype.flatten_fields + (Ctype.object_fields (Ctype.expand_head env self_type)) + in + List.iter (fun (lab,kind,_) -> + if lab = dummy_method then + match Btype.field_kind_repr kind with + Fvar r -> Btype.set_kind r Fabsent + | _ -> () + ) methods + end; + List.iter Ctype.generalize clty.cty_params; generalize_class_type true clty.cty_type; Misc.may Ctype.generalize clty.cty_new; @@ -1768,7 +1798,7 @@ let rec unify_parents env ty cl = begin try let decl = Env.find_class p env in let _, body = Ctype.find_cltype_for_path env decl.cty_path in - Ctype.unify env ty (Ctype.instance env body) + Ctype.unify env ty (Ctype.instance body) with Not_found -> () | _exn -> assert false @@ -1976,6 +2006,12 @@ let report_error env ppf = function | Duplicate (kind, name) -> fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" kind name + | Closing_self_type self -> + fprintf ppf + "@[Cannot close type of object literal:@ %a@,\ + it has been unified with the self type of a class that is not yet@ \ + completely defined.@]" + Printtyp.type_scheme self let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 1735bf9e9a..b9a0d2107c 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -117,6 +117,7 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string + | Closing_self_type of type_expr exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/typecore.ml b/typing/typecore.ml index 06176efd5a..c3ce511bc5 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -81,7 +81,6 @@ type error = | Not_a_packed_module of type_expr | Recursive_local_constraint of (type_expr * type_expr) list | Unexpected_existential - | Unqualified_gadt_pattern of Path.t * string | Invalid_interval | Invalid_for_loop_index | No_value_clauses @@ -99,6 +98,7 @@ type error = | Illegal_letrec_expr | Illegal_class_expr | Unbound_value_missing_rec of Longident.t * Location.t + | Empty_pattern exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -409,22 +409,16 @@ let unify_exp_types loc env ty expected_ty = raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* level at which to create the local type declarations *) -let newtype_level = ref None -let get_newtype_level () = - match !newtype_level with +let gadt_equations_level = ref None +let get_gadt_equations_level () = + match !gadt_equations_level with Some y -> y | None -> assert false let unify_pat_types_gadt loc env ty ty' = - let newtype_level = - match !newtype_level with - | None -> assert false - | Some x -> x - in - try - unify_gadt ~newtype_level env ty ty' + try unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty' with - Unify trace -> + | Unify trace -> raise(Error(loc, !env, Pattern_type_clash(trace))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) @@ -728,8 +722,7 @@ end) = struct in List.find check_type lbls - let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ()) - ?scope lid env opath lbls = + let disambiguate ?(warn=Location.prerr_warning) ?scope lid env opath lbls = let scope = match scope with None -> lbls | Some l -> l in let lbl = match opath with None -> @@ -771,7 +764,6 @@ end) = struct lbl with Not_found -> try let lbl = lookup_from_type env tpath lid in - check_lk tpath lbl; if in_env lbl then begin let s = Printtyp.string_of_path tpath in @@ -1062,7 +1054,11 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env pat_env = !env } in if explode > 0 then - let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in + let (sp, constrs, labels) = + try + Parmatch.ppat_of_type !env expected_ty + with Parmatch.Empty -> raise (Error (loc, !env, Empty_pattern)) + in if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else if mode = Inside_or then raise Need_backtrack else let explode = @@ -1183,15 +1179,10 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env [Hashtbl.find constrs s, (fun () -> ())] | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt in - let check_lk tpath constr = - if constr.cstr_generalized then - raise (Error (lid.loc, !env, - Unqualified_gadt_pattern (tpath, constr.cstr_name))) - in let constr = wrap_disambiguate "This variant pattern is expected to have" (mk_expected expected_ty) - (Constructor.disambiguate lid !env opath ~check_lk) candidates + (Constructor.disambiguate lid !env opath) candidates in if constr.cstr_generalized && constrs <> None && mode = Inside_or then raise Need_backtrack; @@ -1229,7 +1220,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = - instance_constructor ~in_pattern:(env, get_newtype_level ()) constr + instance_constructor ~in_pattern:(env, get_gadt_equations_level ()) + constr in (* PR#7214: do not use gadt unification for toplevel lets *) if not constr.cstr_generalized || mode = Inside_or || no_existentials @@ -1410,7 +1402,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env if separate then begin end_def(); generalize_structure ty; - instance !env ty, instance !env ty + instance ty, instance ty end else ty, ty in unify_pat_types loc !env ty expected_ty; @@ -1455,16 +1447,16 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal) ?(explode=0) ?(lev=get_current_level()) env sp expected_ty = - newtype_level := Some lev; + gadt_equations_level := Some lev; try let r = type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels ~mode ~explode ~env sp expected_ty (fun x -> x) in iter_pattern (fun p -> p.pat_env <- !env) r; - newtype_level := None; + gadt_equations_level := None; r with e -> - newtype_level := None; + gadt_equations_level := None; raise e @@ -1706,7 +1698,8 @@ let rec is_nonexpansive exp = is_nonexpansive exp | Texp_apply ( { exp_desc = Texp_ident (_, _, {val_kind = - Val_prim {Primitive.prim_name = "%raise"}}) }, + Val_prim {Primitive.prim_name = + ("%raise" | "%reraise" | "%raise_notrace")}}) }, [Nolabel, Some e]) -> is_nonexpansive e | _ -> false @@ -2585,22 +2578,27 @@ let contains_polymorphic_variant p = in try loop p; false with Exit -> true -let contains_gadt env p = - let rec loop env p = +let contains_gadt p = + let check p = + match p.pat_desc with + | Tpat_construct (_, cd, _) when cd.cstr_generalized -> + raise Exit + | _ -> () + in + try iter_pattern check p; false with Exit -> true + +(* There are various things that we need to do in presence of GADT constructors + that aren't required if there are none. + However, because of disambiguation, we can't know for sure whether the + patterns contain some GADT constructors. So we conservatively assume that + any constructor might be a GADT constructor. *) +let may_contain_gadts p = + let rec loop p = match p.ppat_desc with - | Ppat_construct (lid, _) -> - begin try - let cstrs = Env.lookup_all_constructors lid.txt env in - List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit) - cstrs - with Not_found -> () - end; iter_ppat (loop env) p - | Ppat_open (lid,sub_p) -> - let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in - loop new_env sub_p - | _ -> iter_ppat (loop env) p + | Ppat_construct (_, _) -> raise Exit + | _ -> iter_ppat loop p in - try loop env p; false with Exit -> true + try loop p; false with Exit -> true let check_absent_variant env = iter_pattern @@ -2625,7 +2623,7 @@ let check_absent_variant env = let duplicate_ident_types caselist env = let caselist = - List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in + List.filter (fun {pc_lhs} -> may_contain_gadts pc_lhs) caselist in Env.copy_types (all_idents_cases caselist) env (* Getting proper location of already typed expressions. @@ -2705,7 +2703,7 @@ and type_expect_ let with_explanation = with_explanation explanation in let rue exp = with_explanation (fun () -> - unify_exp env (re exp) (instance env ty_expected)); + unify_exp env (re exp) (instance ty_expected)); exp in match sexp.pexp_desc with @@ -2766,7 +2764,7 @@ and type_expect_ Texp_ident(path, lid, desc) end; exp_loc = loc; exp_extra = []; - exp_type = instance env desc.val_type; + exp_type = instance desc.val_type; exp_attributes = sexp.pexp_attributes; exp_env = env } end @@ -2807,7 +2805,7 @@ and type_expect_ exp_env = env } | Pexp_let(Nonrecursive, [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) - when contains_gadt env spat -> + when may_contain_gadts spat -> (* TODO: allow non-empty attributes? *) type_expect ?in_function env {sexp with @@ -2894,7 +2892,7 @@ and type_expect_ lower_args (ty::seen) ty_fun | _ -> () in - let ty = instance env funct.exp_type in + let ty = instance funct.exp_type in end_def (); wrap_trace_gadt_instances env (lower_args []) ty; begin_def (); @@ -2944,7 +2942,7 @@ and type_expect_ re { exp_desc = Texp_match(arg, val_cases, exn_cases, eff_cases, partial); exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_try(sbody, caselist) -> @@ -2993,7 +2991,7 @@ and type_expect_ type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes | Pexp_variant(l, sarg) -> (* Keep sharing *) - let ty_expected0 = instance env ty_expected in + let ty_expected0 = instance ty_expected in begin try match sarg, expand_head env ty_expected, expand_head env ty_expected0 with | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> @@ -3058,7 +3056,7 @@ and type_expect_ let decl = Env.find_type p' env in begin_def (); let ty = - newconstr p' (instance_list env decl.type_params) in + newconstr p' (instance_list decl.type_params) in end_def (); generalize_structure ty; ty, op @@ -3075,7 +3073,7 @@ and type_expect_ (fun x -> x) in with_explanation (fun () -> - unify_exp_types loc env ty_record (instance env ty_expected)); + unify_exp_types loc env ty_record (instance ty_expected)); (* type_label_a_list returns a list of labels sorted by lbl_pos *) (* note: check_duplicates would better be implemented in @@ -3120,7 +3118,7 @@ and type_expect_ in None, label_definitions | Some exp -> - let ty_exp = instance env exp.exp_type in + let ty_exp = instance exp.exp_type in let unify_kept lbl = let _, ty_arg1, ty_res1 = instance_label false lbl in unify_exp_types exp.exp_loc env ty_exp ty_res1; @@ -3132,7 +3130,7 @@ and type_expect_ let _, ty_arg2, ty_res2 = instance_label false lbl in unify_exp_types loc env ty_arg1 ty_arg2; with_explanation (fun () -> - unify_exp_types loc env (instance env ty_expected) ty_res2); + unify_exp_types loc env (instance ty_expected) ty_res2); Kept (ty_arg1, lbl.lbl_mut) end in @@ -3161,7 +3159,7 @@ and type_expect_ extended_expression = opt_exp }; exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_field(srecord, lid) -> @@ -3200,7 +3198,7 @@ and type_expect_ re { exp_desc = Texp_array argl; exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> @@ -3280,7 +3278,7 @@ and type_expect_ if separate then begin end_def (); generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty) + (type_argument env sarg ty (instance ty), instance ty) end else (type_argument env sarg ty ty, ty) in @@ -3370,8 +3368,8 @@ and type_expect_ end_def (); generalize_structure ty; generalize_structure ty'; - (type_argument env sarg ty (instance env ty), - instance env ty', Some cty, cty') + (type_argument env sarg ty (instance ty), + instance ty', Some cty, cty') end else (type_argument env sarg ty ty, ty', Some cty, cty') in @@ -3421,7 +3419,7 @@ and type_expect_ let method_type = newvar () in let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in unify env obj_ty desc.val_type; - unify env res_ty (instance env typ); + unify env res_ty (instance typ); let exp = Texp_apply({exp_desc = Texp_ident(Path.Pident method_id, lid, @@ -3460,7 +3458,7 @@ and type_expect_ let typ = match repr typ with {desc = Tpoly (ty, [])} -> - instance env ty + instance ty | {desc = Tpoly (ty, tl); level = l} -> if !Clflags.principal && l <> generic_level then Location.prerr_warning loc @@ -3517,7 +3515,7 @@ and type_expect_ match desc.val_kind with Val_ivar (Mutable, cl_num) -> let newval = - type_expect env snewval (mk_expected (instance env desc.val_type)) + type_expect env snewval (mk_expected (instance desc.val_type)) in let (path_self, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env @@ -3565,7 +3563,7 @@ and type_expect_ begin try let (id, _, _, ty) = Vars.find lab.txt !vars in (Path.Pident id, lab, - type_expect env snewval (mk_expected (instance env ty))) + type_expect env snewval (mk_expected (instance ty))) with Not_found -> let vars = Vars.fold (fun var _ li -> var::li) !vars [] in @@ -3631,7 +3629,7 @@ and type_expect_ let exp_type = match cond.exp_desc with | Texp_construct(_, {cstr_name="false"}, _) -> - instance env ty_expected + instance ty_expected | _ -> instance_def Predef.type_unit in @@ -3651,7 +3649,7 @@ and type_expect_ re { exp_desc = Texp_lazy arg; exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env; } @@ -3679,12 +3677,12 @@ and type_expect_ end; if sty <> None then with_explanation (fun () -> - unify_exp_types loc env (instance env ty) (instance env ty_expected)); + unify_exp_types loc env (instance ty) (instance ty_expected)); let exp = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = type_expect env sbody (mk_expected ty') in - { exp with exp_type = instance env ty } + { exp with exp_type = instance ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); @@ -3697,7 +3695,7 @@ and type_expect_ let exp = type_expect env sbody (mk_expected ty'') in end_def (); check_univars env false "method" exp ty_expected vars; - { exp with exp_type = instance env ty } + { exp with exp_type = instance ty } | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in @@ -3712,7 +3710,6 @@ and type_expect_ (* remember original level *) begin_def (); (* Create a fake abstract type declaration for name. *) - let level = get_current_level () in let decl = { type_params = []; type_arity = 0; @@ -3720,7 +3717,8 @@ and type_expect_ type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = Some (level, level); + type_is_newtype = true; + type_expansion_scope = None; type_loc = loc; type_attributes = []; type_immediate = false; @@ -3758,7 +3756,7 @@ and type_expect_ (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } | Pexp_pack m -> let (p, nl) = - match Ctype.expand_head env (instance env ty_expected) with + match Ctype.expand_head env (instance ty_expected) with {desc = Tpackage (p, nl, _tl)} -> if !Clflags.principal && (Ctype.expand_head env ty_expected).level < Btype.generic_level @@ -3814,7 +3812,7 @@ and type_expect_ | Pexp_unreachable -> re { exp_desc = Texp_unreachable; exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env } @@ -3822,12 +3820,12 @@ and type_function ?in_function loc attrs env ty_expected_explained l caselist = let { ty = ty_expected; explanation } = ty_expected_explained in let (loc_fun, ty_fun) = match in_function with Some p -> p - | None -> (loc, instance env ty_expected) + | None -> (loc, instance ty_expected) in let separate = !Clflags.principal || Env.has_local_constraints env in if separate then begin_def (); let (ty_arg, ty_res) = - try filter_arrow env (instance env ty_expected) l + try filter_arrow env (instance ty_expected) l with Unify _ -> match expand_head env ty_expected with {desc = Tarrow _} as ty -> @@ -3867,7 +3865,7 @@ and type_function ?in_function loc attrs env ty_expected_explained l caselist = re { exp_desc = Texp_function { arg_label = l; param; cases; partial; }; exp_loc = loc; exp_extra = []; - exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); + exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); exp_attributes = attrs; exp_env = env } @@ -4157,7 +4155,7 @@ and type_label_exp create env loc ty_expected generalize_structure ty_res end; begin try - unify env (instance_def ty_res) (instance env ty_expected) + unify env (instance_def ty_res) (instance ty_expected) with Unify trace -> raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace))) end; @@ -4175,7 +4173,7 @@ and type_label_exp create env loc ty_expected raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = type_argument env sarg ty_arg (instance env ty_arg) in + let arg = type_argument env sarg ty_arg (instance ty_arg) in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; @@ -4193,7 +4191,7 @@ and type_label_exp create env loc ty_expected with Error (_, _, Less_general _) as e -> raise e | _ -> raise exn (* In case of failure return the first error *) in - (lid, label, {arg with exp_type = instance env arg.exp_type}) + (lid, label, {arg with exp_type = instance arg.exp_type}) and type_argument ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -4223,7 +4221,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = let rec make_args args ty_fun = match (expand_head env ty_fun).desc with | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> - let ty = option_none (instance env ty_arg) sarg.pexp_loc in + let ty = option_none (instance ty_arg) sarg.pexp_loc in make_args ((l, Some ty) :: args) ty_fun | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' @@ -4233,8 +4231,8 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = let args, ty_fun', simple_res = make_args [] texp.exp_type in let warn = !Clflags.principal && (lv <> generic_level || (repr ty_fun').level <> generic_level) - and texp = {texp with exp_type = instance env texp.exp_type} - and ty_fun = instance env ty_fun' in + and texp = {texp with exp_type = instance texp.exp_type} + and ty_fun = instance ty_fun' in if not (simple_res || no_labels ty_res) then begin unify_exp env texp ty_expected; texp @@ -4309,7 +4307,7 @@ and type_application env funct sargs = (function l, None -> l, None | l, Some f -> l, Some (f ())) (List.rev args), - instance env (result_type omitted ty_fun)) + instance (result_type omitted ty_fun)) | (l1, sarg1) :: sargl -> let (ty1, ty2) = let ty_fun = expand_head env ty_fun in @@ -4439,7 +4437,7 @@ and type_application env funct sargs = may_warn funct.exp_loc (Warnings.Without_principality "eliminated optional argument"); ignored := (l,ty,lv) :: !ignored; - Some (fun () -> option_none (instance env ty) Location.none) + Some (fun () -> option_none (instance ty) Location.none) end else begin may_warn funct.exp_loc (Warnings.Without_principality "commuted an argument"); @@ -4463,7 +4461,7 @@ and type_application env funct sargs = let is_ignore funct = match funct.exp_desc with Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) -> - (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel); + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true with Unify _ -> false) | _ -> false @@ -4472,7 +4470,7 @@ and type_application env funct sargs = (* Special case for ignore: avoid discarding warning *) [Nolabel, sarg] when is_ignore funct -> let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel + filter_arrow env (instance funct.exp_type) Nolabel in let exp = type_expect env sarg (mk_expected ty_arg) in begin match (expand_head env exp.exp_type).desc with @@ -4486,9 +4484,9 @@ and type_application env funct sargs = | _ -> let ty = funct.exp_type in if ignore_labels then - type_args [] [] ty (instance env ty) ty [] sargs + type_args [] [] ty (instance ty) ty [] sargs else - type_args [] [] ty (instance env ty) ty sargs [] + type_args [] [] ty (instance ty) ty sargs [] and type_construct env loc lid sarg ty_expected_explained attrs = let { ty = ty_expected; explanation } = ty_expected_explained in @@ -4531,18 +4529,18 @@ and type_construct env loc lid sarg ty_expected_explained attrs = generalize_structure ty_res; with_explanation explanation (fun () -> unify_exp env {texp with exp_type = instance_def ty_res} - (instance env ty_expected)); + (instance ty_expected)); end_def (); List.iter generalize_structure ty_args; generalize_structure ty_res; end; let ty_args0, ty_res = - match instance_list env (ty_res :: ty_args) with + match instance_list (ty_res :: ty_args) with t :: tl -> tl, t | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp env texp (instance env ty_expected); + if not separate then unify_exp env texp (instance ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected @@ -4595,19 +4593,22 @@ and type_statement ?explanation env sexp = end (* Typing of match cases *) +and check_scope_escape loc env level ty = + try Ctype.check_scope_escape level ty + with Unify trace -> + raise(Error(loc, env, Pattern_type_clash(trace))) and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = (* ty_arg is _fully_ generalized *) let patterns = List.map (fun {pc_lhs=p} -> p) caselist in let contains_polyvars = List.exists contains_polymorphic_variant patterns in - let erase_either = contains_polyvars && contains_variant_either ty_arg - and has_gadts = List.exists (contains_gadt env) patterns in -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) + let erase_either = contains_polyvars && contains_variant_either ty_arg in + let may_contain_gadts = List.exists may_contain_gadts patterns in let ty_arg = - if (has_gadts || erase_either) && not !Clflags.principal + if (may_contain_gadts || erase_either) && not !Clflags.principal then correct_levels ty_arg else ty_arg and ty_res, env = - if has_gadts && not !Clflags.principal then + if may_contain_gadts && not !Clflags.principal then correct_levels ty_res, duplicate_ident_types caselist env else ty_res, env in @@ -4622,22 +4623,21 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = | [{pc_lhs}] when is_var pc_lhs -> false | _ -> true in + let outer_level = get_current_level () in let init_env () = (* raise level for existentials *) begin_def (); Ident.set_current_time (get_current_level ()); let lev = Ident.current_time () in - Ctype.init_def (lev+1000); (* up to 1000 existentials *) - (lev, Env.add_gadt_instance_level lev env) + Ctype.init_def (lev+100000); (* up to 1000 existentials *) + lev in - let lev, env = - if has_gadts then init_env () else (get_current_level (), env) + let lev = + if may_contain_gadts then init_env () else get_current_level () in -(* if has_gadts then - Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) (* Do we need to propagate polymorphism *) let propagate = - !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level || + !Clflags.principal || may_contain_gadts || (repr ty_arg).level = generic_level || match caselist with [{pc_lhs}] when is_var pc_lhs -> false | _ -> true in @@ -4660,28 +4660,36 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = in if !Clflags.principal then begin_def (); (* propagation of pattern *) let scope = Some (Annot.Idef loc) in + begin_def (); + let ty_arg = instance ?partial:take_partial_instance ty_arg in + end_def (); + generalize_structure ty_arg; + let expected_ty_arg = instance ty_arg in let (pat, ext_env, force, unpacks) = - let ty_arg = instance ?partial:take_partial_instance env ty_arg in - type_pattern ~lev env pc_lhs scope ty_arg + type_pattern ~lev env pc_lhs scope expected_ty_arg in pattern_force := force @ !pattern_force; let pat = if !Clflags.principal then begin end_def (); iter_pattern (fun {pat_type=t} -> generalize_structure t) pat; - { pat with pat_type = instance ext_env pat.pat_type } + { pat with pat_type = instance pat.pat_type } end else pat in - (pat, (ext_env, unpacks))) + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape pat.pat_loc env outer_level ty_arg; + (pat, ty_arg, (ext_env, unpacks))) caselist in (* Unify all cases (delayed to keep it order-free) *) let ty_arg' = newvar () in let unify_pats ty = - List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty) - pat_env_list in + List.iter (fun (pat, pat_ty, _) -> + unify_pat_types pat.pat_loc env pat_ty ty + ) pat_env_list + in unify_pats ty_arg'; (* Check for polymorphic variants to close *) - let patl = List.map fst pat_env_list in + let patl = List.map (fun (pat, _, _) -> pat) pat_env_list in if List.exists has_variants patl then begin Parmatch.pressure_variants env patl; List.iter (iter_pattern finalize_variant) patl @@ -4689,7 +4697,7 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = (* `Contaminating' unifications start here *) List.iter (fun f -> f()) !pattern_force; (* Post-processing and generalization *) - if take_partial_instance <> None then unify_pats (instance env ty_arg); + if take_partial_instance <> None then unify_pats (instance ty_arg); if propagate then begin List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl; @@ -4701,15 +4709,15 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = let in_function = if List.length caselist = 1 then in_function else None in let pat_env_cont_list = match conts with - | None -> List.map (fun (pat, env) -> (pat, env, None)) pat_env_list + | None -> List.map (fun (pat, _, env) -> (pat, env, None)) pat_env_list | Some conts -> List.map2 - (fun (pat, env) cont -> (pat, env, cont)) + (fun (pat, _, env) cont -> (pat, env, cont)) pat_env_list conts in let cases = List.map2 - (fun (pat, (ext_env, unpacks), cont) {pc_lhs; pc_guard; pc_rhs} -> + (fun (pat, (ext_env, unpacks), cont) {pc_lhs=_; pc_guard; pc_rhs} -> let cont, ext_env' = match cont with | Some (id, desc) -> @@ -4724,11 +4732,11 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = let ty_res' = if !Clflags.principal then begin begin_def (); - let ty = instance ~partial:true env ty_res in + let ty = instance ~partial:true ty_res in end_def (); generalize_structure ty; ty end - else if contains_gadt env pc_lhs then correct_levels ty_res + else if contains_gadt pat then correct_levels ty_res else ty_res in (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_res'; *) @@ -4752,18 +4760,20 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = c_lhs = pat; c_cont = cont; c_guard = guard; - c_rhs = {exp with exp_type = instance env ty_res'} + c_rhs = {exp with exp_type = instance ty_res'} } ) pat_env_cont_list caselist in - if !Clflags.principal || has_gadts then begin - let ty_res' = instance env ty_res in + if !Clflags.principal || may_contain_gadts then begin + let ty_res' = instance ty_res in List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases end; - let do_init = has_gadts || needs_exhaust_check in - let lev, env = - if do_init && not has_gadts then init_env () else lev, env in + (* We could check whether there actually is a GADT here instead of reusing + [has_constructor], but I'm not sure it's worth it. *) + let do_init = may_contain_gadts || needs_exhaust_check in + let lev = + if do_init && not may_contain_gadts then init_env () else lev in let ty_arg_check = if do_init then (* Hack: use for_saving to copy variables too *) @@ -4772,25 +4782,29 @@ and type_cases ?in_function env ty_arg ty_res ?conts partial_flag loc caselist = in let partial = if partial_flag then - check_partial ~lev env (instance env ty_arg_check) loc cases + check_partial ~lev env (instance ty_arg_check) loc cases else Partial in - let unused_check () = - List.iter (fun (pat, (env, _)) -> check_absent_variant env pat) + let unused_check do_init = + let lev = + if do_init then init_env () else get_current_level () + in + List.iter (fun (pat, _, (env, _)) -> check_absent_variant env pat) pat_env_list; - check_unused ~lev env (instance env ty_arg_check) cases ; + check_unused ~lev env (instance ty_arg_check) cases ; + if do_init then end_def (); Parmatch.check_ambiguous_bindings cases in if contains_polyvars || do_init then - add_delayed_check unused_check + add_delayed_check (fun () -> unused_check do_init) else - unused_check (); + unused_check false; (* Check for unused cases, do not delay because of gadts *) if do_init then begin end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance env ty_res) (newvar ()) ; + unify_exp_types loc env (instance ty_res) (newvar ()) ; end; cases, partial @@ -4807,7 +4821,8 @@ and type_effect_cases env ty_res loc caselist conts = type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = Some (level, level); + type_is_newtype = true; (* FIXME: ctk21: is this right? *) + type_expansion_scope = Some level; type_loc = loc; type_attributes = []; type_immediate = false; @@ -4893,7 +4908,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) List.map (fun pat -> iter_pattern (fun pat -> generalize_structure pat.pat_type) pat; - {pat with pat_type = instance env pat.pat_type}) + {pat with pat_type = instance pat.pat_type}) pat_list end else pat_list in (* Only bind pattern variables after generalizing *) @@ -4997,7 +5012,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) in end_def (); check_univars env true "definition" exp pat.pat_type vars; - {exp with exp_type = instance env exp.exp_type} + {exp with exp_type = instance exp.exp_type} | _ -> Builtin_attributes.warning_scope pvb_attributes (fun () -> type_expect exp_env sexp (mk_expected pat.pat_type))) @@ -5340,10 +5355,6 @@ let report_error env ppf = function | Unexpected_existential -> fprintf ppf "Unexpected existential" - | Unqualified_gadt_pattern (tpath, name) -> - fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" - name path tpath - "must be qualified in this pattern" | Invalid_interval -> fprintf ppf "@[Only character intervals are supported in patterns.@]" | Invalid_for_loop_index -> @@ -5401,6 +5412,7 @@ let report_error env ppf = function longident lid "Hint: You are probably missing the `rec' keyword on line" line + | Empty_pattern -> assert false let report_error env ppf err = wrap_printing_env env (fun () -> report_error env ppf err) diff --git a/typing/typecore.mli b/typing/typecore.mli index fbfa59fac8..a8cdbf023e 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -146,7 +146,6 @@ type error = | Not_a_packed_module of type_expr | Recursive_local_constraint of (type_expr * type_expr) list | Unexpected_existential - | Unqualified_gadt_pattern of Path.t * string | Invalid_interval | Invalid_for_loop_index | No_value_clauses @@ -164,6 +163,7 @@ type error = | Illegal_letrec_expr | Illegal_class_expr | Unbound_value_missing_rec of Longident.t * Location.t + | Empty_pattern exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 385a213f59..52083404b6 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -104,7 +104,8 @@ let enter_type rec_flag env sdecl id = begin match sdecl.ptype_manifest with None -> None | Some _ -> Some(Ctype.newvar ()) end; type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; @@ -352,7 +353,7 @@ let make_effect_constructor env type_param sargs sret = let targs = List.map (transl_simple_type env false) sargs in let args = List.map (fun cty -> cty.ctyp_type) targs in let tret = transl_simple_type env false sret in - Ctype.unify_var env (Ctype.instance env type_param) tret.ctyp_type; + Ctype.unify_var env (Ctype.instance type_param) tret.ctyp_type; let ret_type = Ctype.newconstr type_path [tret.ctyp_type] in let tret_type = { ctyp_desc = Ttyp_constr (type_path, type_lid, targs); @@ -447,7 +448,6 @@ let transl_declaration env sdecl id = match sdecl.ptype_kind with | Ptype_abstract -> Ttype_abstract, Type_abstract | Ptype_variant scstrs -> - assert (scstrs <> []); if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin match cstrs with [] -> () @@ -537,7 +537,8 @@ let transl_declaration env sdecl id = type_private = sdecl.ptype_private; type_manifest = man; type_variance = List.map (fun _ -> Variance.full) params; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; @@ -1434,7 +1435,7 @@ let transl_extension_rebind env type_path type_params typext_params priv lid = let (args, cstr_res) = Ctype.instance_constructor cdescr in let res, ret_type = if cdescr.cstr_generalized then - let params = Ctype.instance_list env type_params in + let params = Ctype.instance_list type_params in let res = Ctype.newconstr type_path params in let ret_type = Some (Ctype.newconstr type_path params) in res, ret_type @@ -1514,7 +1515,7 @@ let transl_extension_constructor env type_path type_params let (args, cstr_res) = Ctype.instance_constructor cdescr in let res, ret_type = if cdescr.cstr_generalized then - let params = Ctype.instance_list env type_params in + let params = Ctype.instance_list type_params in let res = Ctype.newconstr type_path params in let ret_type = Some (Ctype.newconstr type_path params) in res, ret_type @@ -1663,7 +1664,7 @@ let transl_type_extension extend env loc styext = let ttype_params = make_params env styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in List.iter2 (Ctype.unify_var env) - (Ctype.instance_list env type_decl.type_params) + (Ctype.instance_list type_decl.type_params) type_params; let constructors = List.map (transl_extension_constructor env type_path @@ -1989,7 +1990,8 @@ let transl_with_constraint env id row_path orig_decl sdecl = type_private = priv; type_manifest = man; type_variance = []; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; @@ -2037,7 +2039,8 @@ let abstract_type_decl arity = type_private = Public; type_manifest = None; type_variance = replicate_list Variance.full arity; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_loc = Location.none; type_attributes = []; type_immediate = false; diff --git a/typing/typemod.ml b/typing/typemod.ml index a1366c1ebf..3b28eb3f69 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -359,7 +359,8 @@ let merge_constraint initial_env loc sg constr = ) sdecl.ptype_params; type_loc = sdecl.ptype_loc; - type_newtype_level = None; + type_is_newtype = false; + type_expansion_scope = None; type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; @@ -407,7 +408,8 @@ let merge_constraint initial_env loc sg constr = | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in - let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in + let aliasable = not (Env.is_functor_arg path env) in + let newmd = Mtype.strengthen_decl ~aliasable env md' path in ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); real_ids := [Pident id]; (Pident id, lid, Twith_modsubst (path, lid')), diff --git a/typing/types.ml b/typing/types.ml index 4d1463a557..d2569bfc9f 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -22,6 +22,7 @@ open Asttypes type type_expr = { mutable desc: type_desc; mutable level: int; + mutable scope: int option; id: int } and type_desc = @@ -150,7 +151,8 @@ type type_declaration = type_private: private_flag; type_manifest: type_expr option; type_variance: Variance.t list; - type_newtype_level: (int * int) option; + type_is_newtype: bool; + type_expansion_scope: int option; type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: bool; diff --git a/typing/types.mli b/typing/types.mli index 7b9fe8378f..914fa2a700 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -58,6 +58,7 @@ open Asttypes type type_expr = { mutable desc: type_desc; mutable level: int; + mutable scope: int option; id: int } and type_desc = @@ -295,8 +296,8 @@ type type_declaration = type_manifest: type_expr option; type_variance: Variance.t list; (* covariant, contravariant, weakly contravariant, injective *) - type_newtype_level: (int * int) option; - (* definition level * expansion level *) + type_is_newtype: bool; + type_expansion_scope: int option; type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: bool; (* true iff type should not be a pointer *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 4603218f3d..7a631bdcf8 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -71,10 +71,6 @@ exception Error_forward of Location.error type variable_context = int * (string, type_expr) Tbl.t -(* Local definitions *) - -let instance_list = Ctype.instance_list Env.empty - (* Narrowing unbound identifier errors. *) let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = @@ -342,9 +338,9 @@ and transl_type_aux env policy styp = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); begin try - instance env (List.assoc name !univars) + instance (List.assoc name !univars) with Not_found -> try - instance env (fst(Tbl.find name !used_variables)) + instance (fst(Tbl.find name !used_variables)) with Not_found -> let v = if policy = Univars then new_pre_univar ~name () else newvar ~name () @@ -491,7 +487,7 @@ and transl_type_aux env policy styp = let t = try List.assoc alias !univars with Not_found -> - instance env (fst(Tbl.find alias !used_variables)) + instance (fst(Tbl.find alias !used_variables)) in let ty = transl_type env policy st in begin try unify_var env t ty.ctyp_type with Unify trace -> @@ -512,7 +508,7 @@ and transl_type_aux env policy styp = end_def (); generalize_structure t; end; - let t = instance env t in + let t = instance t in let px = Btype.proxy t in begin match px.desc with | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) @@ -824,7 +820,7 @@ let transl_simple_type_univars env styp = in make_fixed_univars typ.ctyp_type; { typ with ctyp_type = - instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } + instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } let transl_simple_type_delayed env styp = univars := []; used_variables := Tbl.empty; diff --git a/utils/build_path_prefix_map.ml b/utils/build_path_prefix_map.ml new file mode 100644 index 0000000000..40e3e8e3a4 --- /dev/null +++ b/utils/build_path_prefix_map.ml @@ -0,0 +1,104 @@ +type path = string +type path_prefix = string +type error_message = string + +let errorf fmt = Printf.kprintf (fun err -> Error err) fmt + +let encode_prefix str = + let buf = Buffer.create (String.length str) in + let push_char = function + | '%' -> Buffer.add_string buf "%#" + | '=' -> Buffer.add_string buf "%+" + | ':' -> Buffer.add_string buf "%." + | c -> Buffer.add_char buf c + in + String.iter push_char str; + Buffer.contents buf + +let decode_prefix str = + let buf = Buffer.create (String.length str) in + let rec loop i = + if i >= String.length str + then Ok (Buffer.contents buf) + else match str.[i] with + | ('=' | ':') as c -> + errorf "invalid character '%c' in key or value" c + | '%' -> + let push c = Buffer.add_char buf c; loop (i + 2) in + if i + 1 = String.length str then + errorf "invalid encoded string %S (trailing '%%')" str + else begin match str.[i + 1] with + | '#' -> push '%' + | '+' -> push '=' + | '.' -> push ':' + | c -> errorf "invalid %%-escaped character '%c'" c + end + | c -> + Buffer.add_char buf c; + loop (i + 1) + in loop 0 + +type pair = { target: path_prefix; source : path_prefix } + +let encode_pair { target; source } = + String.concat "=" [encode_prefix target; encode_prefix source] + +let decode_pair str = + match String.index str '=' with + | exception Not_found -> + errorf "invalid key/value pair %S, no '=' separator" str + | equal_pos -> + let encoded_target = String.sub str 0 equal_pos in + let encoded_source = + String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in + match decode_prefix encoded_target, decode_prefix encoded_source with + | Ok target, Ok source -> Ok { target; source } + | ((Error _ as err), _) | (_, (Error _ as err)) -> err + +type map = pair option list + +let encode_map map = + let encode_elem = function + | None -> "" + | Some pair -> encode_pair pair + in + List.map encode_elem map + |> String.concat ":" + +let decode_map str = + let exception Shortcut of error_message in + let decode_or_empty = function + | "" -> None + | pair -> + begin match decode_pair pair with + | Ok str -> Some str + | Error err -> raise (Shortcut err) + end + in + let pairs = String.split_on_char ':' str in + match List.map decode_or_empty pairs with + | exception (Shortcut err) -> Error err + | map -> Ok map + +let rewrite_opt prefix_map path = + let is_prefix = function + | None -> false + | Some { target = _; source } -> + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) + in + match + List.find is_prefix + (* read key/value pairs from right to left, as the spec demands *) + (List.rev prefix_map) + with + | exception Not_found -> None + | None -> None + | Some { source; target } -> + Some (target ^ (String.sub path (String.length source) + (String.length path - String.length source))) + +let rewrite prefix_map path = + match rewrite_opt prefix_map path with + | None -> path + | Some path -> path diff --git a/utils/build_path_prefix_map.mli b/utils/build_path_prefix_map.mli new file mode 100644 index 0000000000..c21f4583d6 --- /dev/null +++ b/utils/build_path_prefix_map.mli @@ -0,0 +1,24 @@ +type path = string +type path_prefix = string +type error_message = string + +val encode_prefix : path_prefix -> string +val decode_prefix : string -> (path_prefix, error_message) result + +type pair = { target: path_prefix; source : path_prefix } + +val encode_pair : pair -> string +val decode_pair : string -> (pair, error_message) result + +type map = pair option list + +val encode_map : map -> string +val decode_map : string -> (map, error_message) result + +val rewrite_opt : map -> path -> path option +(** [rewrite_opt map path] tries to find a source in [map] + that is a prefix of the input [path]. If it succeeds, + it replaces this prefix with the corresponding target. + If it fails, it just returns [None]. *) + +val rewrite : map -> path -> path diff --git a/utils/clflags.ml b/utils/clflags.ml index c502c41cdd..a1c3610a96 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -92,6 +92,7 @@ and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 500 (* -error-size *) and float_const_prop = ref true (* -no-float-const-prop *) and transparent_modules = ref false (* -trans-mod *) +let unique_ids = ref true let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) and dump_typedtree = ref false (* -dtypedtree *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 9a15649fef..04c41c64ad 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -119,6 +119,7 @@ val for_package : string option ref val error_size : int ref val float_const_prop : bool ref val transparent_modules : bool ref +val unique_ids : bool ref val dump_source : bool ref val dump_parsetree : bool ref val dump_typedtree : bool ref |