diff options
Diffstat (limited to 'testsuite/tests')
50 files changed, 729 insertions, 264 deletions
diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index c4965c22c8..0d368bfc1f 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -7,7 +7,7 @@ run-all: for arg in a b c d ''; do \ printf " ... testing '$$file' (with argument '$$arg'):"; \ OCAMLRUNPARAM=b=1 $(EXECNAME) $$arg > `basename $$file ml`$$arg.result 2>&1; \ - diff -q `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ + $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ done; \ done diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml index bbe8be3279..8dcf116623 100644 --- a/testsuite/tests/basic/arrays.ml +++ b/testsuite/tests/basic/arrays.ml @@ -46,7 +46,9 @@ let test2 () = if not (testcopy [|1.2;2.3;3.4;4.5|]) then print_string "Test2: failed on float array\n"; if not (testcopy [|"un"; "deux"; "trois"|]) then - print_string "Test2: failed on string array\n" + print_string "Test2: failed on string array\n"; + if not (testcopy (bigarray 42)) then + print_string "Test2: failed on big array\n" module AbstractFloat = (struct @@ -79,8 +81,41 @@ let test3 () = AbstractFloat.to_float u.(2) = 3.0) then print_string "Test3: failed on u\n" +let test4 () = + let a = bigarray 0 in + let b = Array.sub a 50 10 in + if b <> [| 50;51;52;53;54;55;56;57;58;59 |] then + print_string "Test4: failed\n" + +let test5 () = + if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then + print_string "Test5: failed on int arrays\n"; + if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then + print_string "Test5: failed on float arrays\n" + +let test6 () = + let a = [| 0;1;2;3;4;5;6;7;8;9 |] in + let b = Array.concat [a;a;a;a;a;a;a;a;a;a] in + if not (Array.length b = 100 && b.(6) = 6 && b.(42) = 2 && b.(99) = 9) then + print_string "Test6: failed\n" + +let test7 () = + let a = Array.make 10 "a" in + let b = [| "b1"; "b2"; "b3" |] in + Array.blit b 0 a 5 3; + if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b2"; "b3"; "a"; "a"|] + || b <> [|"b1"; "b2"; "b3"|] + then print_string "Test7: failed(1)\n"; + Array.blit a 5 a 6 4; + if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b1"; "b2"; "b3"; "a"|] + then print_string "Test7: failed(2)\n" + let _ = test1(); test2(); test3(); + test4(); + test5(); + test6(); + test7(); exit 0 diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile index bc846fe657..06ad39c50c 100644 --- a/testsuite/tests/callback/Makefile +++ b/testsuite/tests/callback/Makefile @@ -12,7 +12,7 @@ run-byte: common @$(OCAMLC) -c tcallback.ml @$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo @./program > bytecode.result - @diff -q reference bytecode.result || (echo " => failed" && exit 1) + @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) @echo " => passed" run-opt: common @@ -20,7 +20,7 @@ run-opt: common @$(OCAMLOPT) -c tcallback.ml @$(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx @./program > native.result - @diff -q reference native.result || (echo " => failed" && exit 1) + @$(DIFF) reference native.result || (echo " => failed" && exit 1) @echo " => passed" promote: defaultpromote diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile index da50369f90..ed33143461 100644 --- a/testsuite/tests/embedded/Makefile +++ b/testsuite/tests/embedded/Makefile @@ -11,7 +11,7 @@ compile: run: @printf " ... testing 'cmmain':" @./program > program.result - @diff -q program.reference program.result > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" promote: defaultpromote diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile new file mode 100644 index 0000000000..bcc2fdb011 --- /dev/null +++ b/testsuite/tests/letrec/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml new file mode 100644 index 0000000000..4a893225b1 --- /dev/null +++ b/testsuite/tests/letrec/backreferences.ml @@ -0,0 +1,18 @@ +(* testing backreferences; some compilation scheme may handle + differently recursive references to a mutually-recursive RHS + depending on whether it is before or after in the bindings list *) +type t = { x : t; y : t; z : t } + +let test = + let rec x = { x; y; z } + and y = { x; y; z } + and z = { x; y; z } + in + List.iter (fun (f, t_ref) -> + List.iter (fun t -> assert (f t == t_ref)) [x; y; z] + ) + [ + (fun t -> t.x), x; + (fun t -> t.y), y; + (fun t -> t.z), z; + ] diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml new file mode 100644 index 0000000000..a7d0338802 --- /dev/null +++ b/testsuite/tests/letrec/class_1.ml @@ -0,0 +1,5 @@ +(* class expression are compiled to recursive bindings *) +class test = +object + method x = 1 +end diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml new file mode 100644 index 0000000000..71c7880d67 --- /dev/null +++ b/testsuite/tests/letrec/class_2.ml @@ -0,0 +1,8 @@ +(* class expressions may also contain local recursive bindings *) +class test = + let rec f = print_endline "f"; fun x -> g x + and g = print_endline "g"; fun x -> f x in +object + method f : 'a 'b. 'a -> 'b = f + method g : 'a 'b. 'a -> 'b = g +end diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference new file mode 100644 index 0000000000..ab713757f4 --- /dev/null +++ b/testsuite/tests/letrec/class_2.reference @@ -0,0 +1,2 @@ +f +g diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml new file mode 100644 index 0000000000..5b88844d7e --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_1.ml @@ -0,0 +1,20 @@ +(* test evaluation order + + 'y' is translated into a constant, and is therefore considered + non-recursive. With the current letrec compilation method, + it should be evaluated before x and z. +*) +type tree = Tree of tree list + +let test = + let rec x = (print_endline "x"; Tree [y; z]) + and y = (print_endline "y"; Tree []) + and z = (print_endline "z"; Tree [x]) + in + match (x, y, z) with + | (Tree [y1; z1], Tree[], Tree[x1]) -> + assert (y1 == y); + assert (z1 == z); + assert (x1 == x) + | _ -> + assert false diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference new file mode 100644 index 0000000000..f471662b7d --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_1.reference @@ -0,0 +1,3 @@ +y +x +z diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml new file mode 100644 index 0000000000..736f82ad32 --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_2.ml @@ -0,0 +1,18 @@ +(* A variant of evaluation_order_1.ml where the side-effects + are inside the blocks. Note that this changes the evaluation + order, as y is considered recursive. +*) +type tree = Tree of tree list + +let test = + let rec x = (Tree [(print_endline "x"; y); z]) + and y = Tree (print_endline "y"; []) + and z = Tree (print_endline "z"; [x]) + in + match (x, y, z) with + | (Tree [y1; z1], Tree[], Tree[x1]) -> + assert (y1 == y); + assert (z1 == z); + assert (x1 == x) + | _ -> + assert false diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference new file mode 100644 index 0000000000..04ec35a6dc --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_2.reference @@ -0,0 +1,3 @@ +x +y +z diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml new file mode 100644 index 0000000000..8f76a8f858 --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_3.ml @@ -0,0 +1,11 @@ +type t = { x : t; y : t } + +let p = print_endline + +let test = + let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) } + and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) } + in + assert (x.x == x); assert (x.y == y); + assert (y.x == x); assert (y.y == y); + () diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference new file mode 100644 index 0000000000..5b8c549eca --- /dev/null +++ b/testsuite/tests/letrec/evaluation_order_3.reference @@ -0,0 +1,6 @@ +x +x_y +x_x +y +y_y +y_x diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml new file mode 100644 index 0000000000..cdfa9d2f85 --- /dev/null +++ b/testsuite/tests/letrec/float_block_1.ml @@ -0,0 +1,10 @@ +(* a bug in cmmgen.ml provokes a change in compilation order between + ocamlc and ocamlopt in certain letrec-bindings involving float + arrays *) +let test = + let rec x = print_endline "x"; [| 1; 2; 3 |] + and y = print_endline "y"; [| 1.; 2.; 3. |] + in + assert (x = [| 1; 2; 3 |]); + assert (y = [| 1.; 2.; 3. |]); + () diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference new file mode 100644 index 0000000000..b77b4eb1d9 --- /dev/null +++ b/testsuite/tests/letrec/float_block_1.reference @@ -0,0 +1,2 @@ +x +y diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml new file mode 100644 index 0000000000..968cba4eb1 --- /dev/null +++ b/testsuite/tests/letrec/float_block_2.ml @@ -0,0 +1,7 @@ +(* a bug in cmmgen.ml provokes a segfault in certain natively compiled + letrec-bindings involving float arrays *) +let test = + let rec x = [| y; y |] and y = 1. in + assert (x = [| 1.; 1. |]); + assert (y = 1.); + () diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml new file mode 100644 index 0000000000..5686e49357 --- /dev/null +++ b/testsuite/tests/letrec/lists.ml @@ -0,0 +1,8 @@ +(* a test with lists, because cyclic lists are fun *) +let test = + let rec li = 0::1::2::3::4::5::6::7::8::9::li in + match li with + | 0::1::2::3::4::5::6::7::8::9:: + 0::1::2::3::4::5::6::7::8::9::li' -> + assert (li == li') + | _ -> assert false diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml new file mode 100644 index 0000000000..e79f79ecbe --- /dev/null +++ b/testsuite/tests/letrec/mixing_value_closures_1.ml @@ -0,0 +1,8 @@ +(* mixing values and closures may exercise interesting code paths *) +type t = A of (int -> int) +let test = + let rec x = A f + and f = function + | 0 -> 2 + | n -> match x with A g -> g 0 + in assert (f 1 = 2) diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml new file mode 100644 index 0000000000..eb5fcb7420 --- /dev/null +++ b/testsuite/tests/letrec/mixing_value_closures_2.ml @@ -0,0 +1,8 @@ +(* a polymorphic variant of test3.ml; found a real bug once *) +let test = + let rec x = `A f + and f = function + | 0 -> 2 + | n -> match x with `A g -> g 0 + in + assert (f 1 = 2) diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml new file mode 100644 index 0000000000..a5b6c51ffe --- /dev/null +++ b/testsuite/tests/letrec/mutual_functions.ml @@ -0,0 +1,11 @@ +(* a simple test with mutually recursive functions *) +let test = + let rec even = function + | 0 -> true + | n -> odd (n - 1) + and odd = function + | 0 -> false + | n -> even (n - 1) + in + List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0))) + [0;1;2;3;4;5;6] diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile index ea07959afb..a510325bce 100644 --- a/testsuite/tests/lib-dynlink-bytecode/Makefile +++ b/testsuite/tests/lib-dynlink-bytecode/Makefile @@ -19,17 +19,17 @@ compile: run: @printf " ... testing 'main'" @export LD_LIBRARY_PATH=`pwd` && ./main plug1.cma plug2.cma > main.result - @diff -q main.reference main.result > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" @printf " ... testing 'static'" @export LD_LIBRARY_PATH=`pwd` && ./static > static.result - @diff -q static.reference static.result > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" @printf " ... testing 'custom'" @export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result - @diff -q custom.reference custom.result > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" promote: defaultpromote diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile index 377b7d8474..06f58b72da 100644 --- a/testsuite/tests/lib-dynlink-csharp/Makefile +++ b/testsuite/tests/lib-dynlink-csharp/Makefile @@ -15,7 +15,7 @@ bytecode: $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > bytecode.result; \ - diff -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ + $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ fi bytecode-dll: @@ -27,7 +27,7 @@ bytecode-dll: $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../byterun/libcamlrun.$(A) $(BYTECCLIBS) -v; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > bytecode.result; \ - diff -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ + $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ fi native: @@ -38,7 +38,7 @@ native: $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > native.result; \ - diff -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ + $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ fi native-dll: @@ -50,7 +50,7 @@ native-dll: $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../asmrun/libasmrun.lib -v; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > native.result; \ - diff -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ + $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ fi promote: defaultpromote diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index d090d80137..d7ac244671 100644 --- a/testsuite/tests/lib-dynlink-native/Makefile +++ b/testsuite/tests/lib-dynlink-native/Makefile @@ -12,7 +12,7 @@ compile: $(PLUGINS) main mylib.so run: @printf " ... testing 'main'" @./main plugin_thread.so > result - @diff -q reference result > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" main: api.cmx main.cmx diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile index ecb87cba20..bf7cf08af7 100644 --- a/testsuite/tests/lib-scanf-2/Makefile +++ b/testsuite/tests/lib-scanf-2/Makefile @@ -11,10 +11,10 @@ compile: tscanf2_io.cmo tscanf2_io.cmx run: @printf " ... testing with ocamlc" @./master.byte ./slave.byte > result.byte 2>&1 - @diff -q reference result.byte > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) reference result.byte > /dev/null || (echo " => failed" && exit 1) @printf " ocamlopt" @./master.native ./slave.native > result.native 2>&1 - @diff -q reference result.native > /dev/null || (echo " => failed" && exit 1) + @$(DIFF) reference result.native > /dev/null || (echo " => failed" && exit 1) @echo " => passed" promote: diff --git a/testsuite/tests/lib-set/Makefile b/testsuite/tests/lib-set/Makefile new file mode 100644 index 0000000000..4ba0bffc51 --- /dev/null +++ b/testsuite/tests/lib-set/Makefile @@ -0,0 +1,3 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml new file mode 100644 index 0000000000..1197fbf6d0 --- /dev/null +++ b/testsuite/tests/lib-set/testmap.ml @@ -0,0 +1,123 @@ +module M = Map.Make(struct type t = int let compare = compare end) + +let img x m = try Some(M.find x m) with Not_found -> None + +let testvals = [0;1;2;3;4;5;6;7;8;9] + +let check msg cond = + if not (List.for_all cond testvals) then + Printf.printf "Test %s FAILED\n%!" msg + +let checkbool msg b = + if not b then + Printf.printf "Test %s FAILED\n%!" msg + +let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y + +let test x v s1 s2 = + + checkbool "is_empty" + (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals); + + check "mem" + (fun i -> M.mem i s1 = (img i s1 <> None)); + + check "add" + (let s = M.add x v s1 in + fun i -> img i s = (if i = x then Some v else img i s1)); + + check "singleton" + (let s = M.singleton x v in + fun i -> img i s = (if i = x then Some v else None)); + + check "remove" + (let s = M.remove x s1 in + fun i -> img i s = (if i = x then None else img i s1)); + + check "merge-union" + (let f _ o1 o2 = + match o1, o2 with + | Some v1, Some v2 -> Some (v1 +. v2) + | None, _ -> o2 + | _, None -> o1 in + let s = M.merge f s1 s2 in + fun i -> img i s = f i (img i s1) (img i s2)); + + check "merge-inter" + (let f _ o1 o2 = + match o1, o2 with + | Some v1, Some v2 -> Some (v1 -. v2) + | _, _ -> None in + let s = M.merge f s1 s2 in + fun i -> img i s = f i (img i s1) (img i s2)); + + checkbool "bindings" + (let rec extract = function + | [] -> [] + | hd :: tl -> + match img hd s1 with + | None -> extract tl + | Some v ->(hd, v) :: extract tl in + M.bindings s1 = extract testvals); + + checkbool "for_all" + (let p x y = x mod 2 = 0 in + M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1)); + + checkbool "exists" + (let p x y = x mod 3 = 0 in + M.exists p s1 = List.exists (uncurry p) (M.bindings s1)); + + checkbool "filter" + (let p x y = x >= 3 && x <= 6 in + M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1)); + + checkbool "partition" + (let p x y = x >= 3 && x <= 6 in + let (st,sf) = M.partition p s1 + and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in + M.bindings st = lt && M.bindings sf = lf); + + checkbool "cardinal" + (M.cardinal s1 = List.length (M.bindings s1)); + + checkbool "min_binding" + (try + let (k,v) = M.min_binding s1 in + img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1 + with Not_found -> + M.is_empty s1); + + checkbool "max_binding" + (try + let (k,v) = M.max_binding s1 in + img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1 + with Not_found -> + M.is_empty s1); + + checkbool "choose" + (try + let (x,v) = M.choose s1 in img x s1 = Some v + with Not_found -> + M.is_empty s1); + + check "split" + (let (l, p, r) = M.split x s1 in + fun i -> + if i < x then img i l = img i s1 + else if i > x then img i r = img i s1 + else p = img i s1) + +let rkey() = Random.int 10 + +let rdata() = Random.float 1.0 + +let rmap() = + let s = ref M.empty in + for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done; + !s + +let _ = + Random.init 42; + for i = 1 to 25000 do test (rkey()) (rdata()) (rmap()) (rmap()) done + diff --git a/testsuite/tests/lib-set/testmap.reference b/testsuite/tests/lib-set/testmap.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/lib-set/testmap.reference diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml new file mode 100644 index 0000000000..c4ab0441e0 --- /dev/null +++ b/testsuite/tests/lib-set/testset.ml @@ -0,0 +1,120 @@ +module S = Set.Make(struct type t = int let compare = compare end) + +let testvals = [0;1;2;3;4;5;6;7;8;9] + +let check msg cond = + if not (List.for_all cond testvals) then + Printf.printf "Test %s FAILED\n%!" msg + +let checkbool msg b = + if not b then + Printf.printf "Test %s FAILED\n%!" msg + +let normalize_cmp c = + if c = 0 then 0 else if c > 0 then 1 else -1 + +let test x s1 s2 = + + checkbool "is_empty" + (S.is_empty s1 = List.for_all (fun i -> not (S.mem i s1)) testvals); + + check "add" + (let s = S.add x s1 in + fun i -> S.mem i s = (S.mem i s1 || i = x)); + + check "singleton" + (let s = S.singleton x in + fun i -> S.mem i s = (i = x)); + + check "remove" + (let s = S.remove x s1 in + fun i -> S.mem i s = (S.mem i s1 && i <> x)); + + check "union" + (let s = S.union s1 s2 in + fun i -> S.mem i s = (S.mem i s1 || S.mem i s2)); + + check "inter" + (let s = S.inter s1 s2 in + fun i -> S.mem i s = (S.mem i s1 && S.mem i s2)); + + check "diff" + (let s = S.diff s1 s2 in + fun i -> S.mem i s = (S.mem i s1 && not (S.mem i s2))); + + checkbool "elements" + (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals); + + checkbool "compare" + (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2))); + + checkbool "equal" + (S.equal s1 s2 = (S.elements s1 = S.elements s2)); + + check "subset" + (let b = S.subset s1 s2 in + fun i -> if b && S.mem i s1 then S.mem i s2 else true); + + checkbool "subset2" + (let b = S.subset s1 s2 in + b || not (S.is_empty (S.diff s1 s2))); + + checkbool "for_all" + (let p x = x mod 2 = 0 in + S.for_all p s1 = List.for_all p (S.elements s1)); + + checkbool "exists" + (let p x = x mod 3 = 0 in + S.exists p s1 = List.exists p (S.elements s1)); + + checkbool "filter" + (let p x = x >= 3 && x <= 6 in + S.elements(S.filter p s1) = List.filter p (S.elements s1)); + + checkbool "partition" + (let p x = x >= 3 && x <= 6 in + let (st,sf) = S.partition p s1 + and (lt,lf) = List.partition p (S.elements s1) in + S.elements st = lt && S.elements sf = lf); + + checkbool "cardinal" + (S.cardinal s1 = List.length (S.elements s1)); + + checkbool "min_elt" + (try + let m = S.min_elt s1 in + S.mem m s1 && S.for_all (fun i -> m <= i) s1 + with Not_found -> + S.is_empty s1); + + checkbool "max_elt" + (try + let m = S.max_elt s1 in + S.mem m s1 && S.for_all (fun i -> m >= i) s1 + with Not_found -> + S.is_empty s1); + + checkbool "choose" + (try + let x = S.choose s1 in S.mem x s1 + with Not_found -> + S.is_empty s1); + + check "split" + (let (l, p, r) = S.split x s1 in + fun i -> + if i < x then S.mem i l = S.mem i s1 + else if i > x then S.mem i r = S.mem i s1 + else p = S.mem i s1) + +let relt() = Random.int 10 + +let rset() = + let s = ref S.empty in + for i = 1 to Random.int 10 do s := S.add (relt()) !s done; + !s + +let _ = + Random.init 42; + for i = 1 to 25000 do test (relt()) (rset()) (rset()) done + diff --git a/testsuite/tests/lib-set/testset.reference b/testsuite/tests/lib-set/testset.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/lib-set/testset.reference diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile index 63f63c9e72..1e2feb9193 100644 --- a/testsuite/tests/runtime-errors/Makefile +++ b/testsuite/tests/runtime-errors/Makefile @@ -16,10 +16,10 @@ run: for f in *.bytecode; do \ printf " ... testing '$$f':"; \ (./$$f > $$f.result 2>&1; true); \ - diff -q $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ + $(DIFF) $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ printf " ... testing '`basename $$f bytecode`native':"; \ (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \ - diff -q `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ + $(DIFF) `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ done promote: defaultpromote diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile index 6a6b5f8907..d112f568cd 100644 --- a/testsuite/tests/tool-ocamldoc/Makefile +++ b/testsuite/tests/tool-ocamldoc/Makefile @@ -6,7 +6,7 @@ run: $(CUSTOM_MODULE).cmo @for file in t*.ml; do \ printf " ... testing '$$file'"; \ $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \ - diff -q `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ + $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ done; @$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true @$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference index 39102239a9..72a301c4aa 100644 --- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference +++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference @@ -9,9 +9,9 @@ | VString of string | VList of variant list | VPair of variant * variant -val variantize : 'a ty -> 'a -> variant = <fun> +val variantize : 't ty -> 't -> variant = <fun> exception VariantMismatch -val devariantize : 'a ty -> variant -> 'a = <fun> +val devariantize : 't ty -> variant -> 't = <fun> # type 'a ty = Int : int ty | String : string ty @@ -27,7 +27,7 @@ and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; } | VList of variant list | VPair of variant * variant | VRecord of (string * variant) list -val variantize : 'a ty -> 'a -> variant = <fun> +val variantize : 't ty -> 't -> variant = <fun> # type 'a ty = Int : int ty | String : string ty @@ -48,7 +48,7 @@ and ('a, 'builder, 'b) field_ = { get : 'a -> 'b; set : 'builder -> 'b -> unit; } -val devariantize : 'a ty -> variant -> 'a = <fun> +val devariantize : 't ty -> variant -> 't = <fun> # type my_record = { a : int; b : string list; } val my_record : my_record ty = Record @@ -58,7 +58,7 @@ val my_record : my_record ty = Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}]; create_builder = <fun>; of_builder = <fun>} # type noarg = Noarg -type ('a, 'b) ty = +type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -75,20 +75,20 @@ and ('a, 'e, 'b) ty_sum = { sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; } and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn -and ('a, 'b) ty_sel = +and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and ('a, 'b) ty_case = +and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case -# type 'a ty_env = +# type _ ty_env = Enil : unit ty_env | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env -# type ('a, 'b) eq = Eq : ('a, 'a) eq +# type (_, _) eq = Eq : ('a, 'a) eq val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun> val get_case : - ('a, 'b) ty_sel -> - (string * ('c, 'a) ty_case) list -> string * ('b, 'c) ty option = <fun> + ('b, 'a) ty_sel -> + (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun> # type variant = VInt of int | VString of string @@ -98,8 +98,8 @@ val get_case : | VConv of string * variant | VSum of string * variant option val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun> -val variantize : 'a ty_env -> ('b, 'a) ty -> 'b -> variant = <fun> -# val devariantize : 'a ty_env -> ('b, 'a) ty -> variant -> 'b = <fun> +val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun> +# val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun> # val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun> # val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty = <fun> @@ -124,12 +124,12 @@ val v : variant = sum_inj = <fun>} # val a : [ `A of int | `B of string | `C ] = `A 3 type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] -val ty_list : ('a, 'b) ty -> ('a vlist, 'b) ty = <fun> +val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> val v : variant = VSum ("Cons", Some (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None))))))) -# type ('a, 'b) ty = +# type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -149,7 +149,7 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>) Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type ex#46 = ex#47 * ex#48 -# type ('a, 'b) ty = +# type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -164,13 +164,13 @@ Error: This pattern matches values of type a * a vlist inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn -and ('a, 'b) ty_sel = +and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and ('a, 'b) ty_case = +and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj> type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] -val ty_list : ('a, 'b) ty -> ('a vlist, 'b) ty = <fun> +val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> # * * * * * * * * * diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference index 39102239a9..72a301c4aa 100644 --- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference +++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference @@ -9,9 +9,9 @@ | VString of string | VList of variant list | VPair of variant * variant -val variantize : 'a ty -> 'a -> variant = <fun> +val variantize : 't ty -> 't -> variant = <fun> exception VariantMismatch -val devariantize : 'a ty -> variant -> 'a = <fun> +val devariantize : 't ty -> variant -> 't = <fun> # type 'a ty = Int : int ty | String : string ty @@ -27,7 +27,7 @@ and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; } | VList of variant list | VPair of variant * variant | VRecord of (string * variant) list -val variantize : 'a ty -> 'a -> variant = <fun> +val variantize : 't ty -> 't -> variant = <fun> # type 'a ty = Int : int ty | String : string ty @@ -48,7 +48,7 @@ and ('a, 'builder, 'b) field_ = { get : 'a -> 'b; set : 'builder -> 'b -> unit; } -val devariantize : 'a ty -> variant -> 'a = <fun> +val devariantize : 't ty -> variant -> 't = <fun> # type my_record = { a : int; b : string list; } val my_record : my_record ty = Record @@ -58,7 +58,7 @@ val my_record : my_record ty = Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}]; create_builder = <fun>; of_builder = <fun>} # type noarg = Noarg -type ('a, 'b) ty = +type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -75,20 +75,20 @@ and ('a, 'e, 'b) ty_sum = { sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; } and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn -and ('a, 'b) ty_sel = +and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and ('a, 'b) ty_case = +and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case -# type 'a ty_env = +# type _ ty_env = Enil : unit ty_env | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env -# type ('a, 'b) eq = Eq : ('a, 'a) eq +# type (_, _) eq = Eq : ('a, 'a) eq val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun> val get_case : - ('a, 'b) ty_sel -> - (string * ('c, 'a) ty_case) list -> string * ('b, 'c) ty option = <fun> + ('b, 'a) ty_sel -> + (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun> # type variant = VInt of int | VString of string @@ -98,8 +98,8 @@ val get_case : | VConv of string * variant | VSum of string * variant option val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun> -val variantize : 'a ty_env -> ('b, 'a) ty -> 'b -> variant = <fun> -# val devariantize : 'a ty_env -> ('b, 'a) ty -> variant -> 'b = <fun> +val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun> +# val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun> # val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun> # val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty = <fun> @@ -124,12 +124,12 @@ val v : variant = sum_inj = <fun>} # val a : [ `A of int | `B of string | `C ] = `A 3 type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] -val ty_list : ('a, 'b) ty -> ('a vlist, 'b) ty = <fun> +val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> val v : variant = VSum ("Cons", Some (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None))))))) -# type ('a, 'b) ty = +# type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -149,7 +149,7 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>) Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type ex#46 = ex#47 * ex#48 -# type ('a, 'b) ty = +# type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty | List : ('a, 'e) ty -> ('a list, 'e) ty @@ -164,13 +164,13 @@ Error: This pattern matches values of type a * a vlist inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn -and ('a, 'b) ty_sel = +and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and ('a, 'b) ty_case = +and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj> type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] -val ty_list : ('a, 'b) ty -> ('a vlist, 'b) ty = <fun> +val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun> # * * * * * * * * * diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference index 60ef06cb35..cf8b0b5bc1 100644 --- a/testsuite/tests/typing-gadts/omega07.ml.principal.reference +++ b/testsuite/tests/typing-gadts/omega07.ml.principal.reference @@ -1,47 +1,47 @@ # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b type zero = Zero -type 'a succ -type 'a nat = NZ : zero nat | NS : 'a nat -> 'a succ nat -# type ('a, 'b) seq = +type _ succ +type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat +# type (_, _) seq = Snil : ('a, zero) seq | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq # val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil)) -# * type ('a, 'b, 'c) plus = +# * type (_, _, _) plus = PlusZ : 'a nat -> (zero, 'a, 'a) plus | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus -# val length : ('a, 'b) seq -> 'b nat = <fun> -# * type ('a, 'b, 'c) app = +# val length : ('a, 'n) seq -> 'n nat = <fun> +# * type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app -val app : ('a, 'b) seq -> ('a, 'c) seq -> ('a, 'b, 'c) app = <fun> +val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun> # * type tp type nd -type ('a, 'b) fk -type 'a shape = +type (_, _) fk +type _ shape = Tp : tp shape | Nd : nd shape | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape # type tt type ff -type 'a boolean = BT : tt boolean | BF : ff boolean -# type ('a, 'b) path = +type _ boolean = BT : tt boolean | BF : ff boolean +# type (_, _) path = Pnone : 'a -> (tp, 'a) path | Phere : (nd, 'a) path | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path -# type ('a, 'b) tree = +# type (_, _) tree = Ttip : (tp, 'a) tree | Tnode : 'a -> (nd, 'a) tree | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree # val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) -# val find : ('a -> 'a -> bool) -> 'a -> ('b, 'a) tree -> ('b, 'a) path list = +# val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list = <fun> -# val extract : ('b, 'a) path -> ('b, 'a) tree -> 'a = <fun> -# type ('a, 'b) le = +# val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun> +# type (_, _) le = LeZ : 'a nat -> (zero, 'a) le | LeS : ('n, 'm) le -> ('n succ, 'm succ) le -# type 'a even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even +# type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even # type one = zero succ type two = one succ type three = two succ @@ -51,11 +51,11 @@ val even2 : two even = EvenSS EvenZ val even4 : four even = EvenSS (EvenSS EvenZ) # val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) # val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun> -# type ('a, 'b) equal = Eq : ('a, 'a) equal +# type (_, _) equal = Eq : ('a, 'a) equal val convert : ('a, 'b) equal -> 'a -> 'b = <fun> val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun> # val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun> -# type ('a, 'b) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff +# type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff # * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun> # Characters 87-243: ..match a, b,le with (* warning *) @@ -67,38 +67,38 @@ Here is an example of a value that is not matched: (NS _, NZ, _) val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun> # val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun> -# type ('a, 'b) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter -val leS' : ('a, 'b) le -> ('a, 'b succ) le = <fun> -# val filter : ('a -> bool) -> ('a, 'b) seq -> ('a, 'b) filter = <fun> -# type ('a, 'b, 'c) balance = +# type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter +val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun> +# val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun> +# type (_, _, _) balance = Less : ('h, 'h succ, 'h succ) balance | Same : ('h, 'h, 'h) balance | More : ('h succ, 'h, 'h succ) balance -type 'a avl = +type _ avl = Leaf : zero avl | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl type avl' = Avl : 'h avl -> avl' # val empty : avl' = Avl Leaf -val elem : int -> 'a avl -> bool = <fun> +val elem : int -> 'h avl -> bool = <fun> # val rotr : - 'a succ succ avl -> - int -> 'a avl -> ('a succ succ avl, 'a succ succ succ avl) sum = <fun> + 'n succ succ avl -> + int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun> # val rotl : - 'a avl -> - int -> 'a succ succ avl -> ('a succ succ avl, 'a succ succ succ avl) sum = + 'n avl -> + int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun> -# val ins : int -> 'a avl -> ('a avl, 'a succ avl) sum = <fun> +# val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun> # val insert : int -> avl' -> avl' = <fun> -# val del_min : 'a succ avl -> int * ('a avl, 'a succ avl) sum = <fun> -type 'a avl_del = +# val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun> +type _ avl_del = Dsame : 'n avl -> 'n avl_del | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del -val del : int -> 'a avl -> 'a avl_del = <fun> +val del : int -> 'n avl -> 'n avl_del = <fun> # val delete : int -> avl' -> avl' = <fun> # type red type black -type ('a, 'b) sub_tree = +type (_, _) sub_tree = Bleaf : (black, zero) sub_tree | Rnode : (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree @@ -106,16 +106,16 @@ type ('a, 'b) sub_tree = ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree type rb_tree = Root : (black, 'n) sub_tree -> rb_tree # type dir = LeftD | RightD -type ('a, 'b) ctxt = +type (_, _) ctxt = CNil : (black, 'n) ctxt | CRed : int * dir * (black, 'n) sub_tree * (red, 'n) ctxt -> (black, 'n) ctxt | CBlk : int * dir * ('c1, 'n) sub_tree * (black, 'n succ) ctxt -> ('c, 'n) ctxt # val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun> -type 'a crep = Red : red crep | Black : black crep -val color : ('a, 'b) sub_tree -> 'a crep = <fun> -# val fill : ('a, 'b) ctxt -> ('a, 'b) sub_tree -> rb_tree = <fun> +type _ crep = Red : red crep | Black : black crep +val color : ('c, 'n) sub_tree -> 'c crep = <fun> +# val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun> # val recolor : dir -> int -> @@ -132,10 +132,10 @@ val color : ('a, 'b) sub_tree -> 'a crep = <fun> int -> (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun> -# val repair : (red, 'a) sub_tree -> ('b, 'a) ctxt -> rb_tree = <fun> -# val ins : int -> ('a, 'b) sub_tree -> ('a, 'b) ctxt -> rb_tree = <fun> +# val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun> +# val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun> # val insert : int -> rb_tree -> rb_tree = <fun> -# type 'a term = +# type _ term = Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term @@ -145,16 +145,16 @@ val ex1 : int term = Ap (Add, Pair (Const 3, Const 5)) val ex2 : (int * int) term = Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1) val eval_term : 'a term -> 'a = <fun> -type 'a rep = +type _ rep = Rint : int rep | Rbool : bool rep | Rpair : 'a rep * 'b rep -> ('a * 'b) rep | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep -type ('a, 'b) equal = Eq : ('a, 'a) equal +type (_, _) equal = Eq : ('a, 'a) equal val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun> # type assoc = Assoc : string * 'a rep * 'a -> assoc val assoc : string -> 'a rep -> assoc list -> 'a = <fun> -type 'a term = +type _ term = Var : string * 'a rep -> 'a term | Abs : string * 'a rep * 'b term -> ('a -> 'b) term | Const : int -> int term @@ -170,11 +170,11 @@ val ex4 : int term = Const 3) val v4 : int = 6 # type rnil -type ('a, 'b, 'c) rcons -type 'a is_row = +type (_, _, _) rcons +type _ is_row = Rnil : rnil is_row | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row -type ('a, 'b) lam = +type (_, _) lam = Const : int -> ('e, int) lam | Var : 'a -> (('a, 't, 'e) rcons, 't) lam | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam @@ -186,10 +186,10 @@ val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam = App (Var X, Shift (Var Y)) val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam = Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>))) -# type 'a env = +# type _ env = Enil : rnil env | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env -val eval_lam : 'a env -> ('a, 'b) lam -> 'b = <fun> +val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun> # type add = Add type suc = Suc val env0 : @@ -233,21 +233,19 @@ val ex3 : App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))) # val v3 : int = 6 -# * type 'a rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep +# * type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun> # type term = C of int | Ab : string * 'a rep * term -> term | Ap of term * term | V of string -type 'a ctx = +type _ ctx = Cnil : rnil ctx | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx -# type 'a checked = - Cerror of string - | Cok : ('e, 't) lam * 't rep -> 'e checked -val lookup : string -> 'a ctx -> 'a checked = <fun> -# val tc : 'a nat -> 'b ctx -> term -> 'b checked = <fun> +# type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked +val lookup : string -> 'e ctx -> 'e checked = <fun> +# val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun> # val ctx0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons ctx = @@ -275,13 +273,13 @@ val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")) # val v2 : int = 6 # type pexp type pval -type 'a mode = Pexp : pexp mode | Pval : pval mode -type ('a, 'b) tarr +type _ mode = Pexp : pexp mode | Pval : pval mode +type (_, _) tarr type tint -type ('a, 'b) rel = +type (_, _) rel = IntR : (tint, int) rel | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel -type ('a, 'b, 'c) lam = +type (_, _, _) lam = Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam @@ -291,18 +289,18 @@ type ('a, 'b, 'c) lam = ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam # val ex1 : (pexp, 'a, tint) lam = App (Lam (<poly>, Var <poly>), Const (IntR, <poly>)) -val mode : ('a, 'b, 'c) lam -> 'a mode = <fun> -# type ('a, 'b) sub = +val mode : ('m, 'e, 't) lam -> 'm mode = <fun> +# type (_, _) sub = Id : ('r, 'r) sub | Bind : 't * ('m, 'r2, 'x) lam * ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub -type ('a, 'b) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' -# val subst : ('a, 'b, 'c) lam -> ('b, 'd) sub -> ('d, 'c) lam' = <fun> +type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' +# val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun> # type closed = rnil type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum # val rule : (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam = <fun> -# val onestep : ('a, closed, 'b) lam -> 'b rlam = <fun> +# val onestep : ('m, closed, 't) lam -> 't rlam = <fun> # diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference index 60ef06cb35..cf8b0b5bc1 100644 --- a/testsuite/tests/typing-gadts/omega07.ml.reference +++ b/testsuite/tests/typing-gadts/omega07.ml.reference @@ -1,47 +1,47 @@ # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b type zero = Zero -type 'a succ -type 'a nat = NZ : zero nat | NS : 'a nat -> 'a succ nat -# type ('a, 'b) seq = +type _ succ +type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat +# type (_, _) seq = Snil : ('a, zero) seq | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq # val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil)) -# * type ('a, 'b, 'c) plus = +# * type (_, _, _) plus = PlusZ : 'a nat -> (zero, 'a, 'a) plus | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus -# val length : ('a, 'b) seq -> 'b nat = <fun> -# * type ('a, 'b, 'c) app = +# val length : ('a, 'n) seq -> 'n nat = <fun> +# * type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app -val app : ('a, 'b) seq -> ('a, 'c) seq -> ('a, 'b, 'c) app = <fun> +val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun> # * type tp type nd -type ('a, 'b) fk -type 'a shape = +type (_, _) fk +type _ shape = Tp : tp shape | Nd : nd shape | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape # type tt type ff -type 'a boolean = BT : tt boolean | BF : ff boolean -# type ('a, 'b) path = +type _ boolean = BT : tt boolean | BF : ff boolean +# type (_, _) path = Pnone : 'a -> (tp, 'a) path | Phere : (nd, 'a) path | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path -# type ('a, 'b) tree = +# type (_, _) tree = Ttip : (tp, 'a) tree | Tnode : 'a -> (nd, 'a) tree | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree # val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) -# val find : ('a -> 'a -> bool) -> 'a -> ('b, 'a) tree -> ('b, 'a) path list = +# val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list = <fun> -# val extract : ('b, 'a) path -> ('b, 'a) tree -> 'a = <fun> -# type ('a, 'b) le = +# val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun> +# type (_, _) le = LeZ : 'a nat -> (zero, 'a) le | LeS : ('n, 'm) le -> ('n succ, 'm succ) le -# type 'a even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even +# type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even # type one = zero succ type two = one succ type three = two succ @@ -51,11 +51,11 @@ val even2 : two even = EvenSS EvenZ val even4 : four even = EvenSS (EvenSS EvenZ) # val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) # val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun> -# type ('a, 'b) equal = Eq : ('a, 'a) equal +# type (_, _) equal = Eq : ('a, 'a) equal val convert : ('a, 'b) equal -> 'a -> 'b = <fun> val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun> # val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun> -# type ('a, 'b) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff +# type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff # * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun> # Characters 87-243: ..match a, b,le with (* warning *) @@ -67,38 +67,38 @@ Here is an example of a value that is not matched: (NS _, NZ, _) val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun> # val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun> -# type ('a, 'b) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter -val leS' : ('a, 'b) le -> ('a, 'b succ) le = <fun> -# val filter : ('a -> bool) -> ('a, 'b) seq -> ('a, 'b) filter = <fun> -# type ('a, 'b, 'c) balance = +# type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter +val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun> +# val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun> +# type (_, _, _) balance = Less : ('h, 'h succ, 'h succ) balance | Same : ('h, 'h, 'h) balance | More : ('h succ, 'h, 'h succ) balance -type 'a avl = +type _ avl = Leaf : zero avl | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl type avl' = Avl : 'h avl -> avl' # val empty : avl' = Avl Leaf -val elem : int -> 'a avl -> bool = <fun> +val elem : int -> 'h avl -> bool = <fun> # val rotr : - 'a succ succ avl -> - int -> 'a avl -> ('a succ succ avl, 'a succ succ succ avl) sum = <fun> + 'n succ succ avl -> + int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun> # val rotl : - 'a avl -> - int -> 'a succ succ avl -> ('a succ succ avl, 'a succ succ succ avl) sum = + 'n avl -> + int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun> -# val ins : int -> 'a avl -> ('a avl, 'a succ avl) sum = <fun> +# val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun> # val insert : int -> avl' -> avl' = <fun> -# val del_min : 'a succ avl -> int * ('a avl, 'a succ avl) sum = <fun> -type 'a avl_del = +# val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun> +type _ avl_del = Dsame : 'n avl -> 'n avl_del | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del -val del : int -> 'a avl -> 'a avl_del = <fun> +val del : int -> 'n avl -> 'n avl_del = <fun> # val delete : int -> avl' -> avl' = <fun> # type red type black -type ('a, 'b) sub_tree = +type (_, _) sub_tree = Bleaf : (black, zero) sub_tree | Rnode : (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree @@ -106,16 +106,16 @@ type ('a, 'b) sub_tree = ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree type rb_tree = Root : (black, 'n) sub_tree -> rb_tree # type dir = LeftD | RightD -type ('a, 'b) ctxt = +type (_, _) ctxt = CNil : (black, 'n) ctxt | CRed : int * dir * (black, 'n) sub_tree * (red, 'n) ctxt -> (black, 'n) ctxt | CBlk : int * dir * ('c1, 'n) sub_tree * (black, 'n succ) ctxt -> ('c, 'n) ctxt # val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun> -type 'a crep = Red : red crep | Black : black crep -val color : ('a, 'b) sub_tree -> 'a crep = <fun> -# val fill : ('a, 'b) ctxt -> ('a, 'b) sub_tree -> rb_tree = <fun> +type _ crep = Red : red crep | Black : black crep +val color : ('c, 'n) sub_tree -> 'c crep = <fun> +# val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun> # val recolor : dir -> int -> @@ -132,10 +132,10 @@ val color : ('a, 'b) sub_tree -> 'a crep = <fun> int -> (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun> -# val repair : (red, 'a) sub_tree -> ('b, 'a) ctxt -> rb_tree = <fun> -# val ins : int -> ('a, 'b) sub_tree -> ('a, 'b) ctxt -> rb_tree = <fun> +# val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun> +# val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun> # val insert : int -> rb_tree -> rb_tree = <fun> -# type 'a term = +# type _ term = Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term @@ -145,16 +145,16 @@ val ex1 : int term = Ap (Add, Pair (Const 3, Const 5)) val ex2 : (int * int) term = Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1) val eval_term : 'a term -> 'a = <fun> -type 'a rep = +type _ rep = Rint : int rep | Rbool : bool rep | Rpair : 'a rep * 'b rep -> ('a * 'b) rep | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep -type ('a, 'b) equal = Eq : ('a, 'a) equal +type (_, _) equal = Eq : ('a, 'a) equal val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun> # type assoc = Assoc : string * 'a rep * 'a -> assoc val assoc : string -> 'a rep -> assoc list -> 'a = <fun> -type 'a term = +type _ term = Var : string * 'a rep -> 'a term | Abs : string * 'a rep * 'b term -> ('a -> 'b) term | Const : int -> int term @@ -170,11 +170,11 @@ val ex4 : int term = Const 3) val v4 : int = 6 # type rnil -type ('a, 'b, 'c) rcons -type 'a is_row = +type (_, _, _) rcons +type _ is_row = Rnil : rnil is_row | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row -type ('a, 'b) lam = +type (_, _) lam = Const : int -> ('e, int) lam | Var : 'a -> (('a, 't, 'e) rcons, 't) lam | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam @@ -186,10 +186,10 @@ val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam = App (Var X, Shift (Var Y)) val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam = Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>))) -# type 'a env = +# type _ env = Enil : rnil env | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env -val eval_lam : 'a env -> ('a, 'b) lam -> 'b = <fun> +val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun> # type add = Add type suc = Suc val env0 : @@ -233,21 +233,19 @@ val ex3 : App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))) # val v3 : int = 6 -# * type 'a rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep +# * type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun> # type term = C of int | Ab : string * 'a rep * term -> term | Ap of term * term | V of string -type 'a ctx = +type _ ctx = Cnil : rnil ctx | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx -# type 'a checked = - Cerror of string - | Cok : ('e, 't) lam * 't rep -> 'e checked -val lookup : string -> 'a ctx -> 'a checked = <fun> -# val tc : 'a nat -> 'b ctx -> term -> 'b checked = <fun> +# type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked +val lookup : string -> 'e ctx -> 'e checked = <fun> +# val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun> # val ctx0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons ctx = @@ -275,13 +273,13 @@ val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")) # val v2 : int = 6 # type pexp type pval -type 'a mode = Pexp : pexp mode | Pval : pval mode -type ('a, 'b) tarr +type _ mode = Pexp : pexp mode | Pval : pval mode +type (_, _) tarr type tint -type ('a, 'b) rel = +type (_, _) rel = IntR : (tint, int) rel | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel -type ('a, 'b, 'c) lam = +type (_, _, _) lam = Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam @@ -291,18 +289,18 @@ type ('a, 'b, 'c) lam = ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam # val ex1 : (pexp, 'a, tint) lam = App (Lam (<poly>, Var <poly>), Const (IntR, <poly>)) -val mode : ('a, 'b, 'c) lam -> 'a mode = <fun> -# type ('a, 'b) sub = +val mode : ('m, 'e, 't) lam -> 'm mode = <fun> +# type (_, _) sub = Id : ('r, 'r) sub | Bind : 't * ('m, 'r2, 'x) lam * ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub -type ('a, 'b) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' -# val subst : ('a, 'b, 'c) lam -> ('b, 'd) sub -> ('d, 'c) lam' = <fun> +type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' +# val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun> # type closed = rnil type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum # val rule : (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam = <fun> -# val onestep : ('a, closed, 'b) lam -> 'b rlam = <fun> +# val onestep : ('m, closed, 't) lam -> 't rlam = <fun> # diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference index a77459917c..4cf48a22c9 100644 --- a/testsuite/tests/typing-gadts/pr5332.ml.reference +++ b/testsuite/tests/typing-gadts/pr5332.ml.reference @@ -14,6 +14,6 @@ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Tbool, Tvar _) -val f : ('a, 'b) typ -> ('a, 'b) typ -> int = <fun> +val f : ('env, 'a) typ -> ('env, 'a) typ -> int = <fun> # Exception: Match_failure ("//toplevel//", 9, 1). # diff --git a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference index 3c6b335f67..cff10f16f9 100644 --- a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference +++ b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference @@ -7,48 +7,48 @@ | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty - type ('a, 'b) eq = Eq : ('a, 'a) eq + type (_, _) eq = Eq : ('a, 'a) eq exception CastFailure - val check_eq : 'a ty -> 'b ty -> ('a, 'b) eq - val gcast : 'a ty -> 'b ty -> 'a -> 'b + val check_eq : 't ty -> 't' ty -> ('t, 't') eq + val gcast : 't ty -> 't' ty -> 't -> 't' end # module HOAS : sig - type 'a term = + type _ term = Tag : 't Typeable.ty * int -> 't term | Con : 't -> 't term | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term | App : ('s -> 't) term * 's term -> 't term - val intp : 'a term -> 'a + val intp : 't term -> 't end # module DeBruijn : sig type ('env, 't) ix = ZeroIx : ('env * 't, 't) ix | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix - val to_int : ('a, 'b) ix -> int + val to_int : ('env, 't) ix -> int type ('env, 't) term = Var : ('env, 't) ix -> ('env, 't) term | Con : 't -> ('env, 't) term | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term - type 'a stack = + type _ stack = Empty : unit stack | Push : 'env stack * 't -> ('env * 't) stack - val prj : ('a, 'b) ix -> 'a stack -> 'b - val intp : ('a, 'b) term -> 'a stack -> 'b + val prj : ('env, 't) ix -> 'env stack -> 't + val intp : ('env, 't) term -> 'env stack -> 't end # module Convert : sig - type ('a, 'b) layout = + type (_, _) layout = EmptyLayout : ('env, unit) layout | PushLayout : 't Typeable.ty * ('env, 'env') layout * ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout - val size : ('a, 'b) layout -> int - val inc : ('a, 'b) layout -> ('a * 't, 'b) layout + val size : ('env, 'env') layout -> int + val inc : ('env, 'env') layout -> ('env * 't, 'env') layout val prj : - 'a Typeable.ty -> int -> ('b, 'c) layout -> ('b, 'a) DeBruijn.ix - val cvt : ('a, 'a) layout -> 'b HOAS.term -> ('a, 'b) DeBruijn.term + 't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix + val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term end # module Main : diff --git a/testsuite/tests/typing-gadts/term-conv.ml.reference b/testsuite/tests/typing-gadts/term-conv.ml.reference index 3c6b335f67..cff10f16f9 100644 --- a/testsuite/tests/typing-gadts/term-conv.ml.reference +++ b/testsuite/tests/typing-gadts/term-conv.ml.reference @@ -7,48 +7,48 @@ | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty - type ('a, 'b) eq = Eq : ('a, 'a) eq + type (_, _) eq = Eq : ('a, 'a) eq exception CastFailure - val check_eq : 'a ty -> 'b ty -> ('a, 'b) eq - val gcast : 'a ty -> 'b ty -> 'a -> 'b + val check_eq : 't ty -> 't' ty -> ('t, 't') eq + val gcast : 't ty -> 't' ty -> 't -> 't' end # module HOAS : sig - type 'a term = + type _ term = Tag : 't Typeable.ty * int -> 't term | Con : 't -> 't term | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term | App : ('s -> 't) term * 's term -> 't term - val intp : 'a term -> 'a + val intp : 't term -> 't end # module DeBruijn : sig type ('env, 't) ix = ZeroIx : ('env * 't, 't) ix | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix - val to_int : ('a, 'b) ix -> int + val to_int : ('env, 't) ix -> int type ('env, 't) term = Var : ('env, 't) ix -> ('env, 't) term | Con : 't -> ('env, 't) term | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term - type 'a stack = + type _ stack = Empty : unit stack | Push : 'env stack * 't -> ('env * 't) stack - val prj : ('a, 'b) ix -> 'a stack -> 'b - val intp : ('a, 'b) term -> 'a stack -> 'b + val prj : ('env, 't) ix -> 'env stack -> 't + val intp : ('env, 't) term -> 'env stack -> 't end # module Convert : sig - type ('a, 'b) layout = + type (_, _) layout = EmptyLayout : ('env, unit) layout | PushLayout : 't Typeable.ty * ('env, 'env') layout * ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout - val size : ('a, 'b) layout -> int - val inc : ('a, 'b) layout -> ('a * 't, 'b) layout + val size : ('env, 'env') layout -> int + val inc : ('env, 'env') layout -> ('env * 't, 'env') layout val prj : - 'a Typeable.ty -> int -> ('b, 'c) layout -> ('b, 'a) DeBruijn.ix - val cvt : ('a, 'a) layout -> 'b HOAS.term -> ('a, 'b) DeBruijn.term + 't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix + val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term end # module Main : diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 5e4458a981..f692325f1d 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -1,19 +1,19 @@ # module Exp : sig - type 'a t = + type _ t = IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t | Abs : ('a -> 'b) -> ('a -> 'b) t - val eval : 'a t -> 'a + val eval : 's t -> 's val discern : 'a t -> int end # module List : sig type zero - type 'a t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t + type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t val head : ('a * 'b) t -> 'a val tail : ('a * 'b) t -> 'b t val length : 'a t -> int @@ -35,17 +35,17 @@ module Nonexhaustive : sig type 'a u = C1 : int -> int u | C2 : bool -> bool u type 'a v = C1 : int -> int v - val unexhaustive : 'a u -> 'a + val unexhaustive : 's u -> 's module M : sig type t type u end type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t - val same_type : 'a t * 'a t -> bool + val same_type : 's t * 's t -> bool end # module Exhaustive : sig type t = int type u = bool type 'a v = Foo : t -> t v | Bar : u -> u v - val same_type : 'a v * 'a v -> bool + val same_type : 's v * 's v -> bool end # Characters 119-120: let eval (D x) = x @@ -76,7 +76,7 @@ Error: This expression has type bool but an expression was expected of type s ^ Error: This pattern matches values of type b but a pattern was expected which matches values of type a -# type 'a t = Int : int t +# type _ t = Int : int t # val ky : 'a -> 'a -> 'a = <fun> # val test : 'a t -> 'a = <fun> # val test : 'a t -> int = <fun> @@ -138,11 +138,11 @@ Error: This expression has type a = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> int -> int = <fun> -# type 'a h = Has_m : < m : int > h | Has_b : < b : bool > h +# type _ h = Has_m : < m : int > h | Has_b : < b : bool > h val f : 'a h -> 'a = <fun> -# type 'a j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j +# type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j val f : 'a j -> 'a = <fun> -# type ('a, 'b) eq = Eq : ('a, 'a) eq +# type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: ....f : type a b. (a,b) eq -> (<m : a; ..> as 'a) -> (<m : b; ..> as 'a) = fun Eq o -> o @@ -205,8 +205,8 @@ Error: This expression has type [> `A of a ] ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o.............. Error: This definition has type - ('c, 'd) eq -> ([< `A of 'd & 'c | `B ] as 'e) -> 'e - which is less general than 'a 'b. ('a, 'b) eq -> 'e -> 'e + ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c + which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun> # val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun> # Characters 166-167: @@ -226,7 +226,7 @@ Error: This expression has type [> `A of a | `B ] This instance of a is ambiguous: it would escape the scope of its equation # type 'a t = A of int | B of bool | C of float | D of 'a -type 'a ty = +type _ ty = TE : 'a ty -> 'a array ty | TA : int ty | TB : bool ty @@ -276,11 +276,11 @@ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun> # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun> -# type 'a t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t +# type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t val f : 'a t -> 'a = <fun> # - : [ `A | `B ] = `A -# type 'a int_foo = IF_constr : < foo : int; .. > int_foo -type 'a int_bar = IB_constr : < bar : int; .. > int_bar +# type _ int_foo = IF_constr : < foo : int; .. > int_foo +type _ int_bar = IB_constr : < bar : int; .. > int_bar # Characters 98-99: (x:<foo:int>) ^ diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index 3b62fdef83..8d05b4ffe8 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -1,19 +1,19 @@ # module Exp : sig - type 'a t = + type _ t = IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t | Abs : ('a -> 'b) -> ('a -> 'b) t - val eval : 'a t -> 'a + val eval : 's t -> 's val discern : 'a t -> int end # module List : sig type zero - type 'a t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t + type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t val head : ('a * 'b) t -> 'a val tail : ('a * 'b) t -> 'b t val length : 'a t -> int @@ -35,17 +35,17 @@ module Nonexhaustive : sig type 'a u = C1 : int -> int u | C2 : bool -> bool u type 'a v = C1 : int -> int v - val unexhaustive : 'a u -> 'a + val unexhaustive : 's u -> 's module M : sig type t type u end type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t - val same_type : 'a t * 'a t -> bool + val same_type : 's t * 's t -> bool end # module Exhaustive : sig type t = int type u = bool type 'a v = Foo : t -> t v | Bar : u -> u v - val same_type : 'a v * 'a v -> bool + val same_type : 's v * 's v -> bool end # Characters 119-120: let eval (D x) = x @@ -69,15 +69,15 @@ Error: This pattern matches values of type ([? `A ] as 'a) * bool t but a pattern was expected which matches values of type 'a * int t # module Propagation : sig - type 'a t = IntLit : int -> int t | BoolLit : bool -> bool t - val check : 'a t -> 'a + type _ t = IntLit : int -> int t | BoolLit : bool -> bool t + val check : 's t -> 's end # Characters 87-88: let f = function A -> 1 | B -> 2 ^ Error: This pattern matches values of type b but a pattern was expected which matches values of type a -# type 'a t = Int : int t +# type _ t = Int : int t # val ky : 'a -> 'a -> 'a = <fun> # val test : 'a t -> 'a = <fun> # val test : 'a t -> int = <fun> @@ -139,11 +139,11 @@ Error: This expression has type a = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> int -> int = <fun> -# type 'a h = Has_m : < m : int > h | Has_b : < b : bool > h +# type _ h = Has_m : < m : int > h | Has_b : < b : bool > h val f : 'a h -> 'a = <fun> -# type 'a j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j +# type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j val f : 'a j -> 'a = <fun> -# type ('a, 'b) eq = Eq : ('a, 'a) eq +# type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: ....f : type a b. (a,b) eq -> (<m : a; ..> as 'a) -> (<m : b; ..> as 'a) = fun Eq o -> o @@ -199,8 +199,8 @@ Error: This expression has type [> `A of a ] ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o.............. Error: This definition has type - ('c, 'd) eq -> ([< `A of 'd & 'c | `B ] as 'e) -> 'e - which is less general than 'a 'b. ('a, 'b) eq -> 'e -> 'e + ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c + which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun> # val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun> # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun> @@ -213,7 +213,7 @@ Error: This expression has type [> `A of a | `B ] This instance of a is ambiguous: it would escape the scope of its equation # type 'a t = A of int | B of bool | C of float | D of 'a -type 'a ty = +type _ ty = TE : 'a ty -> 'a array ty | TA : int ty | TB : bool ty @@ -263,11 +263,11 @@ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun> # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun> -# type 'a t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t +# type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t val f : 'a t -> 'a = <fun> # - : [ `A | `B ] = `A -# type 'a int_foo = IF_constr : < foo : int; .. > int_foo -type 'a int_bar = IB_constr : < bar : int; .. > int_bar +# type _ int_foo = IF_constr : < foo : int; .. > int_foo +type _ int_bar = IB_constr : < bar : int; .. > int_bar # Characters 98-99: (x:<foo:int>) ^ diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference index 5b1016c97c..ddae4d248e 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference @@ -15,8 +15,8 @@ Error: In this GADT definition, the variance of some parameter Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (IntLit, 0) -type 'a t = IntLit : int t | BoolLit : bool t -val check : 'a t * 'a -> bool = <fun> +type _ t = IntLit : int t | BoolLit : bool t +val check : 's t * 's -> bool = <fun> # Characters 91-180: .............................................function | {fst = BoolLit; snd = false} -> false @@ -25,5 +25,5 @@ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {fst=IntLit; snd=0} type ('a, 'b) pair = { fst : 'a; snd : 'b; } -val check : ('a t, 'a) pair -> bool = <fun> +val check : ('s t, 's) pair -> bool = <fun> # diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference index 5b1016c97c..ddae4d248e 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference @@ -15,8 +15,8 @@ Error: In this GADT definition, the variance of some parameter Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (IntLit, 0) -type 'a t = IntLit : int t | BoolLit : bool t -val check : 'a t * 'a -> bool = <fun> +type _ t = IntLit : int t | BoolLit : bool t +val check : 's t * 's -> bool = <fun> # Characters 91-180: .............................................function | {fst = BoolLit; snd = false} -> false @@ -25,5 +25,5 @@ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {fst=IntLit; snd=0} type ('a, 'b) pair = { fst : 'a; snd : 'b; } -val check : ('a t, 'a) pair -> bool = <fun> +val check : ('s t, 's) pair -> bool = <fun> # diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 19d20d8821..c7a5cb3d16 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -302,3 +302,26 @@ end;; let x = new d () in x#n, x#o;; class c () = object method virtual m : int method private m = 1 end;; + +(* Marshaling (cf. PR#5436) *) + +Oo.id (object end);; +Oo.id (object end);; +Oo.id (object end);; +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 + (Oo.id o, Oo.id o', Oo.id o'');; + +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 + (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + +let o = object val x = 33 val y = 44 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 + (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index a78367fdfe..4df2316922 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -292,4 +292,10 @@ Warning 10: this expression should have type unit. 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 +# - : int = 15 +# - : int = 16 +# - : int = 17 +# - : int * int * int = (18, 19, 20) +# - : int * int * int * int * int = (21, 22, 23, 33, 33) +# - : int * int * int * int * int = (24, 25, 26, 33, 33) # diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index 65043c786e..b953491622 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -576,8 +576,8 @@ val g : 'a -> int = <fun> # Characters 34-74: function Leaf _ -> 1 | Node x -> 1 + d x ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'b t -> int which is less general than - 'a. 'a t -> int +Error: This definition has type 'a t -> int which is less general than + 'a0. 'a0 t -> int # Characters 34-78: function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -586,12 +586,12 @@ Error: This definition has type int t -> int which is less general than # Characters 34-74: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'b t -> 'b which is less general than - 'a. 'a t -> 'b +Error: This definition has type 'a t -> 'a which is less general than + 'a0. 'a0 t -> 'a # Characters 38-78: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'c. 'c t -> 'c which is less general than +Error: This definition has type 'b. 'b t -> 'b which is less general than 'b 'a. 'a t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = <fun> diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 37601416bb..71befc5820 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -539,8 +539,8 @@ val g : 'a -> int = <fun> # Characters 34-74: function Leaf _ -> 1 | Node x -> 1 + d x ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'b t -> int which is less general than - 'a. 'a t -> int +Error: This definition has type 'a t -> int which is less general than + 'a0. 'a0 t -> int # Characters 34-78: function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -549,12 +549,12 @@ Error: This definition has type int t -> int which is less general than # Characters 34-74: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'b t -> 'b which is less general than - 'a. 'a t -> 'b +Error: This definition has type 'a t -> 'a which is less general than + 'a0. 'a0 t -> 'a # Characters 38-78: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This definition has type 'c. 'c t -> 'c which is less general than +Error: This definition has type 'b. 'b t -> 'b which is less general than 'b 'a. 'a t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = <fun> diff --git a/testsuite/tests/typing-private-bugs/pr5469_ok.ml b/testsuite/tests/typing-private-bugs/pr5469_ok.ml new file mode 100644 index 0000000000..74d355499c --- /dev/null +++ b/testsuite/tests/typing-private-bugs/pr5469_ok.ml @@ -0,0 +1,7 @@ +module M (T:sig type t end) + = struct type t = private { t : T.t } end +module P + = struct + module T = struct type t end + module R = M(T) + end diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile index eca0a1ee7b..12d375e4a7 100644 --- a/testsuite/tests/warnings/Makefile +++ b/testsuite/tests/warnings/Makefile @@ -6,7 +6,7 @@ run-all: @for file in *.ml; do \ printf " ... testing '$$file':"; \ $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2> `basename $$file ml`result; \ - diff -q `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \ + $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \ done; promote: defaultpromote |