diff options
Diffstat (limited to 'testsuite/tests')
170 files changed, 3191 insertions, 397 deletions
diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index aa37bf9e4..501d0594d 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -23,7 +23,7 @@ INCLUDES=\ OTHEROBJS=\ $(OTOPDIR)/compilerlibs/ocamlcommon.cma \ - $(OTOPDIR)/compilerlibs/ocamloptcomp.cma + $(OTOPDIR)/compilerlibs/ocamloptcomp.cma OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo diff --git a/testsuite/tests/asmcomp/arm64.S b/testsuite/tests/asmcomp/arm64.S index 3bb411061..7b839c44a 100644 --- a/testsuite/tests/asmcomp/arm64.S +++ b/testsuite/tests/asmcomp/arm64.S @@ -12,21 +12,21 @@ .globl call_gen_code .align 2 -call_gen_code: +call_gen_code: /* Set up stack frame and save callee-save registers */ - stp x29, x30, [sp, -160]! - add x29, sp, #0 + stp x29, x30, [sp, -160]! + add x29, sp, #0 stp x19, x20, [sp, 16] stp x21, x22, [sp, 32] stp x23, x24, [sp, 48] stp x25, x26, [sp, 64] stp x27, x28, [sp, 80] - stp d8, d9, [sp, 96] + stp d8, d9, [sp, 96] stp d10, d11, [sp, 112] stp d12, d13, [sp, 128] stp d14, d15, [sp, 144] /* Shuffle arguments */ - mov x8, x0 + mov x8, x0 mov x0, x1 mov x1, x2 mov x2, x3 @@ -39,14 +39,14 @@ call_gen_code: ldp x23, x24, [sp, 48] ldp x25, x26, [sp, 64] ldp x27, x28, [sp, 80] - ldp d8, d9, [sp, 96] + ldp d8, d9, [sp, 96] ldp d10, d11, [sp, 112] ldp d12, d13, [sp, 128] ldp d14, d15, [sp, 144] - ldp x29, x30, [sp], 160 + ldp x29, x30, [sp], 160 ret .globl caml_c_call .align 2 caml_c_call: - br x15 + br x15 diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll index e9efdb60f..4c262b112 100644 --- a/testsuite/tests/asmcomp/lexcmm.mll +++ b/testsuite/tests/asmcomp/lexcmm.mll @@ -81,7 +81,7 @@ let keyword_table = (* To buffer string literals *) -let initial_string_buffer = String.create 256 +let initial_string_buffer = Bytes.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 @@ -90,16 +90,16 @@ let reset_string_buffer () = string_index := 0 let store_string_char c = - if !string_index >= String.length (!string_buff) then begin - let new_buff = String.create (String.length (!string_buff) * 2) in - String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); - string_buff := new_buff + if !string_index >= Bytes.length (!string_buff) then begin + let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in + Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff)); + string_buff := new_buff end; - String.unsafe_set (!string_buff) (!string_index) c; + Bytes.unsafe_set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = - let s = String.sub (!string_buff) 0 (!string_index) in + let s = Bytes.sub_string (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; s diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index f935391b5..d102c16dc 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -33,25 +33,29 @@ double F, G; #define INTTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, X, Y, arg, result); \ } #define INTFLOATTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATINTTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, X, Y, arg, result); \ } diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml index d50867239..92705bd25 100644 --- a/testsuite/tests/asmcomp/optargs.ml +++ b/testsuite/tests/asmcomp/optargs.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of inlining the wrapper which fills in default values for optional arguments. @@ -18,6 +30,4 @@ let () = done; let x2 = Gc.allocated_bytes () in assert(x1 -. x0 = x2 -. x1) - (* check that we did not allocated anything between x1 and x2 *) - - + (* check that we have not allocated anything between x1 and x2 *) diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index ad697b6f4..e936c2587 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -24,9 +24,9 @@ let rec make_letdef def body = Clet(id, def, make_letdef rem body) let make_switch n selector caselist = - let index = Array.create n 0 in + let index = Array.make n 0 in let casev = Array.of_list caselist in - let actv = Array.create (Array.length casev) (Cexit(0,[])) in + let actv = Array.make (Array.length casev) (Cexit(0,[])) in for i = 0 to Array.length casev - 1 do let (posl, e) = casev.(i) in List.iter (fun pos -> index.(pos) <- i) posl; @@ -172,7 +172,7 @@ componentlist: ; expr: INTCONST { Cconst_int $1 } - | FLOATCONST { Cconst_float $1 } + | FLOATCONST { Cconst_float (float_of_string $1) } | STRING { Cconst_symbol $1 } | POINTER { Cconst_pointer $1 } | IDENT { Cvar(find_ident $1) } @@ -316,7 +316,7 @@ dataitem: | BYTE INTCONST { Cint8 $2 } | HALF INTCONST { Cint16 $2 } | INT INTCONST { Cint(Nativeint.of_int $2) } - | FLOAT FLOATCONST { Cdouble $2 } + | FLOAT FLOATCONST { Cdouble (float_of_string $2) } | ADDR STRING { Csymbol_address $2 } | ADDR INTCONST { Clabel_address $2 } | KSTRING STRING { Cstring $2 } diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S index 53c5fc902..ea029573a 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -11,11 +11,11 @@ /***********************************************************************/ #if defined(SYS_solaris) || defined(SYS_elf) -#define Call_gen_code _call_gen_code -#define Caml_c_call _caml_c_call -#else #define Call_gen_code call_gen_code #define Caml_c_call caml_c_call +#else +#define Call_gen_code _call_gen_code +#define Caml_c_call _caml_c_call #endif .global Call_gen_code diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml index e21fdee63..3186686c7 100644 --- a/testsuite/tests/asmcomp/staticalloc.ml +++ b/testsuite/tests/asmcomp/staticalloc.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of structured constant propagation and static allocation. diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 32533fd60..33ca1ed8b 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -14,7 +14,9 @@ BASEDIR=../.. EXECNAME=program$(EXE) ABCDFILES=backtrace.ml -OTHERFILES=backtrace2.ml raw_backtrace.ml +OTHERFILES=backtrace2.ml raw_backtrace.ml \ + backtrace_deprecated.ml backtrace_slots.ml +OTHERFILESNOINLINING=backtraces_and_finalizers.ml default: $(MAKE) byte @@ -68,6 +70,16 @@ native: >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ + done; + @for file in $(OTHERFILESNOINLINING); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlopt:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.native.result 2>&1; \ + $(DIFF) $$F.reference $$F.native.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ done .PHONY: promote diff --git a/testsuite/tests/backtrace/backtrace_deprecated.ml b/testsuite/tests/backtrace/backtrace_deprecated.ml new file mode 100644 index 000000000..7ec5152d0 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 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. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +external get_backtrace : unit -> Printexc.backtrace_slot array option + = "caml_get_exception_backtrace" + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> function + | None -> () + | Some trace -> + Array.iteri + (fun i slot -> match Printexc.Slot.format i slot with + | None -> () + | Some line -> print_endline line) + trace + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_deprecated.reference b/testsuite/tests/backtrace/backtrace_deprecated.reference new file mode 100644 index 000000000..e9fea9ffe --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_deprecated.Error("b") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Re-raised at file "backtrace_deprecated.ml", line 27, characters 68-71 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("c") +Raised at file "backtrace_deprecated.ml", line 28, characters 26-37 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("d") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_deprecated.ml", line 32, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.ml b/testsuite/tests/backtrace/backtrace_slots.ml new file mode 100644 index 000000000..8419c6190 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 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. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +let get_backtrace () = + let raw_backtrace = Printexc.get_raw_backtrace () in + let raw_slots = + Array.init (Printexc.raw_backtrace_length raw_backtrace) + (Printexc.get_raw_backtrace_slot raw_backtrace) in + let convert = Printexc.convert_raw_backtrace_slot in + let backtrace = Array.map convert raw_slots in + (* we'll play with raw slots a bit to check that hashing and comparison work: + - create a hashtable that maps slots to their index in the raw backtrace + - create a balanced set of all slots + *) + let table = Hashtbl.create 100 in + Array.iteri (fun i slot -> Hashtbl.add table slot i) raw_slots; + let module S = Set.Make(struct + type t = Printexc.raw_backtrace_slot + let compare = Pervasives.compare + end) in + let slots = Array.fold_right S.add raw_slots S.empty in + Array.iteri (fun i slot -> + assert (S.mem slot slots); + assert (Hashtbl.mem table slot); + let j = + (* position in the table of the last slot equal to [slot] *) + Hashtbl.find table slot in + assert (slot = raw_slots.(j)); + assert (backtrace.(i) = backtrace.(j)); + ) raw_slots; + backtrace + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> Array.iteri + (fun i slot -> match Printexc.Slot.format i slot with + | None -> () + | Some line -> print_endline line) + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_slots.reference b/testsuite/tests/backtrace/backtrace_slots.reference new file mode 100644 index 000000000..2336cd5ac --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_slots.Error("b") +Raised at file "backtrace_slots.ml", line 47, characters 21-32 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 51, characters 4-11 +Re-raised at file "backtrace_slots.ml", line 53, characters 68-71 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Backtrace_slots.Error("c") +Raised at file "backtrace_slots.ml", line 54, characters 26-37 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Backtrace_slots.Error("d") +Raised at file "backtrace_slots.ml", line 47, characters 21-32 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 51, characters 4-11 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_slots.ml", line 58, characters 14-22 diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml new file mode 100644 index 000000000..22acf1af8 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml @@ -0,0 +1,25 @@ +let () = Printexc.record_backtrace true + +let finaliser _ = try raise Exit with _ -> () + +let create () = + let x = ref () in + Gc.finalise finaliser x; + x + +let f () = raise Exit + +let () = + let minor_size = (Gc.get ()).Gc.minor_heap_size in + for i = 1 to 100 do + Gc.minor (); + try + ignore (create () : unit ref); + f () + with _ -> + for i = 1 to minor_size / 2 - 1 do + ignore (ref ()) + done; + ignore (Printexc.get_backtrace () : string) + done; + Printf.printf "ok\n" diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference new file mode 100644 index 000000000..9766475a4 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml index 14e458cdd..8c71206a8 100644 --- a/testsuite/tests/basic-io-2/io.ml +++ b/testsuite/tests/basic-io-2/io.ml @@ -25,7 +25,7 @@ let test msg funct f1 f2 = let copy_file sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in - let buffer = String.create sz in + let buffer = Bytes.create sz in let rec copy () = let n = input ic buffer 0 sz in if n = 0 then () else begin @@ -41,7 +41,7 @@ let copy_file sz infile ofile = let copy_random sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in - let buffer = String.create sz in + let buffer = Bytes.create sz in let rec copy () = let s = 1 + Random.int sz in let n = input ic buffer 0 s in @@ -72,7 +72,7 @@ let copy_seek chunksize infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in let size = in_channel_length ic in - let buffer = String.create chunksize in + let buffer = Bytes.create chunksize in for i = (size - 1) / chunksize downto 0 do seek_in ic (i * chunksize); seek_out oc (i * chunksize); diff --git a/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile new file mode 100644 index 000000000..62dbc2a69 --- /dev/null +++ b/testsuite/tests/basic-modules/Makefile @@ -0,0 +1,19 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. + +MODULES=offset +MAIN_MODULE=main + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml new file mode 100644 index 000000000..54f8cbd61 --- /dev/null +++ b/testsuite/tests/basic-modules/main.ml @@ -0,0 +1,13 @@ +(* PR#6435 *) + +module F (M : sig + type t + module Set : Set.S with type elt = t + end) = +struct + let test set = Printf.printf "%d\n" (M.Set.cardinal set) +end + +module M = F (Offset) + +let () = M.test (Offset.M.Set.singleton "42") diff --git a/testsuite/tests/basic-modules/main.reference b/testsuite/tests/basic-modules/main.reference new file mode 100644 index 000000000..d00491fd7 --- /dev/null +++ b/testsuite/tests/basic-modules/main.reference @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml new file mode 100644 index 000000000..457947dcd --- /dev/null +++ b/testsuite/tests/basic-modules/offset.ml @@ -0,0 +1,10 @@ +module M = struct + type t = string + + let x = 0 + let x = 1 + + module Set = Set.Make(String) +end + +include M diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml new file mode 100644 index 000000000..f0a9d6a4f --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.ml @@ -0,0 +1,17 @@ +open Printf + +let bug () = + let mat = [| [|false|] |] + and test = ref false in + printf "Value of test at the beginning : %b\n" !test; flush stdout; + (try let _ = mat.(0).(-1) in + (test := true; + printf "Am I going through this block of instructions ?\n"; + flush stdout) + with Invalid_argument _ -> printf "Value of test now : %b\n" !test + ); + (try if mat.(0).(-1) then () + with Invalid_argument _ -> () + ) + +let () = bug () diff --git a/testsuite/tests/basic-more/pr2719.reference b/testsuite/tests/basic-more/pr2719.reference new file mode 100644 index 000000000..073d0916d --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.reference @@ -0,0 +1,4 @@ +Value of test at the beginning : false +Value of test now : false + +All tests succeeded. diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml index 9ea9366f5..5777739fe 100644 --- a/testsuite/tests/basic-more/tprintf.ml +++ b/testsuite/tests/basic-more/tprintf.ml @@ -20,7 +20,8 @@ let test0 () = sprintf "%.0f" 1.0 = "1" && sprintf "%.0f." 1.7 = "2." && sprintf "%.1f." 1.0 = "1.0." && - sprintf "%0.1f." 12.0 = "12.0." && + (*sprintf "%0.1f." 12.0 = "12.0." &&*) + (* >> '0' w/o padding *) sprintf "%3.1f." 12.0 = "12.0." && sprintf "%5.1f." 12.0 = " 12.0." && sprintf "%10.1f." 12.0 = " 12.0." && @@ -33,7 +34,8 @@ let test0 () = sprintf "%010.0f." 12.0 = "0000000012." && sprintf "% 10.0f." 12.0 = " 12." && - sprintf "%0.1f." 12.0 = "12.0." && + (*sprintf "%0.1f." 12.0 = "12.0." &&*) + (* >> '0' w/o padding *) sprintf "%10.1f." 1.001 = " 1.0." && sprintf "%05.1f." 1.001 = "001.0." ;; @@ -59,8 +61,9 @@ test (test2 ());; (* Testing meta format string printing. *) let test3 () = -sprintf "%{toto %s titi.\n%}" "Bonjour %s." = "%s" && -sprintf "%{%d%s%}" "kk%dkk%s\n" = "%i%s";; + sprintf "%{toto %S titi.\n%}" "Bonjour %S." = "%s" && + sprintf "%{Bonjour %S.%}" "toto %S titi.\n" = "%s" +;; test (test3 ());; (* Testing meta format string arguments. *) diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml index e123edff6..b56893f5e 100644 --- a/testsuite/tests/basic/arrays.ml +++ b/testsuite/tests/basic/arrays.ml @@ -79,7 +79,7 @@ let test3 () = and t2 = AbstractFloat.from_float 2.0 and t3 = AbstractFloat.from_float 3.0 in let v = [|t1;t2;t3|] in - let w = Array.create 2 t1 in + let w = Array.make 2 t1 in let u = Array.copy v in if not (AbstractFloat.to_float v.(0) = 1.0 && AbstractFloat.to_float v.(1) = 2.0 && diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml new file mode 100644 index 000000000..666129131 --- /dev/null +++ b/testsuite/tests/basic/constprop.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* 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 constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" ((-x, x + y, x - y, x * y, x / y, x mod y, x land y, x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y, x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y)) ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh, xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y, x <> y, x < y, x <= y, x > y, x >= y)) ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x)) ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x)) ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x)) ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x)) ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh)) + end diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp new file mode 100644 index 000000000..305a98dd9 --- /dev/null +++ b/testsuite/tests/basic/constprop.mlp @@ -0,0 +1,130 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* 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 constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) + +#define tbool(x,y) \ + (x && y, x || y, not x) + +#define tint(x,y,s) \ + (-x, x + y, x - y, x * y, x / y, x mod y, \ + x land y, x lor y, x lxor y, \ + x lsl s, x lsr s, x asr s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y, \ + succ x, pred y) + +#define tfloat(x,y) \ + (int_of_float x, \ + x +. y, x -. y, x *. y, x /. y, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tconvint(i) \ + (float_of_int i, \ + Int32.of_int i, \ + Nativeint.of_int i, \ + Int64.of_int i) + +#define tconvint32(i) \ + (Int32.to_int i, \ + Nativeint.of_int32 i, \ + Int64.of_int32 i) + +#define tconvnativeint(i) \ + (Nativeint.to_int i, \ + Nativeint.to_int32 i, \ + Int64.of_nativeint i) + +#define tconvint64(i) \ + (Int64.to_int i, \ + Int64.to_int32 i, \ + Int64.to_nativeint i) \ + +#define tint32(x,y,s) \ + Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tnativeint(x,y,s) \ + Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tint64(x,y,s) \ + Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") + +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 + +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" (tbool(x, y)) (tbool(xh,yh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" (tfloat(x, y)) (tfloat(xh, yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" (tconvint(x)) (tconvint(xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" (tconvnativeint(x)) (tconvnativeint(xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh)) + end + diff --git a/testsuite/tests/basic/constprop.reference b/testsuite/tests/basic/constprop.reference new file mode 100644 index 000000000..59590530a --- /dev/null +++ b/testsuite/tests/basic/constprop.reference @@ -0,0 +1,10 @@ +booleans: passed +integers: passed +floats: passed +32-bit integers: passed +native integers: passed +64-bit integers: passed +integer conversions: passed +32-bit integer conversions: passed +native integer conversions: passed +64-bit integer conversions: passed diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml index 6dd4be3fc..52d14b9c8 100644 --- a/testsuite/tests/basic/divint.ml +++ b/testsuite/tests/basic/divint.ml @@ -32,7 +32,7 @@ let test_one (df: int -> int) (mf: int -> int) x = let do_test divisor (df: int -> int) (mf: int -> int) = d := divisor; List.iter (test_one df mf) - [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; + [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 100; 1000; 10000; 100000; 1000000; max_int - 1; max_int; -1; -2; -3; -4; -5; -6; -7; -8; -9; -10; -100; -1000; -10000; -100000; -1000000; min_int + 1; min_int]; @@ -59,7 +59,7 @@ let test_one (df: nativeint -> nativeint) (mf: nativeint -> nativeint) x = let do_test divisor (df: nativeint -> nativeint) (mf: nativeint -> nativeint) = d := Nativeint.of_int divisor; List.iter (test_one df mf) - [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; + [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; 100n; 1000n; 10000n; 100000n; 1000000n; Nativeint.(pred max_int); Nativeint.max_int; -1n; -2n; -3n; -4n; -5n; -6n; -7n; -8n; -9n; -10n; diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index 199f6fe4d..38b0d2b0c 100644 --- a/testsuite/tests/basic/maps.ml +++ b/testsuite/tests/basic/maps.ml @@ -19,7 +19,18 @@ let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m let () = print_endline "Union+concat"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, None | None, Some x -> Some x | Some x, Some y -> Some (x ^ x) | _ -> assert false) m1 m2); + let f1 _ l r = + match l, r with + | Some x, None | None, Some x -> Some x + | Some x, Some y -> Some (x ^ x) + | _ -> assert false + in + show (IntMap.merge f1 m1 m2); print_endline "Inter"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); + let f2 _ l r = + match l, r with + | Some x, Some y when x = y -> Some x + | _ -> None + in + show (IntMap.merge f2 m1 m2); () diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml index 666acb45f..4b33206ee 100644 --- a/testsuite/tests/basic/tailcalls.ml +++ b/testsuite/tests/basic/tailcalls.ml @@ -32,9 +32,22 @@ let indtailcall8 fn a b c d e f g h = let indtailcall16 fn a b c d e f g h i j k l m n o p = fn a b c d e f g h i j k l m n o p +(* regression test for PR#6441: *) +let rec tailcall16_value_closures a b c d e f g h i j k l m n o p = + if a < 0 + then b + else tailcall16_value_closures + (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) + (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15) +and fs = [tailcall16_value_closures] + let _ = print_int (tailcall4 10000000 0 0 0); print_newline(); print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline(); - print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline(); + print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline(); print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline(); - print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline() + print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline(); + print_int (tailcall16_value_closures 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline() diff --git a/testsuite/tests/basic/tailcalls.reference b/testsuite/tests/basic/tailcalls.reference index 0943aba55..c7117bc95 100644 --- a/testsuite/tests/basic/tailcalls.reference +++ b/testsuite/tests/basic/tailcalls.reference @@ -3,3 +3,4 @@ 10000001 11 11 +10000001 diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml index 121cec36f..b3e9b7e29 100644 --- a/testsuite/tests/embedded/cmcaml.ml +++ b/testsuite/tests/embedded/cmcaml.ml @@ -18,7 +18,7 @@ let rec fib n = let format_result n = let r = "Result = " ^ string_of_int n in (* Allocate gratuitously to test GC *) - for i = 1 to 1500 do ignore (String.create 256) done; + for i = 1 to 1500 do ignore (Bytes.create 256) done; r (* Registration *) diff --git a/testsuite/tests/formats-transition/Makefile b/testsuite/tests/formats-transition/Makefile new file mode 100644 index 000000000..9625a3fbc --- /dev/null +++ b/testsuite/tests/formats-transition/Makefile @@ -0,0 +1,3 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml new file mode 100644 index 000000000..3127d773a --- /dev/null +++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml @@ -0,0 +1,22 @@ +(* %n, %l, %N and %L have a scanf-specific semantics, but are supposed + to be interpreted by Printf and Format as %u, despite this + interpretation being mildly deprecated *) + +let test format = (Printf.sprintf format (-3) : string) +;; + +let () = Printf.printf "%%n: %B\n" + (test "%n" = test "%u") +;; + +let () = Printf.printf "%%l: %B\n" + (test "%l" = test "%u") +;; + +let () = Printf.printf "%%N: %B\n" + (test "%N" = test "%u") +;; + +let () = Printf.printf "%%L: %B\n" + (test "%L" = test "%u") +;; diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference new file mode 100644 index 000000000..0afeaa2be --- /dev/null +++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference @@ -0,0 +1,7 @@ + +# * * val test : (int -> string, unit, string) format -> string = <fun> +# %n: true +# %l: true +# %N: true +# %L: true +# diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml b/testsuite/tests/formats-transition/ignored_scan_counters.ml new file mode 100644 index 000000000..706a1af6f --- /dev/null +++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml @@ -0,0 +1,30 @@ +(* Benoît's patch did not support %_[nlNL]; test their behavior *) + +(* not supported by Printf or Format: fails at runtime *) +let () = Printf.printf "%_n" +;; +let () = Printf.printf "%_N" +;; +let () = Printf.printf "%_l" +;; +let () = Printf.printf "%_L" +;; + +let () = Format.printf "%_n" +;; +let () = Format.printf "%_N" +;; +let () = Format.printf "%_l" +;; +let () = Format.printf "%_L" +;; + +(* identity for Scanf *) +let () = print_endline (Scanf.sscanf "" "%_n" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_N" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_l" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_L" "Hello World!") +;; diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference new file mode 100644 index 000000000..6d8d098b5 --- /dev/null +++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference @@ -0,0 +1,14 @@ + +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Hello World! +# Hello World! +# Hello World! +# Hello World! +# diff --git a/testsuite/tests/formats-transition/invalid_formats.ml b/testsuite/tests/formats-transition/invalid_formats.ml new file mode 100644 index 000000000..71f796b04 --- /dev/null +++ b/testsuite/tests/formats-transition/invalid_formats.ml @@ -0,0 +1,4 @@ +(* Empty file added to create a conflict with branch 4.02 because + the test only makes sense on 4.02.x and will not work on 4.03+ + When merging, don't forget to remove also the .ml.reference file. + *) diff --git a/testsuite/tests/formats-transition/legacy_incompatible_flags.ml b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml new file mode 100644 index 000000000..53cf5c26c --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml @@ -0,0 +1,20 @@ +(* the legacy parser ignores flags on formatters on which they make no + sense *) + +let () = Printf.printf "%+s\n" "toto" +;; +let () = Printf.printf "%#s\n" "toto" +;; +let () = Printf.printf "% s\n" "toto" +;; +let () = Printf.printf "%03s\n" "toto" +;; +let () = Printf.printf "%03S\n" "toto" +;; +let () = Printf.printf "%.3s\n" "toto" +;; + +(* it still fails on flags used with ignored formats (%_d, etc.), + but it's unclear how to test that in a backward-compatible way, + if we accept that the error message may have changed +*) diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml new file mode 100644 index 000000000..16eca40c1 --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml @@ -0,0 +1,18 @@ +(* test whether padding modifiers are accepted without any padding + size + + the precision modifier is accepted without precision setting, but it + defaults to 0, which is not the same thing as not having precision: + %.0f 3.5 => 3 + %.f 3.5 => 3 + %f 3.5 => 3.5 +*) + +let () = Printf.printf "%0d\n" 3 +;; +let () = Printf.printf "%-d\n" 3 +;; +let () = Printf.printf "%.d\n" 3 +;; +let () = Printf.printf "%.f\n" 3. +;; diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference new file mode 100644 index 000000000..81c05c0dd --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference @@ -0,0 +1,6 @@ + +# * * * * * * * * 3 +# 3 +# 3 +# 3 +# diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c index 9a1cc843a..f7bb32cea 100644 --- a/testsuite/tests/gc-roots/globrootsprim.c +++ b/testsuite/tests/gc-roots/globrootsprim.c @@ -16,10 +16,12 @@ #include "mlvalues.h" #include "memory.h" #include "alloc.h" +#include "gc.h" -struct block { value v; }; +struct block { value header; value v; }; -#define Block_val(v) ((struct block *) (v)) +#define Block_val(v) ((struct block*) &((value*) v)[-1]) +#define Val_block(b) ((value) &((b)->v)) value gb_get(value vblock) { @@ -29,9 +31,10 @@ value gb_get(value vblock) value gb_classic_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); + b->header = Make_header(1, 0, Caml_black); b->v = v; caml_register_global_root(&(b->v)); - return (value) b; + return Val_block(b); } value gb_classic_set(value vblock, value newval) @@ -49,9 +52,10 @@ value gb_classic_remove(value vblock) value gb_generational_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); + b->header = Make_header(1, 0, Caml_black); b->v = v; caml_register_generational_global_root(&(b->v)); - return (value) b; + return Val_block(b); } value gb_generational_set(value vblock, value newval) diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml index c259061eb..906826fae 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml +++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml @@ -38,10 +38,14 @@ let test test_number answer correct_answer = (* External C and Fortran functions *) -external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab" -external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" -external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" -external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" +external c_filltab : + unit -> (float, float64_elt, c_layout) Array2.t = "c_filltaab" +external c_printtab : + (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" +external fortran_filltab : + unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" +external fortran_printtab : + (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" let _ = diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 333c17547..5ac8e7f74 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -433,7 +433,8 @@ let _ = (check_array2 (make_array2 float64 c_layout 0 10 20 float) 0 10 20 float); test 6 true - (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id); + (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) + 1 10 20 id); test 7 true (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id); test 8 true @@ -494,10 +495,14 @@ let _ = test 1 true !ok; let b = Array2.create float32 fortran_layout 3 3 in - for i = 1 to 3 do for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done done; + for i = 1 to 3 do + for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done + done; let ok = ref true in for i = 1 to 3 do - for j = 1 to 3 do if Array2.unsafe_get b i j <> float(i-j) then ok := false done + for j = 1 to 3 do + if Array2.unsafe_get b i j <> float(i-j) then ok := false + done done; test 2 true !ok; @@ -541,9 +546,12 @@ let _ = test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]); test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]); let a = make_array2 int fortran_layout 1 5 3 id in - test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]); - test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]); - test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]); + test 6 (Array2.slice_right a 1) + (from_list_fortran int [1001;2001;3001;4001;5001]); + test 7 (Array2.slice_right a 2) + (from_list_fortran int [1002;2002;3002;4002;5002]); + test 8 (Array2.slice_right a 3) + (from_list_fortran int [1003;2003;3003;4003;5003]); (* Tri-dimensional arrays *) @@ -587,7 +595,8 @@ let _ = (check_array3 (make_array3 float64 c_layout 0 4 5 6 float) 0 4 5 6 float); test 6 true - (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id); + (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) + 1 4 5 6 id); test 7 true (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id); test 8 true @@ -641,7 +650,8 @@ let _ = done done done; let ok = ref true in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do - if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k then ok := false + if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k + then ok := false done done done; test 1 true !ok; @@ -675,7 +685,8 @@ let _ = let c = reshape_1 (genarray_of_array2 a) 12 in test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]); let d = reshape_1 (genarray_of_array2 b) 12 in - test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); + test 2 d (from_list_fortran int + [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); testing_function "reshape_2"; let c = reshape_2 (genarray_of_array2 a) 4 3 in test 1 (Array2.slice_left c 0) (from_list int [0;1;2]); @@ -718,7 +729,8 @@ let _ = test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int); test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float); test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex); - test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex); + test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 + makecomplex); testing_function "map_file"; let mapped_file = Filename.temp_file "bigarray" ".data" in diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml index 66cd46750..f9bcf9289 100644 --- a/testsuite/tests/lib-digest/md5.ml +++ b/testsuite/tests/lib-digest/md5.ml @@ -201,7 +201,9 @@ let test hex s = let res = finish ctx in let exp = Digest.string s in let ok = res = exp && Digest.to_hex exp = hex in - if not ok then Printf.printf "Failure for %S : %S %S %S %S\n" s res exp (Digest.to_hex exp) hex; + if not ok then + Printf.printf "Failure for %S : %S %S %S %S\n" s res exp + (Digest.to_hex exp) hex; ok let time msg iter fn = @@ -215,12 +217,16 @@ let _ = if test "d41d8cd98f00b204e9800998ecf8427e" "" && test "0cc175b9c0f1b6a831c399e269772661" "a" && test "900150983cd24fb0d6963f7d28e17f72" "abc" - && test "8215ef0796a20bcaaae116d3876c664a" "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + && test "8215ef0796a20bcaaae116d3876c664a" + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" && test "7707d6ae4e027c70eea2a935c2296f21" (String.make 1_000_000 'a') && test "f96b697d7cb7938d525a2f31aaf161d0" "message digest" - && test "d174ab98d277d9f5a5611c2c9f419d9f" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - && test "9e107d9d372bb6826bd81d3542a419d6" "The quick brown fox jumps over the lazy dog" - && test "e4d909c290d0fb1ca068ffaddf22cbd0" "The quick brown fox jumps over the lazy dog." + && test "d174ab98d277d9f5a5611c2c9f419d9f" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + && test "9e107d9d372bb6826bd81d3542a419d6" + "The quick brown fox jumps over the lazy dog" + && test "e4d909c290d0fb1ca068ffaddf22cbd0" + "The quick brown fox jumps over the lazy dog." then printf "Test vectors passed.\n"; flush stdout; (* Benchmark *) diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c index f97c66f3e..60c8ab35a 100644 --- a/testsuite/tests/lib-dynlink-bytecode/stub1.c +++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c @@ -16,8 +16,9 @@ #include <stdio.h> value stub1() { + CAMLparam0(); CAMLlocal1(x); printf("This is stub1!\n"); fflush(stdout); x = caml_copy_string("ABCDEF"); - return x; + CAMLreturn(x); } diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c index a82eb46f6..b5d11636e 100755 --- a/testsuite/tests/lib-dynlink-csharp/entry.c +++ b/testsuite/tests/lib-dynlink-csharp/entry.c @@ -22,8 +22,8 @@ # define _DLLAPI __declspec(dllexport) # else # define _DLLAPI extern -# endif -# if defined(__MINGW32__) || defined(UNDER_CE) +# endif +# if defined(__MINGW32__) || defined(UNDER_CE) # define _CALLPROC # else # define _CALLPROC __stdcall diff --git a/testsuite/tests/lib-format/Makefile b/testsuite/tests/lib-format/Makefile index 0b385ca4b..7a6297b6f 100644 --- a/testsuite/tests/lib-format/Makefile +++ b/testsuite/tests/lib-format/Makefile @@ -14,5 +14,7 @@ MAIN_MODULE=tformat ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib ADD_MODULES=testing -include ../../makefiles/Makefile.one -include ../../makefiles/Makefile.common +BASEDIR=../.. + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml index 0ff127579..8a3c1cfc0 100644 --- a/testsuite/tests/lib-hashtbl/hfun.ml +++ b/testsuite/tests/lib-hashtbl/hfun.ml @@ -35,7 +35,8 @@ let _ = printf "+infty\t\t%08x\n" (Hashtbl.hash infinity); printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity); printf "NaN\t\t%08x\n" (Hashtbl.hash nan); - printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); + printf "NaN#2\t\t%08x\n" + (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0)); printf "-- Native integers:\n"; diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml index 41f24bb65..27ffd64d2 100644 --- a/testsuite/tests/lib-marshal/intext.ml +++ b/testsuite/tests/lib-marshal/intext.ml @@ -230,7 +230,8 @@ let test_string () = t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in - test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 122 + (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in let s = Marshal.to_string (big 1000) [] in let rec check_big n t = @@ -248,76 +249,77 @@ let marshal_to_buffer s start len v flags = ;; let test_buffer () = - let s = String.create 512 in + let s = Bytes.create 512 in marshal_to_buffer s 0 512 1 []; - test 201 (Marshal.from_string s 0 = 1); + test 201 (Marshal.from_bytes s 0 = 1); marshal_to_buffer s 0 512 (-1) []; - test 202 (Marshal.from_string s 0 = (-1)); + test 202 (Marshal.from_bytes s 0 = (-1)); marshal_to_buffer s 0 512 258 []; - test 203 (Marshal.from_string s 0 = 258); + test 203 (Marshal.from_bytes s 0 = 258); marshal_to_buffer s 0 512 20000 []; - test 204 (Marshal.from_string s 0 = 20000); + test 204 (Marshal.from_bytes s 0 = 20000); marshal_to_buffer s 0 512 0x12345678 []; - test 205 (Marshal.from_string s 0 = 0x12345678); + test 205 (Marshal.from_bytes s 0 = 0x12345678); marshal_to_buffer s 0 512 bigint []; - test 206 (Marshal.from_string s 0 = bigint); + test 206 (Marshal.from_bytes s 0 = bigint); marshal_to_buffer s 0 512 "foobargeebuz" []; - test 207 (Marshal.from_string s 0 = "foobargeebuz"); + test 207 (Marshal.from_bytes s 0 = "foobargeebuz"); marshal_to_buffer s 0 512 longstring []; - test 208 (Marshal.from_string s 0 = longstring); + test 208 (Marshal.from_bytes s 0 = longstring); test 209 (try marshal_to_buffer s 0 512 verylongstring []; false with Failure "Marshal.to_buffer: buffer overflow" -> true); marshal_to_buffer s 0 512 3.141592654 []; - test 210 (Marshal.from_string s 0 = 3.141592654); + test 210 (Marshal.from_bytes s 0 = 3.141592654); marshal_to_buffer s 0 512 () []; - test 211 (Marshal.from_string s 0 = ()); + test 211 (Marshal.from_bytes s 0 = ()); marshal_to_buffer s 0 512 A []; - test 212 (match Marshal.from_string s 0 with + test 212 (match Marshal.from_bytes s 0 with A -> true | _ -> false); marshal_to_buffer s 0 512 (B 1) []; - test 213 (match Marshal.from_string s 0 with + test 213 (match Marshal.from_bytes s 0 with (B 1) -> true | _ -> false); marshal_to_buffer s 0 512 (C 2.718) []; - test 214 (match Marshal.from_string s 0 with + test 214 (match Marshal.from_bytes s 0 with (C f) -> f = 2.718 | _ -> false); marshal_to_buffer s 0 512 (D "hello, world!") []; - test 215 (match Marshal.from_string s 0 with + test 215 (match Marshal.from_bytes s 0 with (D "hello, world!") -> true | _ -> false); marshal_to_buffer s 0 512 (E 'l') []; - test 216 (match Marshal.from_string s 0 with + test 216 (match Marshal.from_bytes s 0 with (E 'l') -> true | _ -> false); marshal_to_buffer s 0 512 (F(B 1)) []; - test 217 (match Marshal.from_string s 0 with + test 217 (match Marshal.from_bytes s 0 with (F(B 1)) -> true | _ -> false); marshal_to_buffer s 0 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) []; - test 218 (match Marshal.from_string s 0 with + test 218 (match Marshal.from_bytes s 0 with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); marshal_to_buffer s 0 512 (H(1, A)) []; - test 219 (match Marshal.from_string s 0 with + test 219 (match Marshal.from_bytes s 0 with (H(1, A)) -> true | _ -> false); marshal_to_buffer s 0 512 (I(B 2, 1e-6)) []; - test 220 (match Marshal.from_string s 0 with + test 220 (match Marshal.from_bytes s 0 with (I(B 2, 1e-6)) -> true | _ -> false); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in marshal_to_buffer s 0 512 z []; - test 221 (match Marshal.from_string s 0 with + test 221 (match Marshal.from_bytes s 0 with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); marshal_to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] []; - test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 222 + (Marshal.from_bytes s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in test 223 (try marshal_to_buffer s 0 512 (big 1000) []; false diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml index 7fc15b517..541dd4c69 100644 --- a/testsuite/tests/lib-num/test_nats.ml +++ b/testsuite/tests/lib-num/test_nats.ml @@ -117,7 +117,10 @@ let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3) ;; -let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in +let s = + "33333333333333333333333333333333333333333333333333333333333333333333\ + 33333333333333333333333333333333333333333333333333333333333333333333" +in test 21 equal_nat ( nat_of_string s, (let nat = make_nat 15 in diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile index a8a294718..dc31633e1 100644 --- a/testsuite/tests/lib-printf/Makefile +++ b/testsuite/tests/lib-printf/Makefile @@ -15,5 +15,6 @@ MAIN_MODULE=tprintf ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib ADD_MODULES=testing -include ../../makefiles/Makefile.one -include ../../makefiles/Makefile.common +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml index 47313b325..2922f8e32 100644 --- a/testsuite/tests/lib-printf/tprintf.ml +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -27,10 +27,12 @@ try test (sprintf "%04d/%05i" 42 43 = "0042/00043"); test (sprintf "%+d/%+i" 42 43 = "+42/+43"); test (sprintf "% d/% i" 42 43 = " 42/ 43"); - test (sprintf "%#d/%#i" 42 43 = "42/43"); + (*test (sprintf "%#d/%#i" 42 43 = "42/43");*) + (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); - test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); + (*test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 ");*) + (* >> '#' is incompatible with 'd' *) printf "\nd/i negative\n%!"; test (sprintf "%d/%i" (-42) (-43) = "-42/-43"); @@ -38,21 +40,27 @@ try test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043"); test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43"); test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); - test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); + (*test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");*) + (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); - test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); + (*test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 ");*) + (* >> '0' is incompatible with '-', '#' is incompatible with 'd' *) printf "\nu positive\n%!"; test (sprintf "%u" 42 = "42"); test (sprintf "%-4u" 42 = "42 "); test (sprintf "%04u" 42 = "0042"); - test (sprintf "%+u" 42 = "42"); - test (sprintf "% u" 42 = "42"); - test (sprintf "%#u" 42 = "42"); + (*test (sprintf "%+u" 42 = "42");*) + (* >> '+' is incompatible with 'u' *) + (*test (sprintf "% u" 42 = "42");*) + (* >> ' ' is incompatible with 'u' *) + (*test (sprintf "%#u" 42 = "42");*) + (* >> '#' is incompatible with 'u' *) test (sprintf "%4u" 42 = " 42"); test (sprintf "%*u" 4 42 = " 42"); - test (sprintf "%-0+ #6d" 42 = "+42 "); + (*test (sprintf "%-0+ #6d" 42 = "+42 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'd' *) printf "\nu negative\n%!"; begin match Sys.word_size with @@ -67,12 +75,15 @@ try test (sprintf "%x" 42 = "2a"); test (sprintf "%-4x" 42 = "2a "); test (sprintf "%04x" 42 = "002a"); - test (sprintf "%+x" 42 = "2a"); - test (sprintf "% x" 42 = "2a"); + (*test (sprintf "%+x" 42 = "2a");*) + (* >> '+' is incompatible with 'x' *) + (*test (sprintf "% x" 42 = "2a");*) + (* >> ' ' is incompatible with 'x' *) test (sprintf "%#x" 42 = "0x2a"); test (sprintf "%4x" 42 = " 2a"); test (sprintf "%*x" 5 42 = " 2a"); - test (sprintf "%-0+ #*x" 5 42 = "0x2a "); + (*test (sprintf "%-0+ #*x" 5 42 = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nx negative\n%!"; begin match Sys.word_size with @@ -87,12 +98,15 @@ try test (sprintf "%X" 42 = "2A"); test (sprintf "%-4X" 42 = "2A "); test (sprintf "%04X" 42 = "002A"); - test (sprintf "%+X" 42 = "2A"); - test (sprintf "% X" 42 = "2A"); + (*test (sprintf "%+X" 42 = "2A");*) + (* >> '+' is incompatible with 'X' *) + (*test (sprintf "% X" 42 = "2A");*) + (* >> ' ' is incompatible with 'X' *) test (sprintf "%#X" 42 = "0X2A"); test (sprintf "%4X" 42 = " 2A"); test (sprintf "%*X" 5 42 = " 2A"); - test (sprintf "%-0+ #*X" 5 42 = "0X2A "); + (*test (sprintf "%-0+ #*X" 5 42 = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nx negative\n%!"; begin match Sys.word_size with @@ -107,12 +121,15 @@ try test (sprintf "%o" 42 = "52"); test (sprintf "%-4o" 42 = "52 "); test (sprintf "%04o" 42 = "0052"); - test (sprintf "%+o" 42 = "52"); - test (sprintf "% o" 42 = "52"); + (*test (sprintf "%+o" 42 = "52");*) + (* >> '+' is incompatible with 'o' *) + (*test (sprintf "% o" 42 = "52");*) + (* >> '+' is incompatible with 'o' *) test (sprintf "%#o" 42 = "052"); test (sprintf "%4o" 42 = " 52"); test (sprintf "%*o" 5 42 = " 52"); - test (sprintf "%-0+ #*o" 5 42 = "052 "); + (*test (sprintf "%-0+ #*o" 5 42 = "052 ");*) + (* >> '-' is incompatible with 'o' *) printf "\no negative\n%!"; begin match Sys.word_size with @@ -126,15 +143,20 @@ try printf "\ns\n%!"; test (sprintf "%s" "foo" = "foo"); test (sprintf "%-5s" "foo" = "foo "); - test (sprintf "%05s" "foo" = " foo"); - test (sprintf "%+s" "foo" = "foo"); - test (sprintf "% s" "foo" = "foo"); - test (sprintf "%#s" "foo" = "foo"); + (*test (sprintf "%05s" "foo" = " foo");*) + (* >> '0' is incompatible with 's' *) + (*test (sprintf "%+s" "foo" = "foo");*) + (* >> '+' is incompatible with 's' *) + (*test (sprintf "% s" "foo" = "foo");*) + (* >> ' ' is incompatible with 's' *) + (*test (sprintf "%#s" "foo" = "foo");*) + (* >> '#' is incompatible with 's' *) test (sprintf "%5s" "foo" = " foo"); test (sprintf "%1s" "foo" = "foo"); test (sprintf "%*s" 6 "foo" = " foo"); test (sprintf "%*s" 2 "foo" = "foo"); - test (sprintf "%-0+ #5s" "foo" = "foo "); + (*test (sprintf "%-0+ #5s" "foo" = "foo ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 's' *) test (sprintf "%s@" "foo" = "foo@"); test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr"); test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr"); @@ -143,9 +165,12 @@ try test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); (* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) (* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) - test (sprintf "%+S" "foo" = "\"foo\""); - test (sprintf "% S" "foo" = "\"foo\""); - test (sprintf "%#S" "foo" = "\"foo\""); + (*test (sprintf "%+S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) + (*test (sprintf "% S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) + (*test (sprintf "%#S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) (* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) test (sprintf "%1S" "foo" = "\"foo\""); (* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) @@ -159,9 +184,12 @@ try test (sprintf "%c" 'c' = "c"); (* test (sprintf "%-4c" 'c' = "c "); padding not done *) (* test (sprintf "%04c" 'c' = " c"); padding not done *) - test (sprintf "%+c" 'c' = "c"); - test (sprintf "% c" 'c' = "c"); - test (sprintf "%#c" 'c' = "c"); + (*test (sprintf "%+c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) + (*test (sprintf "% c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) + (*test (sprintf "%#c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) (* test (sprintf "%4c" 'c' = " c"); padding not done *) (* test (sprintf "%*c" 2 'c' = " c"); padding not done *) (* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *) @@ -171,12 +199,15 @@ try test (sprintf "%C" '\'' = "'\\''"); (* test (sprintf "%-4C" 'c' = "c "); padding not done *) (* test (sprintf "%04C" 'c' = " c"); padding not done *) - test (sprintf "%+C" 'c' = "'c'"); - test (sprintf "% C" 'c' = "'c'"); - test (sprintf "%#C" 'c' = "'c'"); -(* test (sprintf "%4C" 'c' = " 'c'"); padding not done *) -(* test (sprintf "%*C" 2 'c' = "'c'"); padding not done *) -(* test (sprintf "%-0+ #4C" 'c' = "'c' "); padding not done *) + (*test (sprintf "%+C" 'c' = "'c'");*) + (* >> '+' is incompatible with 'C' *) + (*test (sprintf "% C" 'c' = "'c'");*) + (* >> ' ' is incompatible with 'C' *) + (*test (sprintf "%#C" 'c' = "'c'");*) + (* >> '#' is incompatible with 'C' *) +(* test (sprintf "%4C" 'c' = " c"); padding not done *) +(* test (sprintf "%*C" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *) printf "\nf\n%!"; test (sprintf "%f" (-42.42) = "-42.420000"); @@ -184,19 +215,23 @@ try test (sprintf "%013f" (-42.42) = "-00042.420000"); test (sprintf "%+f" 42.42 = "+42.420000"); test (sprintf "% f" 42.42 = " 42.420000"); - test (sprintf "%#f" 42.42 = "42.420000"); + (*test (sprintf "%#f" 42.42 = "42.420000");*) + (* >> '#' is incompatible with 'f' *) test (sprintf "%13f" 42.42 = " 42.420000"); test (sprintf "%*f" 12 42.42 = " 42.420000"); - test (sprintf "%-0+ #12f" 42.42 = "+42.420000 "); + (*test (sprintf "%-0+ #12f" 42.42 = "+42.420000 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *) test (sprintf "%.3f" (-42.42) = "-42.420"); test (sprintf "%-13.3f" (-42.42) = "-42.420 "); test (sprintf "%013.3f" (-42.42) = "-00000042.420"); test (sprintf "%+.3f" 42.42 = "+42.420"); test (sprintf "% .3f" 42.42 = " 42.420"); - test (sprintf "%#.3f" 42.42 = "42.420"); + (*test (sprintf "%#.3f" 42.42 = "42.420");*) + (* >> '#' is incompatible with 'f' *) test (sprintf "%13.3f" 42.42 = " 42.420"); test (sprintf "%*.*f" 12 3 42.42 = " 42.420"); - test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 "); + (*test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *) (* Under Windows (mingw and maybe also MSVC), the stdlib uses three digits for the exponent instead of the two used by Linux and BSD. @@ -240,19 +275,23 @@ try test (sprintf "%015e" (-42.42) =* "-004.242000e+01"); test (sprintf "%+e" 42.42 =* "+4.242000e+01"); test (sprintf "% e" 42.42 =* " 4.242000e+01"); - test (sprintf "%#e" 42.42 =* "4.242000e+01"); + (*test (sprintf "%#e" 42.42 =* "4.242000e+01");*) + (* >> '#' is incompatible with 'e' *) test (sprintf "%15e" 42.42 =* " 4.242000e+01"); test (sprintf "%*e" 14 42.42 =* " 4.242000e+01"); - test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 "); + (*test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *) test (sprintf "%.3e" (-42.42) =* "-4.242e+01"); test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01 "); test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01"); test (sprintf "%+.3e" 42.42 =* "+4.242e+01"); test (sprintf "% .3e" 42.42 =* " 4.242e+01"); - test (sprintf "%#.3e" 42.42 =* "4.242e+01"); + (*test (sprintf "%#.3e" 42.42 =* "4.242e+01");*) + (* >> '#' is incompatible with 'e' *) test (sprintf "%15.3e" 42.42 =* " 4.242e+01"); test (sprintf "%*.*e" 11 3 42.42 =* " 4.242e+01"); - test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 "); + (*test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *) printf "\nE\n%!"; test (sprintf "%E" (-42.42) =* "-4.242000E+01"); @@ -260,19 +299,23 @@ try test (sprintf "%015E" (-42.42) =* "-004.242000E+01"); test (sprintf "%+E" 42.42 =* "+4.242000E+01"); test (sprintf "% E" 42.42 =* " 4.242000E+01"); - test (sprintf "%#E" 42.42 =* "4.242000E+01"); + (*test (sprintf "%#E" 42.42 =* "4.242000E+01");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%15E" 42.42 =* " 4.242000E+01"); test (sprintf "%*E" 14 42.42 =* " 4.242000E+01"); - test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 "); + (*test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%.3E" (-42.42) =* "-4.242E+01"); test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01 "); test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01"); test (sprintf "%+.3E" 42.42 =* "+4.242E+01"); test (sprintf "% .3E" 42.42 =* " 4.242E+01"); - test (sprintf "%#.3E" 42.42 =* "4.242E+01"); + (*test (sprintf "%#.3E" 42.42 =* "4.242E+01");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%15.3E" 42.42 =* " 4.242E+01"); test (sprintf "%*.*E" 11 3 42.42 =* " 4.242E+01"); - test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 "); + (*test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'E' *) (* %g gives strange results that correspond to neither %f nor %e printf "\ng\n%!"; @@ -302,10 +345,12 @@ try test (sprintf "%04ld/%05li" 42l 43l = "0042/00043"); test (sprintf "%+ld/%+li" 42l 43l = "+42/+43"); test (sprintf "% ld/% li" 42l 43l = " 42/ 43"); - test (sprintf "%#ld/%#li" 42l 43l = "42/43"); + (*test (sprintf "%#ld/%#li" 42l 43l = "42/43");*) + (* >> '#' is incompatible with 'ld' *) test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43"); test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43"); - test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 "); + (*test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nld/li negative\n%!"; test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43"); @@ -313,21 +358,27 @@ try test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043"); test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43"); test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43"); - test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43"); + (*test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");*) + (* >> '#' is incompatible with 'ld' *) test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43"); test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43"); - test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 "); + (*test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nlu positive\n%!"; test (sprintf "%lu" 42l = "42"); test (sprintf "%-4lu" 42l = "42 "); test (sprintf "%04lu" 42l = "0042"); - test (sprintf "%+lu" 42l = "42"); - test (sprintf "% lu" 42l = "42"); - test (sprintf "%#lu" 42l = "42"); + (*test (sprintf "%+lu" 42l = "42");*) + (* >> '+' is incompatible with 'lu' *) + (*test (sprintf "% lu" 42l = "42");*) + (* >> ' ' is incompatible with 'lu' *) + (*test (sprintf "%#lu" 42l = "42");*) + (* >> '#' is incompatible with 'lu' *) test (sprintf "%4lu" 42l = " 42"); test (sprintf "%*lu" 4 42l = " 42"); - test (sprintf "%-0+ #6ld" 42l = "+42 "); + (*test (sprintf "%-0+ #6ld" 42l = "+42 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nlu negative\n%!"; test (sprintf "%lu" (-1l) = "4294967295"); @@ -336,12 +387,15 @@ try test (sprintf "%lx" 42l = "2a"); test (sprintf "%-4lx" 42l = "2a "); test (sprintf "%04lx" 42l = "002a"); - test (sprintf "%+lx" 42l = "2a"); - test (sprintf "% lx" 42l = "2a"); + (*test (sprintf "%+lx" 42l = "2a");*) + (* >> '+' is incompatible with 'lx' *) + (*test (sprintf "% lx" 42l = "2a");*) + (* >> ' ' is incompatible with 'lx' *) test (sprintf "%#lx" 42l = "0x2a"); test (sprintf "%4lx" 42l = " 2a"); test (sprintf "%*lx" 5 42l = " 2a"); - test (sprintf "%-0+ #*lx" 5 42l = "0x2a "); + (*test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nlx negative\n%!"; test (sprintf "%lx" (-42l) = "ffffffd6"); @@ -350,12 +404,15 @@ try test (sprintf "%lX" 42l = "2A"); test (sprintf "%-4lX" 42l = "2A "); test (sprintf "%04lX" 42l = "002A"); - test (sprintf "%+lX" 42l = "2A"); - test (sprintf "% lX" 42l = "2A"); + (*test (sprintf "%+lX" 42l = "2A");*) + (* >> '+' is incompatible with 'lX' *) + (*test (sprintf "% lX" 42l = "2A");*) + (* >> ' ' is incompatible with 'lX' *) test (sprintf "%#lX" 42l = "0X2A"); test (sprintf "%4lX" 42l = " 2A"); test (sprintf "%*lX" 5 42l = " 2A"); - test (sprintf "%-0+ #*lX" 5 42l = "0X2A "); + (*test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nlx negative\n%!"; test (sprintf "%lX" (-42l) = "FFFFFFD6"); @@ -364,12 +421,15 @@ try test (sprintf "%lo" 42l = "52"); test (sprintf "%-4lo" 42l = "52 "); test (sprintf "%04lo" 42l = "0052"); - test (sprintf "%+lo" 42l = "52"); - test (sprintf "% lo" 42l = "52"); + (*test (sprintf "%+lo" 42l = "52");*) + (* >> '+' is incompatible with 'lo' *) + (*test (sprintf "% lo" 42l = "52");*) + (* >> ' ' is incompatible with 'lo' *) test (sprintf "%#lo" 42l = "052"); test (sprintf "%4lo" 42l = " 52"); test (sprintf "%*lo" 5 42l = " 52"); - test (sprintf "%-0+ #*lo" 5 42l = "052 "); + (*test (sprintf "%-0+ #*lo" 5 42l = "052 ");*) + (* >> '-' is incompatible with '0' *) printf "\nlo negative\n%!"; test (sprintf "%lo" (-42l) = "37777777726"); @@ -381,34 +441,46 @@ try test (sprintf "%Ld/%Li" 42L 43L = "42/43"); test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 "); test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043"); - test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43"); - test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43"); - test (sprintf "%#Ld/%#Li" 42L 43L = "42/43"); + (*test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");*) + (* >> '+' is incompatible with 'Ld' *) + (*test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");*) + (* >> ' ' is incompatible with 'Ld' *) + (*test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");*) + (* >> '#' is incompatible with 'Ld' *) test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43"); test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43"); - test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 "); + (*test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLd/Li negative\n%!"; test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43"); test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 "); test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043"); - test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43"); - test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43"); - test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43"); + (*test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");*) + (* >> '+' is incompatible with 'Ld' *) + (*test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");*) + (* >> ' ' is incompatible with 'Ld' *) + (*test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");*) + (* >> '#' is incompatible with 'Ld' *) test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43"); test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43"); - test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 "); + (*test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLu positive\n%!"; test (sprintf "%Lu" 42L = "42"); test (sprintf "%-4Lu" 42L = "42 "); test (sprintf "%04Lu" 42L = "0042"); - test (sprintf "%+Lu" 42L = "42"); - test (sprintf "% Lu" 42L = "42"); - test (sprintf "%#Lu" 42L = "42"); + (*test (sprintf "%+Lu" 42L = "42");*) + (* >> '+' is incompatible with 'Lu' *) + (*test (sprintf "% Lu" 42L = "42");*) + (* >> ' ' is incompatible with 'Lu' *) + (*test (sprintf "%#Lu" 42L = "42");*) + (* >> '#' is incompatible with 'Lu' *) test (sprintf "%4Lu" 42L = " 42"); test (sprintf "%*Lu" 4 42L = " 42"); - test (sprintf "%-0+ #6Ld" 42L = "+42 "); + (*test (sprintf "%-0+ #6Ld" 42L = "+42 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLu negative\n%!"; test (sprintf "%Lu" (-1L) = "18446744073709551615"); @@ -417,12 +489,15 @@ try test (sprintf "%Lx" 42L = "2a"); test (sprintf "%-4Lx" 42L = "2a "); test (sprintf "%04Lx" 42L = "002a"); - test (sprintf "%+Lx" 42L = "2a"); - test (sprintf "% Lx" 42L = "2a"); + (*test (sprintf "%+Lx" 42L = "2a");*) + (* >> '+' is incompatible with 'Lx' *) + (*test (sprintf "% Lx" 42L = "2a");*) + (* >> ' ' is incompatible with 'Lx' *) test (sprintf "%#Lx" 42L = "0x2a"); test (sprintf "%4Lx" 42L = " 2a"); test (sprintf "%*Lx" 5 42L = " 2a"); - test (sprintf "%-0+ #*Lx" 5 42L = "0x2a "); + (*test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nLx negative\n%!"; test (sprintf "%Lx" (-42L) = "ffffffffffffffd6"); @@ -431,12 +506,15 @@ try test (sprintf "%LX" 42L = "2A"); test (sprintf "%-4LX" 42L = "2A "); test (sprintf "%04LX" 42L = "002A"); - test (sprintf "%+LX" 42L = "2A"); - test (sprintf "% LX" 42L = "2A"); + (*test (sprintf "%+LX" 42L = "2A");*) + (* >> '+' is incompatible with 'LX' *) + (*test (sprintf "% LX" 42L = "2A");*) + (* >> ' ' is incompatible with 'LX' *) test (sprintf "%#LX" 42L = "0X2A"); test (sprintf "%4LX" 42L = " 2A"); test (sprintf "%*LX" 5 42L = " 2A"); - test (sprintf "%-0+ #*LX" 5 42L = "0X2A "); + (*test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nLx negative\n%!"; test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6"); @@ -445,12 +523,15 @@ try test (sprintf "%Lo" 42L = "52"); test (sprintf "%-4Lo" 42L = "52 "); test (sprintf "%04Lo" 42L = "0052"); - test (sprintf "%+Lo" 42L = "52"); - test (sprintf "% Lo" 42L = "52"); + (*test (sprintf "%+Lo" 42L = "52");*) + (* >> '+' is incompatible with 'Lo' *) + (*test (sprintf "% Lo" 42L = "52");*) + (* >> ' ' is incompatible with 'Lo' *) test (sprintf "%#Lo" 42L = "052"); test (sprintf "%4Lo" 42L = " 52"); test (sprintf "%*Lo" 5 42L = " 52"); - test (sprintf "%-0+ #*Lo" 5 42L = "052 "); + (*test (sprintf "%-0+ #*Lo" 5 42L = "052 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLo negative\n%!"; test (sprintf "%Lo" (-42L) = "1777777777777777777726"); @@ -471,7 +552,7 @@ try printf "\n{...%%}\n%!"; let f = format_of_string "%4g/%s" in - test (sprintf "%{%#0F%S%}" f = "%f%s"); + test (sprintf "%{%.4F%5S%}" f = "%f%s"); printf "\n(...%%)\n%!"; let f = format_of_string "%d/foo/%s" in diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference index 387dfb853..11ee3a74f 100644 --- a/testsuite/tests/lib-printf/tprintf.reference +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -1,91 +1,91 @@ d/i positive - 0 1 2 3 4 5 6 7 8 + 0 1 2 3 4 5 6 d/i negative - 9 10 11 12 13 14 15 16 17 + 7 8 9 10 11 12 13 u positive - 18 19 20 21 22 23 24 25 26 + 14 15 16 17 18 u negative - 27 + 19 x positive - 28 29 30 31 32 33 34 35 36 + 20 21 22 23 24 25 x negative - 37 + 26 X positive - 38 39 40 41 42 43 44 45 46 + 27 28 29 30 31 32 x negative - 47 + 33 o positive - 48 49 50 51 52 53 54 55 56 + 34 35 36 37 38 39 o negative - 57 + 40 s - 58 59 60 61 62 63 64 65 66 67 68 69 70 71 + 41 42 43 44 45 46 47 48 49 S - 72 73 74 75 76 77 78 79 80 + 50 51 52 53 54 55 c - 81 82 83 84 + 56 C - 85 86 87 88 89 + 57 58 f - 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 + 59 60 61 62 63 64 65 66 67 68 69 70 71 72 F - 108 109 110 111 + 73 74 75 76 e - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 + 77 78 79 80 81 82 83 84 85 86 87 88 89 90 E - 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 + 91 92 93 94 95 96 97 98 99 100 101 102 103 104 B - 148 149 + 105 106 ld/li positive - 150 151 152 153 154 155 156 157 158 + 107 108 109 110 111 112 113 ld/li negative - 159 160 161 162 163 164 165 166 167 + 114 115 116 117 118 119 120 lu positive - 168 169 170 171 172 173 174 175 176 + 121 122 123 124 125 lu negative - 177 + 126 lx positive - 178 179 180 181 182 183 184 185 186 + 127 128 129 130 131 132 lx negative - 187 + 133 lX positive - 188 189 190 191 192 193 194 195 196 + 134 135 136 137 138 139 lx negative - 197 + 140 lo positive - 198 199 200 201 202 203 204 205 206 + 141 142 143 144 145 146 lo negative - 207 + 147 Ld/Li positive - 208 209 210 211 212 213 214 215 216 + 148 149 150 151 152 Ld/Li negative - 217 218 219 220 221 222 223 224 225 + 153 154 155 156 157 Lu positive - 226 227 228 229 230 231 232 233 234 + 158 159 160 161 162 Lu negative - 235 + 163 Lx positive - 236 237 238 239 240 241 242 243 244 + 164 165 166 167 168 169 Lx negative - 245 + 170 LX positive - 246 247 248 249 250 251 252 253 254 + 171 172 173 174 175 176 Lx negative - 255 + 177 Lo positive - 256 257 258 259 260 261 262 263 264 + 178 179 180 181 182 183 Lo negative - 265 + 184 a - 266 + 185 t - 267 + 186 {...%} - 268 + 187 (...%) - 269 + 188 ! % @ , and constants - 270 271 272 273 274 275 276 + 189 190 191 192 193 194 195 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index 53c92ffc8..8e6a252b8 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1090,13 +1090,13 @@ let test46, test47 = Printf.sprintf "%i %(%s%)." 1 "spells one, %s" "in english"), (fun () -> - Printf.sprintf "%i ,%{%s%}, %s." + Printf.sprintf "%i %{%s%}, %s." 1 "spells one %s" "in english") ;; test (test46 () = "1 spells one, in english.") ;; -test (test47 () = "1 ,%s, in english.") +test (test47 () = "1 %s, in english.") ;; (* Testing scanning of meta formats. *) diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml index 4f6626c11..3e55942a4 100644 --- a/testsuite/tests/lib-set/testset.ml +++ b/testsuite/tests/lib-set/testset.ml @@ -58,7 +58,8 @@ let test x s1 s2 = (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))); + (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)); diff --git a/testsuite/tests/lib-systhreads/testfork.precheck b/testsuite/tests/lib-systhreads/testfork.precheck index af81e807f..f93abf1a6 100644 --- a/testsuite/tests/lib-systhreads/testfork.precheck +++ b/testsuite/tests/lib-systhreads/testfork.precheck @@ -14,4 +14,3 @@ case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in *' unix '*) exit 0;; *) exit 3;; esac - diff --git a/testsuite/tests/lib-threads/test1.ml b/testsuite/tests/lib-threads/test1.ml index 8961b6f85..c551fbc5d 100644 --- a/testsuite/tests/lib-threads/test1.ml +++ b/testsuite/tests/lib-threads/test1.ml @@ -21,7 +21,7 @@ type 'a prodcons = notfull: Condition.t } let create size init = - { buffer = Array.create size init; + { buffer = Array.make size init; lock = Mutex.create(); readpos = 0; writepos = 0; diff --git a/testsuite/tests/lib-threads/test7.checker b/testsuite/tests/lib-threads/test7.checker index 55396e138..4c4b2b4d6 100644 --- a/testsuite/tests/lib-threads/test7.checker +++ b/testsuite/tests/lib-threads/test7.checker @@ -10,4 +10,5 @@ # # ######################################################################### -test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l` +test `grep -E '^-?[0123456789]+$' test7.result | wc -l` \ + = `cat test7.result | wc -l` diff --git a/testsuite/tests/lib-threads/testA.ml b/testsuite/tests/lib-threads/testA.ml index bdd33c345..30efd6d39 100644 --- a/testsuite/tests/lib-threads/testA.ml +++ b/testsuite/tests/lib-threads/testA.ml @@ -26,8 +26,8 @@ let process id data = set_private_data data; Mutex.lock output_lock; print_int id; print_string " --> "; print_string(get_private_data()); - Mutex.unlock output_lock; - print_newline() + print_newline(); + Mutex.unlock output_lock let _ = let t1 = Thread.create (process 1) "un" in diff --git a/testsuite/tests/lib-threads/testsocket.ml b/testsuite/tests/lib-threads/testsocket.ml index ec16c058c..6b2b0b049 100644 --- a/testsuite/tests/lib-threads/testsocket.ml +++ b/testsuite/tests/lib-threads/testsocket.ml @@ -20,7 +20,9 @@ let engine verbose number address = try while true do let s = input_line ic in - if verbose then (print_int number; print_string ">"; print_string s; print_newline()) + if verbose then begin + print_int number; print_string ">"; print_string s; print_newline() + end done; with End_of_file -> close_out oc; @@ -31,11 +33,11 @@ let main() = match Sys.argv with | [| _ |] -> false, [| Sys.argv.(0); "caml.inria.fr" |] | _ -> true, Sys.argv in - let addresses = Array.create (Array.length argv - 1) inet_addr_any in + let addresses = Array.make (Array.length argv - 1) inet_addr_any in for i = 1 to Array.length argv - 1 do addresses.(i - 1) <- (gethostbyname argv.(i)).h_addr_list.(0) done; - let processes = Array.create (Array.length addresses) (Thread.self()) in + let processes = Array.make (Array.length addresses) (Thread.self()) in for i = 0 to Array.length addresses - 1 do processes.(i) <- Thread.create (engine verbose i) addresses.(i) done; diff --git a/testsuite/tests/lib-threads/testsocket.precheck b/testsuite/tests/lib-threads/testsocket.precheck index 15ae35c52..6d41158ef 100644 --- a/testsuite/tests/lib-threads/testsocket.precheck +++ b/testsuite/tests/lib-threads/testsocket.precheck @@ -20,4 +20,4 @@ # disable this test on Windows non-cygwin ports until we decide # how to fix PR#5325 and PR#5578 -$CANKILL
\ No newline at end of file +$CANKILL diff --git a/testsuite/tests/lib-threads/token1.ml b/testsuite/tests/lib-threads/token1.ml index d6e7a1b7a..d0a7528b0 100644 --- a/testsuite/tests/lib-threads/token1.ml +++ b/testsuite/tests/lib-threads/token1.ml @@ -39,7 +39,7 @@ let process (n, conds, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let conds = Array.create nprocs (Condition.create()) in + let conds = Array.make nprocs (Condition.create()) in for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done; diff --git a/testsuite/tests/lib-threads/token2.ml b/testsuite/tests/lib-threads/token2.ml index 9ef05806e..c3548fb0f 100644 --- a/testsuite/tests/lib-threads/token2.ml +++ b/testsuite/tests/lib-threads/token2.ml @@ -35,9 +35,9 @@ let process (n, ins, outs, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let ins = Array.create nprocs Unix.stdin in - let outs = Array.create nprocs Unix.stdout in - let threads = Array.create nprocs (Thread.self ()) in + let ins = Array.make nprocs Unix.stdin in + let outs = Array.make nprocs Unix.stdout in + let threads = Array.make nprocs (Thread.self ()) in for n = 0 to nprocs - 1 do let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o done; diff --git a/testsuite/tests/match-exception-warnings/Makefile b/testsuite/tests/match-exception-warnings/Makefile new file mode 100644 index 000000000..c9433b2ec --- /dev/null +++ b/testsuite/tests/match-exception-warnings/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml new file mode 100644 index 000000000..742038db4 --- /dev/null +++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml @@ -0,0 +1,12 @@ +(** Test exhaustiveness. + + match clauses should continue to give warnings about inexhaustive + value-matching clauses when there is an exception-matching clause + *) + +let test_match_exhaustiveness () = + match None with + | exception e -> () + | Some false -> () + | None -> () +;; diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference new file mode 100644 index 000000000..f1e30bc56 --- /dev/null +++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference @@ -0,0 +1,11 @@ + +# * * * * Characters 210-289: + ....match None with + | exception e -> () + | Some false -> () + | None -> () +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Some true +val test_match_exhaustiveness : unit -> unit = <fun> +# diff --git a/testsuite/tests/match-exception/Makefile b/testsuite/tests/match-exception/Makefile new file mode 100644 index 000000000..299656b24 --- /dev/null +++ b/testsuite/tests/match-exception/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/match-exception/allocation.ml b/testsuite/tests/match-exception/allocation.ml new file mode 100644 index 000000000..fa943ffa3 --- /dev/null +++ b/testsuite/tests/match-exception/allocation.ml @@ -0,0 +1,24 @@ +(** Test that matching multiple values doesn't allocate a block. *) + +let f x y = + match x, y with + | Some x, None + | None, Some x -> x + 1 + | None, None -> 0 + | Some x, Some y -> x + y + | exception _ -> -1 + +let test_multiple_match_does_not_allocate = + let allocated_bytes = Gc.allocated_bytes () in + let allocated_bytes' = Gc.allocated_bytes () in + let a = Some 3 and b = None in + let allocated_bytes'' = Gc.allocated_bytes () in + let _ = f a b in + let allocated_bytes''' = Gc.allocated_bytes () in + if allocated_bytes' -. allocated_bytes = allocated_bytes''' -. allocated_bytes'' + then + Printf.printf "no allocations for multiple-value match\n" + else + Printf.printf "multiple-value match allocated %f bytes\n" + ((allocated_bytes''' -. allocated_bytes'') -. + (allocated_bytes' -. allocated_bytes)) diff --git a/testsuite/tests/match-exception/allocation.reference b/testsuite/tests/match-exception/allocation.reference new file mode 100644 index 000000000..98056ce6e --- /dev/null +++ b/testsuite/tests/match-exception/allocation.reference @@ -0,0 +1 @@ +no allocations for multiple-value match diff --git a/testsuite/tests/match-exception/exception_propagation.ml b/testsuite/tests/match-exception/exception_propagation.ml new file mode 100644 index 000000000..38d2cfd68 --- /dev/null +++ b/testsuite/tests/match-exception/exception_propagation.ml @@ -0,0 +1,17 @@ +(** + Test that match allows exceptions to propagate. +*) +let () = + try + match + (let _ = raise Not_found in + assert false) + with + | _ -> assert false + | exception Invalid_argument _ -> assert false + with + Not_found -> + print_endline "caught expected exception (Not_found)" + | _ -> + assert false +;; diff --git a/testsuite/tests/match-exception/exception_propagation.reference b/testsuite/tests/match-exception/exception_propagation.reference new file mode 100644 index 000000000..a119b6813 --- /dev/null +++ b/testsuite/tests/match-exception/exception_propagation.reference @@ -0,0 +1 @@ +caught expected exception (Not_found) diff --git a/testsuite/tests/match-exception/match_failure.ml b/testsuite/tests/match-exception/match_failure.ml new file mode 100644 index 000000000..c6149bf3b --- /dev/null +++ b/testsuite/tests/match-exception/match_failure.ml @@ -0,0 +1,19 @@ +(** + Test that value match failure in a match block raises Match_failure. +*) +let return_some_3 () = Some (1 + 2) +;; + +let test_match_partial_match = + try + let _ = (match return_some_3 () with + | Some x when x < 3 -> "Some x" + | exception Failure _ -> "failure" + | exception Invalid_argument _ -> "invalid argument" + | None -> "None" + ) in + assert false + with + Match_failure _ -> + print_endline "match failure, as expected" +;; diff --git a/testsuite/tests/match-exception/match_failure.reference b/testsuite/tests/match-exception/match_failure.reference new file mode 100644 index 000000000..6e17840fe --- /dev/null +++ b/testsuite/tests/match-exception/match_failure.reference @@ -0,0 +1 @@ +match failure, as expected diff --git a/testsuite/tests/match-exception/nested_handlers.ml b/testsuite/tests/match-exception/nested_handlers.ml new file mode 100644 index 000000000..0314cb103 --- /dev/null +++ b/testsuite/tests/match-exception/nested_handlers.ml @@ -0,0 +1,45 @@ +(* + Test that multiple handlers coexist happily. +*) + +let test_multiple_handlers = + let trace = ref [] in + let collect v = trace := v :: !trace in + let _ = + match + begin + match + begin + collect "one"; + failwith "two" + end + with + () -> collect "failure one" + | exception (Failure x) -> + collect x; + failwith "three" + end + with + () -> + collect "failure two"; + | exception (Failure x) -> + collect x; + match + begin + collect "four"; + failwith "five" + end + with + () -> collect "failure three" + | exception (Failure x) -> + collect x + in + print_endline (String.concat " " !trace); + assert (!trace = [ + "five"; + "four"; + "three"; + "two"; + "one"; + ]) +;; diff --git a/testsuite/tests/match-exception/nested_handlers.reference b/testsuite/tests/match-exception/nested_handlers.reference new file mode 100644 index 000000000..e30528669 --- /dev/null +++ b/testsuite/tests/match-exception/nested_handlers.reference @@ -0,0 +1 @@ +five four three two one diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.ml b/testsuite/tests/match-exception/raise_from_success_continuation.ml new file mode 100644 index 000000000..34fb64714 --- /dev/null +++ b/testsuite/tests/match-exception/raise_from_success_continuation.ml @@ -0,0 +1,15 @@ +(** + Test raising exceptions from a value-matching branch. +*) +let test_raise_from_val_handler = + let () = print_endline "test raise from val handler" in + let g () = List.find ((=)2) [1;2;4] in + let h () = + match + g () + with exception _ -> 10 + | _ -> raise Not_found + in + assert ((try h () with Not_found -> 20) = 20); + print_endline "raise from val handler succeeded" +;; diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.reference b/testsuite/tests/match-exception/raise_from_success_continuation.reference new file mode 100644 index 000000000..4cfe21608 --- /dev/null +++ b/testsuite/tests/match-exception/raise_from_success_continuation.reference @@ -0,0 +1,2 @@ +test raise from val handler +raise from val handler succeeded diff --git a/testsuite/tests/match-exception/streams.ml b/testsuite/tests/match-exception/streams.ml new file mode 100644 index 000000000..42e9a5f1d --- /dev/null +++ b/testsuite/tests/match-exception/streams.ml @@ -0,0 +1,37 @@ +(** + Test the stream example . +*) +type stream = Stream of (int * stream Lazy.t) +;; + +exception End_of_stream +;; + +let make_stream_up_to n = + let rec loop i = + if i = n then Stream (i, lazy (raise End_of_stream)) + else Stream (i, lazy (loop (i + 1))) + in loop 0 +;; + +let stream_get (Stream (x, s)) = (x, Lazy.force s) +;; + +let rec iter_stream_match f s = + match stream_get s + with exception End_of_stream -> () + | (x, s') -> + begin + f x; + iter_stream_match f s' + end +;; + +let test_iter_stream = + let limit = 10000000 in + try + iter_stream_match ignore (make_stream_up_to limit); + print_endline "iter_stream with handler case (match) is tail recursive" + with Stack_overflow -> + assert false +;; diff --git a/testsuite/tests/match-exception/streams.reference b/testsuite/tests/match-exception/streams.reference new file mode 100644 index 000000000..13df46408 --- /dev/null +++ b/testsuite/tests/match-exception/streams.reference @@ -0,0 +1 @@ +iter_stream with handler case (match) is tail recursive diff --git a/testsuite/tests/match-exception/tail_calls.ml b/testsuite/tests/match-exception/tail_calls.ml new file mode 100644 index 000000000..61cf02664 --- /dev/null +++ b/testsuite/tests/match-exception/tail_calls.ml @@ -0,0 +1,21 @@ +(** + The success continuation expression is in tail position. +*) + +let count_to_tr_match n = + let rec loop i = + match + i < n + with exception Not_found -> () + | false -> () + | true -> loop (i + 1) + in loop 0 +;; + +let test_tail_recursion = + try + count_to_tr_match 10000000; + print_endline "handler-case (match) is tail recursive" + with _ -> + assert false +;; diff --git a/testsuite/tests/match-exception/tail_calls.reference b/testsuite/tests/match-exception/tail_calls.reference new file mode 100644 index 000000000..342bf24a2 --- /dev/null +++ b/testsuite/tests/match-exception/tail_calls.reference @@ -0,0 +1 @@ +handler-case (match) is tail recursive diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli index c0578e56f..246bc8198 100644 --- a/testsuite/tests/misc-kb/kb.mli +++ b/testsuite/tests/misc-kb/kb.mli @@ -23,5 +23,7 @@ val deletion_message: rule -> unit val non_orientable: term * term -> unit val partition: ('a -> bool) -> 'a list -> 'a list * 'a list val get_rule: int -> rule list -> rule -val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list +val kb_completion: + (term * term -> bool) -> int -> rule list -> (term * term) list + -> int * int -> (term * term) list -> rule list val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml index 2c1cf38b0..7e2442b0b 100644 --- a/testsuite/tests/misc-unsafe/fft.ml +++ b/testsuite/tests/misc-unsafe/fft.ml @@ -135,8 +135,8 @@ let test np = print_int np; print_string "... "; flush stdout; let enp = float np in let npm = np / 2 - 1 in - let pxr = Array.create (np+2) 0.0 - and pxi = Array.create (np+2) 0.0 in + let pxr = Array.make (np+2) 0.0 + and pxi = Array.make (np+2) 0.0 in let t = pi /. enp in pxr.(1) <- (enp -. 1.0) *. 0.5; pxi.(1) <- 0.0; diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml index 4f872fd24..8879d9529 100644 --- a/testsuite/tests/misc-unsafe/quicksort.ml +++ b/testsuite/tests/misc-unsafe/quicksort.ml @@ -63,8 +63,8 @@ let random() = exception Failed let test_sort sort_fun size = - let a = Array.create size 0 in - let check = Array.create 4096 0 in + let a = Array.make size 0 in + let check = Array.make 4096 0 in for i = 0 to size-1 do let n = random() in a.(i) <- n; check.(n) <- check.(n)+1 done; diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml index 954edc164..297eb68e4 100644 --- a/testsuite/tests/misc/bdd.ml +++ b/testsuite/tests/misc/bdd.ml @@ -31,14 +31,14 @@ let getId bdd = let initSize_1 = 8*1024 - 1 let nodeC = ref 1 let sz_1 = ref initSize_1 -let htab = ref(Array.create (!sz_1+1) []) +let htab = ref(Array.make (!sz_1+1) []) let n_items = ref 0 let hashVal x y v = x lsl 1 + y + v lsl 2 let resize newSize = let arr = !htab in let newSz_1 = newSize-1 in - let newArr = Array.create newSize [] in + let newArr = Array.make newSize [] in let rec copyBucket bucket = match bucket with [] -> () @@ -71,7 +71,7 @@ let rec insert idl idh v ind bucket newNode = let resetUnique () = ( sz_1 := initSize_1; - htab := Array.create (!sz_1+1) []; + htab := Array.make (!sz_1+1) []; n_items := 0; nodeC := 1 ) @@ -111,14 +111,14 @@ let mkVar x = mkNode zero x one let cacheSize = 1999 -let andslot1 = Array.create cacheSize 0 -let andslot2 = Array.create cacheSize 0 -let andslot3 = Array.create cacheSize zero -let xorslot1 = Array.create cacheSize 0 -let xorslot2 = Array.create cacheSize 0 -let xorslot3 = Array.create cacheSize zero -let notslot1 = Array.create cacheSize 0 -let notslot2 = Array.create cacheSize one +let andslot1 = Array.make cacheSize 0 +let andslot2 = Array.make cacheSize 0 +let andslot3 = Array.make cacheSize zero +let xorslot1 = Array.make cacheSize 0 +let xorslot2 = Array.make cacheSize 0 +let xorslot3 = Array.make cacheSize zero +let notslot1 = Array.make cacheSize 0 +let notslot2 = Array.make cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize let rec not n = @@ -196,7 +196,7 @@ let random() = seed := !seed * 25173 + 17431; !seed land 1 > 0 let random_vars n = - let vars = Array.create n false in + let vars = Array.make n false in for i = 0 to n - 1 do vars.(i) <- random() done; vars diff --git a/testsuite/tests/prim-bigstring/Makefile b/testsuite/tests/prim-bigstring/Makefile new file mode 100644 index 000000000..379dba99c --- /dev/null +++ b/testsuite/tests/prim-bigstring/Makefile @@ -0,0 +1,8 @@ +BASEDIR=../.. +LIBRARIES=unix bigarray +ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \ + -I $(OTOPDIR)/otherlibs/bigarray +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml new file mode 100644 index 000000000..8fad87b15 --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.ml @@ -0,0 +1,102 @@ + +open Bigarray +type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t + +external caml_bigstring_get_16 : + bigstring -> int -> int = "%caml_bigstring_get16" +external caml_bigstring_get_32 : + bigstring -> int -> int32 = "%caml_bigstring_get32" +external caml_bigstring_get_64 : + bigstring -> int -> int64 = "%caml_bigstring_get64" + +external caml_bigstring_set_16 : + bigstring -> int -> int -> unit = "%caml_bigstring_set16" +external caml_bigstring_set_32 : + bigstring -> int -> int32 -> unit = "%caml_bigstring_set32" +external caml_bigstring_set_64 : + bigstring -> int -> int64 -> unit = "%caml_bigstring_set64" + +let bigstring_of_string s = + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + +let s = bigstring_of_string (String.make 10 '\x00') +let empty_s = bigstring_of_string "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_bigstring_get_16 s (-1); + assert_bound_check2 caml_bigstring_get_16 s 9; + assert_bound_check2 caml_bigstring_get_32 s (-1); + assert_bound_check2 caml_bigstring_get_32 s 7; + assert_bound_check2 caml_bigstring_get_64 s (-1); + assert_bound_check2 caml_bigstring_get_64 s 3; + + assert_bound_check3 caml_bigstring_set_16 s (-1) 0; + assert_bound_check3 caml_bigstring_set_16 s 9 0; + assert_bound_check3 caml_bigstring_set_32 s (-1) 0l; + assert_bound_check3 caml_bigstring_set_32 s 7 0l; + assert_bound_check3 caml_bigstring_set_64 s (-1) 0L; + assert_bound_check3 caml_bigstring_set_64 s 3 0L; + + assert_bound_check2 caml_bigstring_get_16 empty_s 0; + assert_bound_check2 caml_bigstring_get_32 empty_s 0; + assert_bound_check2 caml_bigstring_get_64 empty_s 0; + + assert_bound_check3 caml_bigstring_set_16 empty_s 0 0; + assert_bound_check3 caml_bigstring_set_32 empty_s 0 0l; + assert_bound_check3 caml_bigstring_set_64 empty_s 0 0L + + + +let () = + caml_bigstring_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2); + caml_bigstring_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2) + +let () = + caml_bigstring_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2); + caml_bigstring_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2) + +let () = + caml_bigstring_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2); + caml_bigstring_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/bigstring_access.reference b/testsuite/tests/prim-bigstring/bigstring_access.reference new file mode 100644 index 000000000..22b25addf --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml new file mode 100644 index 000000000..3afcc6c55 --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.ml @@ -0,0 +1,89 @@ + +external caml_string_get_16 : string -> int -> int = "%caml_string_get16" +external caml_string_get_32 : string -> int -> int32 = "%caml_string_get32" +external caml_string_get_64 : string -> int -> int64 = "%caml_string_get64" + +external caml_string_set_16 : string -> int -> int -> unit = + "%caml_string_set16" +external caml_string_set_32 : string -> int -> int32 -> unit = + "%caml_string_set32" +external caml_string_set_64 : string -> int -> int64 -> unit = + "%caml_string_set64" + +let s = String.make 10 '\x00' +let empty_s = "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_string_get_16 s (-1); + assert_bound_check2 caml_string_get_16 s 9; + assert_bound_check2 caml_string_get_32 s (-1); + assert_bound_check2 caml_string_get_32 s 7; + assert_bound_check2 caml_string_get_64 s (-1); + assert_bound_check2 caml_string_get_64 s 3; + + assert_bound_check3 caml_string_set_16 s (-1) 0; + assert_bound_check3 caml_string_set_16 s 9 0; + assert_bound_check3 caml_string_set_32 s (-1) 0l; + assert_bound_check3 caml_string_set_32 s 7 0l; + assert_bound_check3 caml_string_set_64 s (-1) 0L; + assert_bound_check3 caml_string_set_64 s 3 0L; + + assert_bound_check2 caml_string_get_16 empty_s 0; + assert_bound_check2 caml_string_get_32 empty_s 0; + assert_bound_check2 caml_string_get_64 empty_s 0; + + assert_bound_check3 caml_string_set_16 empty_s 0 0; + assert_bound_check3 caml_string_set_32 empty_s 0 0l; + assert_bound_check3 caml_string_set_64 empty_s 0 0L + + + +let () = + caml_string_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2); + caml_string_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2) + +let () = + caml_string_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2); + caml_string_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2) + +let () = + caml_string_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2); + caml_string_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/string_access.reference b/testsuite/tests/prim-bigstring/string_access.reference new file mode 100644 index 000000000..22b25addf --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml index 5395840c3..3a40bb51f 100644 --- a/testsuite/tests/regression/pr5757/pr5757.ml +++ b/testsuite/tests/regression/pr5757/pr5757.ml @@ -12,6 +12,6 @@ Random.init 3;; for i = 0 to 100_000 do - ignore (String.create (Random.int 1_000_000)) + ignore (Bytes.create (Random.int 1_000_000)) done;; Printf.printf "hello world\n";; diff --git a/testsuite/tests/regression/pr6024/Makefile b/testsuite/tests/regression/pr6024/Makefile index 964eefced..3426801f5 100644 --- a/testsuite/tests/regression/pr6024/Makefile +++ b/testsuite/tests/regression/pr6024/Makefile @@ -12,5 +12,6 @@ MAIN_MODULE=pr6024 -include ../../../makefiles/Makefile.one -include ../../../makefiles/Makefile.common +BASEDIR=../../.. +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker index 893d1efd9..b4f86ac69 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result - diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.checker b/testsuite/tests/runtime-errors/stackoverflow.native.checker index ac12dd3f8..26c2ccf14 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.native.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.native.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.native.reference stackoverflow.native.result - diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.checker b/testsuite/tests/runtime-errors/syserror.bytecode.checker index ed2d20950..a1cb88a52 100644 --- a/testsuite/tests/runtime-errors/syserror.bytecode.checker +++ b/testsuite/tests/runtime-errors/syserror.bytecode.checker @@ -11,6 +11,3 @@ ######################################################################### grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null - - - diff --git a/testsuite/tests/tool-debugger/.ignore b/testsuite/tests/tool-debugger/basic/.ignore index e09cf9eb6..e09cf9eb6 100644 --- a/testsuite/tests/tool-debugger/.ignore +++ b/testsuite/tests/tool-debugger/basic/.ignore diff --git a/testsuite/tests/tool-debugger/Makefile b/testsuite/tests/tool-debugger/basic/Makefile index f95b4803b..f95b4803b 100644 --- a/testsuite/tests/tool-debugger/Makefile +++ b/testsuite/tests/tool-debugger/basic/Makefile diff --git a/testsuite/tests/tool-debugger/debuggee.ml b/testsuite/tests/tool-debugger/basic/debuggee.ml index 341d0b369..341d0b369 100644 --- a/testsuite/tests/tool-debugger/debuggee.ml +++ b/testsuite/tests/tool-debugger/basic/debuggee.ml diff --git a/testsuite/tests/tool-debugger/debuggee.reference b/testsuite/tests/tool-debugger/basic/debuggee.reference index e998926c3..e998926c3 100644 --- a/testsuite/tests/tool-debugger/debuggee.reference +++ b/testsuite/tests/tool-debugger/basic/debuggee.reference diff --git a/testsuite/tests/tool-debugger/input_script b/testsuite/tests/tool-debugger/basic/input_script index 2caf06dd4..2caf06dd4 100755 --- a/testsuite/tests/tool-debugger/input_script +++ b/testsuite/tests/tool-debugger/basic/input_script diff --git a/testsuite/tests/tool-debugger/find-artifacts/.ignore b/testsuite/tests/tool-debugger/find-artifacts/.ignore new file mode 100644 index 000000000..0a2c0c40c --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/.ignore @@ -0,0 +1,2 @@ +compiler-libs +out diff --git a/testsuite/tests/tool-debugger/find-artifacts/Makefile b/testsuite/tests/tool-debugger/find-artifacts/Makefile new file mode 100644 index 000000000..f313d8642 --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/Makefile @@ -0,0 +1,67 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, EPI Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 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. # +# # +######################################################################### + +BASEDIR=../../.. +MAIN_MODULE=debuggee +ADD_COMPFLAGS=-g -custom +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix + +.PHONY: default +default: + @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ + echo 'skipped (shared libraries not available)'; \ + else \ + $(MAKE) compile; \ + $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \ + fi + +.PHONY: compile +compile: $(ML_FILES) $(CMO_FILES) + @rm -rf out + @rm -f program.byte program.byte.exe + @mkdir out + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/blah.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + in/blah.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/foo.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + -I out in/foo.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + out/blah.cmo out/foo.cmo + @mkdir -p compiler-libs + @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/ + +.PHONY: run +run: + @printf " ... testing with ocamlc" + @rm -f $(MAIN_MODULE).result + @echo 'source input_script' | \ + $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \ + program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \ + && sed -e '/Debugger version/d' -e '/^Time:/d' \ + -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \ + $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \ + && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \ + && echo " => passed" || echo " => failed" + +.PHONY: promote +promote: defaultpromote + +.PHONY: clean +clean: defaultclean + @rm -f *.result program.byte program.byte.exe \ + program.native program.native.exe \ + $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES) + @rm -rf compiler-libs out + +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference new file mode 100644 index 000000000..06564f90b --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference @@ -0,0 +1,6 @@ + +(ocd) Loading program... done. +Breakpoint: 1 +10 <|b|>print x; +x: Blah.blah = Foo +y: Blah.blah = Bar "hi" diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml new file mode 100644 index 000000000..462c07b2e --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml @@ -0,0 +1,3 @@ +type blah = + | Foo + | Bar of string diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml new file mode 100644 index 000000000..8d992673b --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml @@ -0,0 +1,13 @@ +open Blah + +let print = function + | Foo -> print_endline "Foo"; + | Bar s -> print_endline ("Bar(" ^ s ^ ")") + +let main () = + let x = Foo in + let y = Bar "hi" in + print x; + print y + +let _ = main () diff --git a/testsuite/tests/tool-debugger/find-artifacts/input_script b/testsuite/tests/tool-debugger/find-artifacts/input_script new file mode 100644 index 000000000..4b907c5ae --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/input_script @@ -0,0 +1,5 @@ +break @ Foo 10 +run +print x +print y +quit diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml index 1a5995728..005ea68d9 100644 --- a/testsuite/tests/tool-lexyacc/lexgen.ml +++ b/testsuite/tests/tool-lexyacc/lexgen.ml @@ -55,7 +55,9 @@ let rec print_regexp = function | Chars n -> prerr_string "Chars "; prerr_int n | Action n -> prerr_string "Action "; prerr_int n | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2 - | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")" + | Alt(r1,r2) -> + prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; + prerr_string ")" | Star r -> prerr_string "("; print_regexp r; prerr_string ")*" ***) @@ -164,7 +166,7 @@ let rec lastpos = function let followpos size name_regexp_list = - let v = Array.create size [] in + let v = Array.make size [] in let fill_pos first = function OnChars pos -> v.(pos) <- merge_trans first v.(pos); () | ToAction _ -> () in @@ -221,8 +223,8 @@ let goto_state = function let transition_from chars follow pos_set = - let tr = Array.create 256 [] - and shift = Array.create 256 Backtrack in + let tr = Array.make 256 [] + and shift = Array.make 256 Backtrack in List.iter (fun pos -> List.iter @@ -248,7 +250,10 @@ let make_dfa lexdef = let (chars, name_regexp_list, actions) = encode_lexdef lexdef in (** - List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list; + List.iter (fun (name, regexp) -> + prerr_string name; prerr_string " = "; print_regexp regexp; + prerr_newline()) + name_regexp_list; **) let follow = followpos (Array.length chars) name_regexp_list in @@ -258,6 +263,6 @@ let make_dfa lexdef = let states = map_on_states (translate_state chars follow) in let v = - Array.create (number_of_states()) (Perform 0) in + Array.make (number_of_states()) (Perform 0) in List.iter (fun (auto, i) -> v.(i) <- auto) states; (initial_states, v, actions) diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml index 918cadc40..9e34bb2a1 100644 --- a/testsuite/tests/tool-ocamldoc/odoc_test.ml +++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml @@ -53,7 +53,19 @@ class string_gen = p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" (match t.ty_manifest with None -> "None" - | Some e -> Odoc_info.string_of_type_expr e + | Some (Other e) -> Odoc_info.string_of_type_expr e + | Some (Object_type fields) -> + let b = Buffer.create 256 in + Buffer.add_string b "<"; + List.iter + (fun fd -> + Printf.bprintf b " %s: %s ;" + fd.of_name + (Odoc_info.string_of_type_expr fd.of_type) + ) + fields; + Buffer.add_string b " >"; + Buffer.contents b ); ); diff --git a/testsuite/tests/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml index d253be43d..ee291b900 100644 --- a/testsuite/tests/tool-ocamldoc/t01.ml +++ b/testsuite/tests/tool-ocamldoc/t01.ml @@ -16,4 +16,7 @@ module type MT = sig (string * string * string) -> (string * string * string) -> unit val y : int + + type obj_type = + < foo : int ; bar : float -> string ; gee : int -> (int * string) > end diff --git a/testsuite/tests/tool-ocamldoc/t01.reference b/testsuite/tests/tool-ocamldoc/t01.reference index 72345ffec..d5159bdfc 100644 --- a/testsuite/tests/tool-ocamldoc/t01.reference +++ b/testsuite/tests/tool-ocamldoc/t01.reference @@ -23,6 +23,8 @@ string * string * string -> string * string * string -> string * string * string -> unit val y : int + type obj_type = + < bar : float -> string; foo : int; gee : int -> int * string > end]> # type T01.MT.t: # manifest (Odoc_info.string_of_type_expr): @@ -31,3 +33,6 @@ end]> string -> string * string * string -> string * string * string -> string * string * string -> unit]> +# type T01.MT.obj_type: +# manifest (Odoc_info.string_of_type_expr): +<[< bar: float -> string ; foo: int ; gee: int -> int * string ; >]> diff --git a/testsuite/tests/tool-toplevel/Makefile b/testsuite/tests/tool-toplevel/Makefile new file mode 100644 index 000000000..c9433b2ec --- /dev/null +++ b/testsuite/tests/tool-toplevel/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-toplevel/tracing.ml b/testsuite/tests/tool-toplevel/tracing.ml new file mode 100644 index 000000000..5acaff238 --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml @@ -0,0 +1,4 @@ +List.fold_left;; +#trace List.fold_left;; +0;; +List.fold_left (+) 0 [1;2;3];; diff --git a/testsuite/tests/tool-toplevel/tracing.ml.reference b/testsuite/tests/tool-toplevel/tracing.ml.reference new file mode 100644 index 000000000..e6eda8d7f --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml.reference @@ -0,0 +1,30 @@ + +# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun> +# List.fold_left is now traced. +# - : int = 0 +# List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [] +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +- : int = 6 +# diff --git a/testsuite/tests/typing-extensions/Makefile b/testsuite/tests/typing-extensions/Makefile new file mode 100644 index 000000000..5f42b7057 --- /dev/null +++ b/testsuite/tests/typing-extensions/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-extensions/cast.ml b/testsuite/tests/typing-extensions/cast.ml new file mode 100644 index 000000000..afcc2080d --- /dev/null +++ b/testsuite/tests/typing-extensions/cast.ml @@ -0,0 +1,96 @@ + +(* By using two types we can have a recursive constraint *) +type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..> +and 'a name = Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name +;; + +exception Bad_cast +;; + +class type castable = +object + method cast: 'a.'a name -> 'a +end +;; + +(* Lets create a castable class with a name*) + +class type foo_t = +object + inherit castable + method foo: string +end +;; + +type 'a class_name += Foo: foo_t class_name +;; + +class foo: foo_t = +object(self) + method cast: type a. a name -> a = + function + Class Foo -> (self :> foo_t) + | _ -> ((raise Bad_cast) : a) + method foo = "foo" +end +;; + +(* Now we can create a subclass of foo *) + +class type bar_t = +object + inherit foo + method bar: string +end +;; + +type 'a class_name += Bar: bar_t class_name +;; + +class bar: bar_t = +object(self) + inherit foo as super + method cast: type a. a name -> a = + function + Class Bar -> (self :> bar_t) + | other -> super#cast other + method bar = "bar" +end +;; + +(* Now lets create a mutable list of castable objects *) + +let clist :castable list ref = ref [] +;; + +let push_castable (c: #castable) = + clist := (c :> castable) :: !clist +;; + +let pop_castable () = + match !clist with + c :: rest -> + clist := rest; + c + | [] -> raise Not_found +;; + +(* We can add foos and bars to this list, and retrive them *) + +push_castable (new foo);; +push_castable (new bar);; +push_castable (new foo);; + +let c1: castable = pop_castable ();; +let c2: castable = pop_castable ();; +let c3: castable = pop_castable ();; + +(* We can also downcast these values to foos and bars *) + +let f1: foo = c1#cast (Class Foo);; (* Ok *) +let f2: foo = c2#cast (Class Foo);; (* Ok *) +let f3: foo = c3#cast (Class Foo);; (* Ok *) + +let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *) +let b2: bar = c2#cast (Class Bar);; (* Ok *) +let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *) diff --git a/testsuite/tests/typing-extensions/cast.ml.reference b/testsuite/tests/typing-extensions/cast.ml.reference new file mode 100644 index 000000000..c22974163 --- /dev/null +++ b/testsuite/tests/typing-extensions/cast.ml.reference @@ -0,0 +1,33 @@ + +# type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. > +and 'a name = + Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name +# exception Bad_cast +# class type castable = object method cast : 'a name -> 'a end +# class type foo_t = object method cast : 'a name -> 'a method foo : string end +# type 'b class_name += Foo : foo_t class_name +# class foo : foo_t +# class type bar_t = + object + method bar : string + method cast : 'a name -> 'a + method foo : string + end +# type 'b class_name += Bar : bar_t class_name +# class bar : bar_t +# val clist : castable list ref = {contents = []} +# val push_castable : #castable -> unit = <fun> +# val pop_castable : unit -> castable = <fun> +# - : unit = () +# - : unit = () +# - : unit = () +# val c1 : castable = <obj> +# val c2 : castable = <obj> +# val c3 : castable = <obj> +# val f1 : foo = <obj> +# val f2 : foo = <obj> +# val f3 : foo = <obj> +# Exception: Bad_cast. +# val b2 : bar = <obj> +# Exception: Bad_cast. +# diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml new file mode 100644 index 000000000..59a23db9d --- /dev/null +++ b/testsuite/tests/typing-extensions/extensions.ml @@ -0,0 +1,321 @@ + +type foo = .. +;; + +type foo += + A + | B of int +;; + +let is_a x = + match x with + A -> true + | _ -> false +;; + +(* The type must be open to create extension *) + +type foo +;; + +type foo += A of int (* Error type is not open *) +;; + +(* The type parameters must match *) + +type 'a foo = .. +;; + +type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) +;; + +(* In a signature the type does not have to be open *) + +module type S = +sig + type foo + type foo += A of float +end +;; + +(* But it must still be extensible *) + +module type S = +sig + type foo = A of int + type foo += B of float (* Error foo does not have an extensible type *) +end +;; + +(* Signatures can change the grouping of extensions *) + +type foo = .. +;; + +module M = struct + type foo += + A of int + | B of string + + type foo += + C of int + | D of float +end +;; + +module type S = sig + type foo += + B of string + | C of int + + type foo += D of float + + type foo += A of int +end +;; + +module M_S = (M : S) +;; + +(* Extensions can be GADTs *) + +type 'a foo = .. +;; + +type _ foo += + A : int -> int foo + | B : int foo +;; + +let get_num : type a. a foo -> a -> a option = fun f i1 -> + match f with + A i2 -> Some (i1 + i2) + | _ -> None +;; + +(* Extensions must obey constraints *) + +type 'a foo = .. constraint 'a = [> `Var ] +;; + +type 'a foo += A of 'a +;; + +let a = A 9 (* ERROR: Constraints not met *) +;; + +type 'a foo += B : int foo (* ERROR: Constraints not met *) +;; + +(* Signatures can make an extension private *) + +type foo = .. +;; + +module M = struct type foo += A of int end +;; + +let a1 = M.A 10 +;; + +module type S = sig type foo += private A of int end +;; + +module M_S = (M : S) +;; + +let is_s x = + match x with + M_S.A _ -> true + | _ -> false +;; + +let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) +;; + +(* Extensions can be rebound *) + +type foo = .. +;; + +module M = struct type foo += A1 of int end +;; + +type foo += A2 = M.A1 +;; + +type bar = .. +;; + +type bar += A3 = M.A1 (* Error: rebind wrong type *) +;; + +module M = struct type foo += private B1 of int end +;; + +type foo += private B2 = M.B1 +;; + +type foo += B3 = M.B1 (* Error: rebind private extension *) +;; + +type foo += C = Unknown (* Error: unbound extension *) +;; + +(* Extensions can be rebound even if type is closed *) + +module M : sig type foo type foo += A1 of int end + = struct type foo = .. type foo += A1 of int end + +type M.foo += A2 = M.A1 + +(* Rebinding handles abbreviations *) + +type 'a foo = .. +;; + +type 'a foo1 = 'a foo = .. +;; + +type 'a foo2 = 'a foo = .. +;; + +type 'a foo1 += + A of int + | B of 'a + | C : int foo1 +;; + +type 'a foo2 += + D = A + | E = B + | F = C +;; + +(* Extensions must obey variances *) + +type +'a foo = .. +;; + +type 'a foo += A of (int -> 'a) +;; + +type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *) +;; + +type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *) +;; + +type 'a bar = .. +;; + +type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) +;; + +(* Exceptions are compatible with extensions *) + +module M : sig + type exn += + Foo of int * float + | Bar : 'a list -> exn +end = struct + exception Bar : 'a list -> exn + exception Foo of int * float +end +;; + +module M : sig + exception Bar : 'a list -> exn + exception Foo of int * float +end = struct + type exn += + Foo of int * float + | Bar : 'a list -> exn +end +;; + +exception Foo of int * float +;; + +exception Bar : 'a list -> exn +;; + +module M : sig + type exn += + Foo of int * float + | Bar : 'a list -> exn +end = struct + exception Bar = Bar + exception Foo = Foo +end +;; + +(* Test toplevel printing *) + +type foo = .. +;; + +type foo += + Foo of int * int option + | Bar of int option +;; + +let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) +;; + +type foo += Foo of string +;; + +let y = x (* Prints Bar but not Foo (which has been shadowed) *) +;; + +exception Foo of int * int option +;; + +exception Bar of int option +;; + +let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) +;; + +type foo += Foo of string +;; + +let y = x (* Prints Bar and part of Foo (which has been shadowed) *) +;; + +(* Test Obj functions *) + +type foo = .. +;; + +type foo += + Foo + | Bar of int +;; + +let n1 = Obj.extension_name Foo +;; + +let n2 = Obj.extension_name (Bar 1) +;; + +let t = (Obj.extension_id (Bar 2)) = (Obj.extension_id (Bar 3)) (* true *) +;; + +let f = (Obj.extension_id (Bar 2)) = (Obj.extension_id Foo) (* false *) +;; + +let is_foo x = (Obj.extension_id Foo) = (Obj.extension_id x) + +type foo += Foo +;; + +let f = is_foo Foo +;; + +let _ = Obj.extension_name 7 (* Invald_arg *) +;; + +let _ = Obj.extension_id (object method m = 3 end) (* Invald_arg *) +;; diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference new file mode 100644 index 000000000..25af292de --- /dev/null +++ b/testsuite/tests/typing-extensions/extensions.ml.reference @@ -0,0 +1,131 @@ + +# type foo = .. +# type foo += A | B of int +# val is_a : foo -> bool = <fun> +# type foo +# Characters 13-21: + type foo += A of int (* Error type is not open *) + ^^^^^^^^ +Error: Cannot extend type definition foo +# type 'a foo = .. +# Characters 1-30: + type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type foo + They have different arities. +# module type S = sig type foo type foo += A of float end +# Characters 84-106: + type foo += B of float (* Error foo does not have an extensible type *) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type foo is not extensible +# type foo = .. +# module M : + sig + type foo += A of int | B of string + type foo += C of int | D of float + + end +# module type S = + sig + type foo += B of string | C of int + type foo += D of float + type foo += A of int + end +# module M_S : S +# type 'a foo = .. +# type _ foo += A : int -> int foo | B : int foo +# val get_num : 'a foo -> 'a -> 'a option = <fun> +# type 'a foo = .. constraint 'a = [> `Var ] +# type 'a foo += A of 'a +# Characters 11-12: + let a = A 9 (* ERROR: Constraints not met *) + ^ +Error: This expression has type int but an expression was expected of type + [> `Var ] +# Characters 20-23: + type 'a foo += B : int foo (* ERROR: Constraints not met *) + ^^^ +Error: This type int should be an instance of type [> `Var ] +# type foo = .. +# module M : sig type foo += A of int end +# val a1 : foo = M.A 10 +# module type S = sig type foo += private A of int end +# module M_S : S +# val is_s : foo -> bool = <fun> +# Characters 10-18: + let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) + ^^^^^^^^ +Error: Cannot create values of the private type foo +# type foo = .. +# module M : sig type foo += A1 of int end +# type foo += A2 of int +# type bar = .. +# Characters 18-22: + type bar += A3 = M.A1 (* Error: rebind wrong type *) + ^^^^ +Error: The constructor M.A1 has type foo but was expected to be of type bar +# module M : sig type foo += private B1 of int end +# type foo += private B2 of int +# Characters 18-22: + type foo += B3 = M.B1 (* Error: rebind private extension *) + ^^^^ +Error: The constructor M.B1 is private +# Characters 13-24: + type foo += C = Unknown (* Error: unbound extension *) + ^^^^^^^^^^^ +Error: Unbound constructor Unknown +# module M : sig type foo type foo += A1 of int end +type M.foo += A2 of int +type 'a foo = .. +# type 'a foo1 = 'a foo = .. +# type 'a foo2 = 'a foo = .. +# type 'a foo1 += A of int | B of 'a | C : int foo1 +# type 'a foo2 += D of int | E of 'a | F : int foo2 +# type +'a foo = .. +# type 'a foo += A of (int -> 'a) +# Characters 1-32: + type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +# Characters 1-40: + type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +# type 'a bar = .. +# Characters 1-33: + type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type bar + Their variances do not agree. +# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +# module M : + sig exception Bar : 'a list -> exn exception Foo of int * float end +# exception Foo of int * float +# exception Bar : 'a list -> exn +# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +# type foo = .. +# type foo += Foo of int * int option | Bar of int option +# val x : foo * foo = (Foo (3, Some 4), Bar (Some 5)) +# type foo += Foo of string +# val y : foo * foo = (<extension>, Bar (Some 5)) +# exception Foo of int * int option +# exception Bar of int option +# val x : exn * exn = (Foo (3, Some 4), Bar (Some 5)) +# type foo += Foo of string +# val y : exn * exn = (Foo (3, _), Bar (Some 5)) +# type foo = .. +# type foo += Foo | Bar of int +# val n1 : string = "Foo" +# val n2 : string = "Bar" +# val t : bool = true +# val f : bool = false +# val is_foo : 'a -> bool = <fun> +type foo += Foo +# val f : bool = false +# Exception: Invalid_argument "Obj.extension_name". +# Exception: Invalid_argument "Obj.extension_id". +# diff --git a/testsuite/tests/typing-extensions/msg.ml b/testsuite/tests/typing-extensions/msg.ml new file mode 100644 index 000000000..ef1c12fb4 --- /dev/null +++ b/testsuite/tests/typing-extensions/msg.ml @@ -0,0 +1,131 @@ +(* Typed names *) + +module Msg : sig + + type 'a tag + + type result = Result : 'a tag * 'a -> result + + val write : 'a tag -> 'a -> unit + + val read : unit -> result + + type 'a tag += Int : int tag + + module type Desc = sig + type t + val label : string + val write : t -> string + val read : string -> t + end + + module Define (D : Desc) : sig + type 'a tag += C : D.t tag + end + +end = struct + + type 'a tag = .. + + type ktag = T : 'a tag -> ktag + + type 'a kind = + { tag : 'a tag; + label : string; + write : 'a -> string; + read : string -> 'a; } + + type rkind = K : 'a kind -> rkind + + type wkind = { f : 'a . 'a tag -> 'a kind } + + let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13 + + let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13 + + let read_raw () : string * string = raise (Failure "Not implemented") + + type result = Result : 'a tag * 'a -> result + + let read () = + let label, content = read_raw () in + let K k = Hashtbl.find readTbl label in + let body = k.read content in + Result(k.tag, body) + + let write_raw (label : string) (content : string) = + raise (Failure "Not implemented") + + let write (tag : 'a tag) (body : 'a) = + let {f} = Hashtbl.find writeTbl (T tag) in + let k = f tag in + let content = k.write body in + write_raw k.label content + + (* Add int kind *) + + type 'a tag += Int : int tag + + let ik = + { tag = Int; + label = "int"; + write = string_of_int; + read = int_of_string } + + let () = Hashtbl.add readTbl "int" (K ik) + + let () = + let f (type t) (i : t tag) : t kind = + match i with + Int -> ik + | _ -> assert false + in + Hashtbl.add writeTbl (T Int) {f} + + (* Support user defined kinds *) + + module type Desc = sig + type t + val label : string + val write : t -> string + val read : string -> t + end + + module Define (D : Desc) = struct + type 'a tag += C : D.t tag + let k = + { tag = C; + label = D.label; + write = D.write; + read = D.read } + let () = Hashtbl.add readTbl D.label (K k) + let () = + let f (type t) (c : t tag) : t kind = + match c with + C -> k + | _ -> assert false + in + Hashtbl.add writeTbl (T C) {f} + end + +end;; + +let write_int i = Msg.write Msg.Int i;; + +module StrM = Msg.Define(struct + type t = string + let label = "string" + let read s = s + let write s = s +end);; + +type 'a Msg.tag += String = StrM.C;; + +let write_string s = Msg.write String s;; + +let read_one () = + let Msg.Result(tag, body) = Msg.read () in + match tag with + Msg.Int -> print_int body + | String -> print_string body + | _ -> print_string "Unknown";; diff --git a/testsuite/tests/typing-extensions/msg.ml.reference b/testsuite/tests/typing-extensions/msg.ml.reference new file mode 100644 index 000000000..e7f1a8f24 --- /dev/null +++ b/testsuite/tests/typing-extensions/msg.ml.reference @@ -0,0 +1,23 @@ + +# module Msg : + sig + type 'a tag + type result = Result : 'a tag * 'a -> result + val write : 'a tag -> 'a -> unit + val read : unit -> result + type 'a tag += Int : int tag + module type Desc = + sig + type t + val label : string + val write : t -> string + val read : string -> t + end + module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end + end +# val write_int : int -> unit = <fun> +# module StrM : sig type 'a Msg.tag += C : string Msg.tag end +# type 'a Msg.tag += String : string Msg.tag +# val write_string : string -> unit = <fun> +# val read_one : unit -> unit = <fun> +# diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml new file mode 100644 index 000000000..e7632cac2 --- /dev/null +++ b/testsuite/tests/typing-extensions/open_types.ml @@ -0,0 +1,109 @@ +type foo = .. +;; + +(* Check that abbreviations work *) + +type bar = foo = .. +;; + +type baz = foo = .. +;; + +type bar += Bar1 of int +;; + +type baz += Bar2 of int +;; + +module M = struct type bar += Foo of float end +;; + +module type S = sig type baz += Foo of float end +;; + +module M_S = (M : S) +;; + +(* Abbreviations need to be made open *) + +type foo = .. +;; + +type bar = foo +;; + +type bar += Bar of int (* Error: type is not open *) +;; + +type baz = bar = .. (* Error: type kinds don't match *) +;; + +(* Abbreviations need to match parameters *) + +type 'a foo = .. +;; + +type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) +;; + +type ('a, 'b) foo = .. +;; + +type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) +;; + +(* Private abstract types cannot be open *) + +type foo = .. +;; + +type bar = private foo = .. (* ERROR: Private abstract types cannot be open *) +;; + +(* Check that signatures can hide open-ness *) + +module M = struct type foo = .. end +;; + +module type S = sig type foo end +;; + +module M_S = (M : S) +;; + +type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) +;; + +(* Check that signatures cannot add open-ness *) + +module M = struct type foo end +;; + +module type S = sig type foo = .. end +;; + +module M_S = (M : S) (* ERROR: Signatures are not compatible *) +;; + +(* Check that signatures maintain variances *) + +module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end +;; + +module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end +;; + +module M_S = (M : S) (* ERROR: Signatures are not compatible *) +;; + +(* Exn is an open type *) + +type exn2 = exn = .. +;; + +(* Exhaustiveness *) + +type foo = .. +type foo += Foo +let f = function Foo -> () +;; (* warn *) diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference new file mode 100644 index 000000000..5fb9684d4 --- /dev/null +++ b/testsuite/tests/typing-extensions/open_types.ml.reference @@ -0,0 +1,83 @@ + +# type foo = .. +# type bar = foo = .. +# type baz = foo = .. +# type bar += Bar1 of int +# type baz += Bar2 of int +# module M : sig type bar += Foo of float end +# module type S = sig type baz += Foo of float end +# module M_S : S +# type foo = .. +# type bar = foo +# Characters 13-23: + type bar += Bar of int (* Error: type is not open *) + ^^^^^^^^^^ +Error: Cannot extend type definition bar +# Characters 6-20: + type baz = bar = .. (* Error: type kinds don't match *) + ^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type bar + Their kinds differ. +# type 'a foo = .. +# Characters 6-32: + type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type 'a foo + They have different arities. +# type ('a, 'b) foo = .. +# Characters 6-38: + type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + ('a, 'a) foo + Their constraints differ. +# type foo = .. +# Characters 24-25: + type bar = private foo = .. (* ERROR: Private abstract types cannot be open *) + ^ +Error: Syntax error +# module M : sig type foo = .. end +# module type S = sig type foo end +# module M_S : S +# Characters 17-20: + type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) + ^^^ +Error: Cannot extend type definition M_S.foo +# module M : sig type foo end +# module type S = sig type foo = .. end +# Characters 15-16: + module M_S = (M : S) (* ERROR: Signatures are not compatible *) + ^ +Error: Signature mismatch: + Modules do not match: sig type foo = M.foo end is not included in S + Type declarations do not match: + type foo = M.foo + is not included in + type foo = .. + Their kinds differ. +# module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end +# module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end +# Characters 15-16: + module M_S = (M : S) (* ERROR: Signatures are not compatible *) + ^ +Error: Signature mismatch: + Modules do not match: + sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end + is not included in + S + Type declarations do not match: + type 'a foo = 'a M.foo = .. + is not included in + type 'a foo = .. + Their variances do not agree. +# type exn2 = exn = .. +# Characters 61-79: + let f = function Foo -> () + ^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +*extension* +type foo = .. +type foo += Foo +val f : foo -> unit = <fun> +# diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile index e854696f4..e77918367 100644 --- a/testsuite/tests/typing-fstclassmod/Makefile +++ b/testsuite/tests/typing-fstclassmod/Makefile @@ -13,7 +13,7 @@ BASEDIR=../.. #MODULES= MAIN_MODULE=fstclassmod -ADD_COMPFLAGS=-w a +ADD_COMPFLAGS=-w A -warn-error A include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml index 82af377be..bc8d66e51 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.ml +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml @@ -146,11 +146,20 @@ let () = module type S1 = sig end module type S2 = S1 -let f (x : (module S1)) : (module S2) = x +let _f (x : (module S1)) : (module S2) = x module X = struct module type S end module Y = struct include X end -let f (x : (module X.S)) : (module Y.S) = x +let _f (x : (module X.S)) : (module Y.S) = x + +(* PR#6194, main example *) +module type S3 = sig val x : bool end;; +let f = function + | Some (module M : S3) when M.x ->1 + | Some _ -> 2 + | None -> 3 +;; +print_endline (string_of_int (f (Some (module struct let x = false end))));; diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.reference b/testsuite/tests/typing-fstclassmod/fstclassmod.reference index 59c7aa116..ec517d789 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.reference +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.reference @@ -4,3 +4,4 @@ abc/def/xyz xyz/def/abc XXXXXXXX 10 (123,("A",456)) +2 diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml new file mode 100644 index 000000000..8091375c0 --- /dev/null +++ b/testsuite/tests/typing-gadts/didier.ml @@ -0,0 +1,48 @@ +type 'a ty = + | Int : int ty + | Bool : bool ty + +let fbool (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x +;; +(* val fbool : 'a -> 'a ty -> 'a = <fun> *) +(** OK: the return value is x of type t **) + +let fint (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 +;; +(* val fint : 'a -> 'a ty -> bool = <fun> *) +(** OK: the return value is x > 0 of type bool; +This has used the equation t = bool, not visible in the return type **) + +let f (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 + | Bool -> x +(* val f : 'a -> 'a ty -> bool = <fun> *) + + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x + | Int -> x > 0 +(* Error: This expression has type bool but an expression was expected of type +t = int *) + +let id x = x;; +let idb1 = (fun id -> let _ = id true in id) id;; +let idb2 : bool -> bool = id;; +let idb3 ( _ : bool ) = false;; + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb3 x + | Int -> x > 0 + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb2 x + | Int -> x > 0 + diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml index 8ba45d2df..0acc90868 100644 --- a/testsuite/tests/typing-gadts/pr5948.ml +++ b/testsuite/tests/typing-gadts/pr5948.ml @@ -1,6 +1,6 @@ type tag = [`TagA | `TagB | `TagC];; -type 'a poly = +type 'a poly = AandBTags : [< `TagA of int | `TagB ] poly | ATag : [< `TagA of int] poly (* constraint 'a = [< `TagA of int | `TagB] *) @@ -10,17 +10,17 @@ let intA = function `TagA i -> i let intB = function `TagB -> 4 ;; -let intAorB = function +let intAorB = function `TagA i -> i | `TagB -> 4 ;; -type _ wrapPoly = +type _ wrapPoly = WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly ;; let example6 : type a. a wrapPoly -> (a -> int) = - fun w -> + fun w -> match w with | WrapPoly ATag -> intA | WrapPoly _ -> intA (* This should not be allowed *) diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml index 6d0bbcee7..23902add3 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml +++ b/testsuite/tests/typing-gadts/pr5985.ml @@ -29,7 +29,7 @@ end;; (* fail *) (* Another (more direct) instance using polymorphic variants *) (* PR#6275 *) type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *) -let magic (x : int) : bool = +let magic (x : int) : bool = let A x = A x in x;; (* fail *) type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *) diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml index e9646196e..ad5e8eda7 100644 --- a/testsuite/tests/typing-gadts/pr6163.ml +++ b/testsuite/tests/typing-gadts/pr6163.ml @@ -1,4 +1,4 @@ -type _ nat = +type _ nat = Zero : [`Zero] nat | Succ : 'a nat -> [`Succ of 'a] nat;; type 'a pre_nat = [`Zero | `Succ of 'a];; diff --git a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference index 647015c36..8f2be5252 100644 --- a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference +++ b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference @@ -1,8 +1,7 @@ -# Characters 118-119: +# Characters 137-138: fun C k -> k (fun x -> x);; - ^ -Error: Recursive local constraint when unifying - (((ex#0 -> ex#1) -> ex#1) -> (ex#2 -> ex#1) -> ex#1) t - with ((a -> o) -> o) t + ^ +Error: This expression has type ex#0 but an expression was expected of type + ex#1 = (ex#2 -> ex#1) -> ex#1 # diff --git a/testsuite/tests/typing-gadts/pr6174.ml.reference b/testsuite/tests/typing-gadts/pr6174.ml.reference index 647015c36..8f2be5252 100644 --- a/testsuite/tests/typing-gadts/pr6174.ml.reference +++ b/testsuite/tests/typing-gadts/pr6174.ml.reference @@ -1,8 +1,7 @@ -# Characters 118-119: +# Characters 137-138: fun C k -> k (fun x -> x);; - ^ -Error: Recursive local constraint when unifying - (((ex#0 -> ex#1) -> ex#1) -> (ex#2 -> ex#1) -> ex#1) t - with ((a -> o) -> o) t + ^ +Error: This expression has type ex#0 but an expression was expected of type + ex#1 = (ex#2 -> ex#1) -> ex#1 # diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index a8215290a..2f0bb9196 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -102,12 +102,8 @@ module Existential_escape = module Rectype = struct type (_,_) t = C : ('a,'a) t - let _ = - fun (type s) -> - let a : (s, s * s) t = failwith "foo" in - match a with - C -> - () + let f : type s. (s, s*s) t -> unit = + fun C -> () (* here s = s*s! *) end ;; diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 0d40f674a..fd9fb3501 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -53,10 +53,8 @@ module Nonexhaustive : Error: This expression has type a#2 t but an expression was expected of type a#2 t The type constructor a#2 would escape its scope -# Characters 174-175: - C -> - ^ -Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t +# module Rectype : + sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index e6aa47b41..a5faa02c0 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -53,10 +53,8 @@ module Nonexhaustive : Error: This expression has type a#2 t but an expression was expected of type a#2 t The type constructor a#2 would escape its scope -# Characters 174-175: - C -> - ^ -Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t +# module Rectype : + sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ diff --git a/testsuite/tests/typing-labels/mixin2.ml b/testsuite/tests/typing-labels/mixin2.ml index 8a5498fa3..fd2b28979 100644 --- a/testsuite/tests/typing-labels/mixin2.ml +++ b/testsuite/tests/typing-labels/mixin2.ml @@ -182,7 +182,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-labels/mixin3.ml b/testsuite/tests/typing-labels/mixin3.ml index 0b9db2428..5b987e819 100644 --- a/testsuite/tests/typing-labels/mixin3.ml +++ b/testsuite/tests/typing-labels/mixin3.ml @@ -176,7 +176,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml index 5408ca2c1..a00636325 100644 --- a/testsuite/tests/typing-misc/constraints.ml +++ b/testsuite/tests/typing-misc/constraints.ml @@ -14,3 +14,11 @@ type 'a t = 'a;; let f (x : 'a t as 'a) = ();; (* fails *) let f (x : 'a t) (y : 'a) = x = y;; + +(* PR#6505 *) +module type PR6505 = sig + type 'o is_an_object = < .. > as 'o + and 'o abs constraint 'o = 'o is_an_object + val abs : 'o is_an_object -> 'o abs + val unabs : 'o abs -> 'o +end;; (* fails *) diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference index fe5204400..83a3dc1f9 100644 --- a/testsuite/tests/typing-misc/constraints.ml.reference +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -26,4 +26,9 @@ Error: This alias is bound to type 'a t = 'a but is used as an instance of type 'a The type variable 'a occurs inside 'a # val f : 'a t -> 'a -> bool = <fun> +# Characters 83-122: + and 'o abs constraint 'o = 'o is_an_object + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of abs contains a cycle: + 'a is_an_object as 'a # diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml index b0f0229a6..2d4b9d19d 100644 --- a/testsuite/tests/typing-misc/labels.ml +++ b/testsuite/tests/typing-misc/labels.ml @@ -1,4 +1,11 @@ (* PR#5835 *) - let f ~x = x + 1;; f ?x:0;; + +(* PR#6352 *) +let foo (f : unit -> unit) = ();; +let g ?x () = ();; +foo ((); g);; + +(* PR#5748 *) +foo (fun ?opt () -> ()) ;; (* fails *) diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference index b76dcddc5..f8be126bb 100644 --- a/testsuite/tests/typing-misc/labels.ml.principal.reference +++ b/testsuite/tests/typing-misc/labels.ml.principal.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference index b76dcddc5..f8be126bb 100644 --- a/testsuite/tests/typing-misc/labels.ml.reference +++ b/testsuite/tests/typing-misc/labels.ml.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml new file mode 100644 index 000000000..b0bd52227 --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml @@ -0,0 +1,8 @@ +(* PR#6394 *) + +module rec X : sig + type t = int * bool +end = struct + type t = A | B + let f = function A | B -> 0 +end;; diff --git a/testsuite/tests/typing-misc/variant.ml.reference b/testsuite/tests/typing-misc/variant.ml.reference new file mode 100644 index 000000000..4de6b611e --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml.reference @@ -0,0 +1,16 @@ + +# Characters 61-116: + ......struct + type t = A | B + let f = function A | B -> 0 + end.. +Error: Signature mismatch: + Modules do not match: + sig type t = X.t = A | B val f : t -> int end + is not included in + sig type t = int * bool end + Type declarations do not match: + type t = X.t = A | B + is not included in + type t = int * bool +# diff --git a/testsuite/tests/typing-modules-bugs/pr6427_bad.ml b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml new file mode 100644 index 000000000..286dafb88 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml @@ -0,0 +1,20 @@ +let flag = ref false +module F(S : sig module type T end) (A : S.T) (B : S.T) = +struct + module X = (val if !flag then (module A) else (module B) : S.T) +end + +(* If the above were accepted, one could break soundness *) +module type S = sig type t val x : t end +module Float = struct type t = float let x = 0.0 end +module Int = struct type t = int let x = 0 end + +module M = F(struct module type T = S end) + +let () = flag := false +module M1 = M(Float)(Int) + +let () = flag := true +module M2 = M(Float)(Int) + +let _ = [| M2.X.x; M1.X.x |] diff --git a/testsuite/tests/typing-modules-bugs/pr6513_ok.ml b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml new file mode 100644 index 000000000..f23fc599a --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml @@ -0,0 +1,25 @@ +module type PR6513 = sig +module type S = sig type u end + +module type T = sig + type 'a wrap + type uri +end + +module Make: functor (Html5 : T with type 'a wrap = 'a) -> + S with type u = < foo : Html5.uri > +end + +(* Requires -package tyxml +module type PR6513_orig = sig +module type S = +sig + type t + type u +end + +module Make: functor (Html5: Html5_sigs.T with type 'a Xml.wrap = 'a and type 'a wrap = 'a and type 'a list_wrap = 'a list) -> S with + type t = Html5_types.div Html5.elt and + type u = < foo: Html5.uri > +end +*) diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index e5cbe9f39..640655eb1 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -52,5 +52,11 @@ type u = X of bool;; module type B = A with type t = u;; (* fail *) (* PR#5815 *) +(* ---> duplicated exception name is now an error *) module type S = sig exception Foo of int exception Foo of bool end;; + +(* PR#6410 *) + +module F(X : sig end) = struct let x = 3 end;; +F.x;; (* fail *) diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index 8e993fa3a..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -28,5 +28,14 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. +# module F : functor (X : sig end) -> sig val x : int end +# Characters 0-3: + F.x;; (* fail *) + ^^^ +Error: The module F is a functor, not a structure # diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index 8e993fa3a..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -28,5 +28,14 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. +# module F : functor (X : sig end) -> sig val x : int end +# Characters 0-3: + F.x;; (* fail *) + ^^^ +Error: The module F is a functor, not a structure # diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 0b7e7ae2b..3eca52714 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -4,11 +4,6 @@ C.chr 66;; module C' : module type of Char = C;; C'.chr 66;; -module C'' : (module C) = C';; (* fails *) - -module C'' : (module Char) = C;; -C''.chr 66;; - module C3 = struct include Char end;; C3.chr 66;; @@ -112,7 +107,7 @@ let f (x : t) : T.t = x ;; module A = struct module B = struct type t let compare x y = 0 end module S = Set.Make(B) - let empty = S.empty + let empty = S.empty end module A1 = A;; A1.empty = A.empty;; @@ -192,3 +187,51 @@ module M = struct end end;; module type S = module type of M ;; + +(* PR#6365 *) +module type S = sig module M : sig type t val x : t end end;; +module H = struct type t = A let x = A end;; +module H' = H;; +module type S' = S with module M = H';; (* shouldn't introduce an alias *) + +(* PR#6376 *) +module type Alias = sig module N : sig end module M = N end;; +module F (X : sig end) = struct type t end;; +module type A = Alias with module N := F(List);; +module rec Bad : A = Bad;; + +(* Shinwell 2014-04-23 *) +module B = struct + module R = struct + type t = string + end + + module O = R +end + +module K = struct + module E = B + module N = E.O +end;; + +let x : K.N.t = "foo";; + +(* PR#6465 *) + +module M = struct type t = A module B = struct type u = B end end;; +module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *) +module P : sig type t = M.t = A module B = M.B end = struct include M end;; + +module type S = sig + module M : sig module P : sig end end + module Q = M +end;; +module type S = sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end +end;; +module R = struct + module M = struct module N = struct end module P = struct end end + module Q = M +end;; +module R' : S = R;; (* should be ok *) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index 730252b58..e6611acbb 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -13,13 +13,6 @@ external unsafe_chr : int -> char = "%identity" end # - : char = 'B' -# Characters 27-29: - module C'' : (module C) = C';; (* fails *) - ^^ -Error: Signature mismatch: - Modules do not match: (module C') is not included in (module C) -# module C'' = Char -# - : char = 'B' # module C3 : sig external code : char -> int = "%identity" @@ -347,4 +340,46 @@ Error: In this `with' constraint, the new definition of I module Q : sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end end +# module type S = sig module M : sig type t val x : t end end +# module H : sig type t = A val x : t end +# module H' = H +# module type S' = sig module M : sig type t = H.t = A val x : t end end +# module type Alias = sig module N : sig end module M = N end +# module F : functor (X : sig end) -> sig type t end +# Characters -1--1: + module type A = Alias with module N := F(List);; + +Error: Module type declarations do not match: + module type A = sig module M = F(List) end + does not match + module type A = sig module M = F(List) end + At position module type A = <here> + Modules do not match: + sig module M = F(List) end + is not included in + sig module M = F(List) end + At position module type A = sig module M : <here> end + Module F(List) cannot be aliased +# Characters 17-18: + module rec Bad : A = Bad;; + ^ +Error: Unbound module type A +# module B : sig module R : sig type t = string end module O = R end +module K : sig module E = B module N = E.O end +# val x : K.N.t = "foo" +# module M : sig type t = A module B : sig type u = B end end +# module P : sig type t = M.t = A module B = M.B end +# module P : sig type t = M.t = A module B = M.B end +# module type S = sig module M : sig module P : sig end end module Q = M end +# module type S = + sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end + end +# module R : + sig + module M : sig module N : sig end module P : sig end end + module Q = M + end +# module R' : S # diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml index 2768aba61..dc5bf5289 100644 --- a/testsuite/tests/typing-modules/generative.ml +++ b/testsuite/tests/typing-modules/generative.ml @@ -27,7 +27,8 @@ module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) (* tests for shortened functor notation () *) module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;; -module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> struct end;; +module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> + struct end;; module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;; module GZ : functor (X: sig end) () (Z: sig end) -> sig end = functor (X: sig end) () (Z: sig end) -> struct end;; diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference index 19aaa1284..a6aa10026 100644 --- a/testsuite/tests/typing-modules/generative.ml.reference +++ b/testsuite/tests/typing-modules/generative.ml.reference @@ -38,7 +38,7 @@ Error: Signature mismatch: is not included in functor (X : sig end) -> sig end # module X : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end -# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end +# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end # module Z : functor (_ : sig end) (_ : sig end) (_ : sig end) -> sig end # module GZ : functor (X : sig end) () (Z : sig end) -> sig end # diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index ba3e64f01..5ffc6498f 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -170,14 +170,14 @@ p1#print (fun x -> x#print);; (*******************************************************************) class virtual comparable () = object (self : 'a) - method virtual leq : 'a -> bool + method virtual cmp : 'a -> int end;; class int_comparable (x : int) = object inherit comparable () val x = x method x = x - method leq p = x <= p#x + method cmp p = compare x p#x end;; class int_comparable2 xi = object @@ -193,7 +193,7 @@ class ['a] sorted_list () = object let rec insert = function [] -> [x] - | a::l as l' -> if a#leq x then a::(insert l) else x::l' + | a::l as l' -> if a#cmp x <= 0 then a::(insert l) else x::l' in l <- insert l method hd = List.hd l @@ -209,7 +209,7 @@ l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) class int_comparable3 (x : int) = object val mutable x = x - method leq (y : int_comparable) = x < y#x + method cmp (y : int_comparable) = compare x y#x method x = x method setx y = x <- y end;; @@ -218,7 +218,7 @@ let c3 = new int_comparable3 15;; l#add (c3 :> int_comparable);; (new sorted_list ())#add c3;; (* Error; strange message with -principal *) -let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;; +let sort (l : #comparable list) = List.sort (fun x -> x#cmp) l;; let pr l = List.map (fun c -> print_int c#x; print_string " ") l; print_newline ();; @@ -231,7 +231,7 @@ pr l;; pr (sort l);; let min (x : #comparable) y = - if x#leq y then x else y;; + if x#cmp y <= 0 then x else y;; (min (new int_comparable 7) (new int_comparable 11))#x;; (min (new int_comparable2 5) (new int_comparable2 3))#x;; diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference index 0b04607a2..2b12a7d9b 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + 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 leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,11 +235,11 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > - is not compatible with type 'a = < leq : 'a -> bool; .. > + #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: diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 353f607cb..7cbd68ec2 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + 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 leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,13 +235,13 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not compatible with type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < 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: diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index befd70d94..917474f96 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -236,7 +236,7 @@ end;; let d = new d () in d#xc, d#xd;; class virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; @@ -305,26 +305,28 @@ 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 r = ref 0;; +let id o = Oo.id o - !r;; +r := Oo.id (object end);; +id (object end);; +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'');; + (id o, id o', 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);; + (id o, id o', 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);; + 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);; (* Recursion (cf. PR#5291) *) diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index 76ade6755..e5d9bb8d5 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * 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 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + 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 > @@ -244,9 +244,9 @@ Error: Signature mismatch: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c -# Characters 32-55: +# 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> @@ -295,12 +295,14 @@ 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 = 95 -# - : int = 96 -# - : int = 97 -# - : int * int * int = (98, 99, 100) -# - : int * int * int * int * int = (101, 102, 103, 33, 33) -# - : int * int * int * int * int = (104, 105, 106, 33, 33) +# 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 ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 97ed42ca7..ed4df922d 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * 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 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + 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 > @@ -244,9 +244,9 @@ Error: Signature mismatch: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c -# Characters 32-55: +# 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> @@ -294,12 +294,14 @@ 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 = 95 -# - : int = 96 -# - : int = 97 -# - : int * int * int = (98, 99, 100) -# - : int * int * int * int * int = (101, 102, 103, 33, 33) -# - : int * int * int * int * int = (104, 105, 106, 33, 33) +# 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 ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-objects/pr6383.ml b/testsuite/tests/typing-objects/pr6383.ml new file mode 100644 index 000000000..bd2fdb06f --- /dev/null +++ b/testsuite/tests/typing-objects/pr6383.ml @@ -0,0 +1 @@ +let f (x: #M.foo) = 0;; diff --git a/testsuite/tests/typing-objects/pr6383.ml.reference b/testsuite/tests/typing-objects/pr6383.ml.reference new file mode 100644 index 000000000..01b6141d3 --- /dev/null +++ b/testsuite/tests/typing-objects/pr6383.ml.reference @@ -0,0 +1,6 @@ + +# Characters 10-16: + let f (x: #M.foo) = 0;; + ^^^^^^ +Error: Unbound module M +# diff --git a/testsuite/tests/typing-private/private.ml.principal.reference b/testsuite/tests/typing-private/private.ml.principal.reference index 03e795701..96b1d7595 100644 --- a/testsuite/tests/typing-private/private.ml.principal.reference +++ b/testsuite/tests/typing-private/private.ml.principal.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index 360940c92..cb1573ed4 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml new file mode 100644 index 000000000..82fad0783 --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -0,0 +1,86 @@ +type t = A of {x:int; mutable y:int};; +let f (A r) = r;; (* -> escape *) +let f (A r) = r.x;; (* ok *) +let f x = A {x; y = x};; (* ok *) +let f (A r) = A {r with y = r.x + 1};; (* ok *) +let f () = A {a = 1};; (* customized error message *) +let f () = A {x = 1; y = 3};; (* ok *) + +type _ t = A: {x : 'a; y : 'b} -> 'a t;; +let f (A {x; y}) = A {x; y = ()};; (* ok *) +let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *) + +module M = struct + type 'a t = + | A of {x : 'a} + | B: {u : 'b} -> unit t;; + + exception Foo of {x : int};; +end;; + +module N : sig + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'bla} -> unit t + + exception Foo of {x : int} +end = struct + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'z} -> unit t + + exception Foo = M.Foo +end;; + + +module type S = sig exception A of {x:int} end;; + +module F (X : sig val x : (module S) end) = struct + module A = (val X.x) +end;; (* -> this expression creates fresh types (not really!) *) + + +module type S = sig + exception A of {x : int} + exception A of {x : string} +end;; + +module M = struct + exception A of {x : int} + exception A of {x : string} +end;; + + +module M1 = struct + exception A of {x : int} +end;; + +module M = struct + include M1 + include M1 +end;; + + +module type S1 = sig + exception A of {x : int} +end;; + +module type S = sig + include S1 + include S1 +end;; + +module M = struct + exception A = M1.A +end;; + +module X1 = struct + type t = .. +end;; +module X2 = struct + type t = .. +end;; +module Z = struct + type X1.t += A of {x: int} + type X2.t += A of {x: int} +end;; diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference index 96198167a..12f609aca 100644 --- a/testsuite/tests/typing-recordarg/recordarg.ml.reference +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -1,8 +1,64 @@ -# module M : +# type t = A of { x : int; mutable y : int; } +# Characters 14-15: + let f (A r) = r;; (* -> escape *) + ^ +Error: This form is not allowed as the type of the inlined record could escape. +# val f : t -> int = <fun> +# val f : int -> t = <fun> +# val f : t -> t = <fun> +# Characters 14-15: + let f () = A {a = 1};; (* customized error message *) + ^ +Error: The field a is not part of the record argument for the t.A constructor +# val f : unit -> t = <fun> +# type _ t = A : { x : 'a; y : 'b; } -> 'a t +# val f : 'a t -> 'a t = <fun> +# val f : 'a t -> 'a t = <fun> +# module M : sig type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t exception Foo of { x : int; } end -# module N : sig exception Foo of { x : int; } end +# module N : + sig + type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t + exception Foo of { x : int; } + end +# module type S = sig exception A of { x : int; } end +# Characters 65-74: + module A = (val X.x) + ^^^^^^^^^ +Error: This expression creates fresh types. + It is not allowed inside applicative functors. +# Characters 61-62: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# Characters 58-59: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M1 : sig exception A of { x : int; } end +# Characters 34-44: + include M1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module type S1 = sig exception A of { x : int; } end +# Characters 36-46: + include S1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M : sig exception A of { x : int; } end +# module X1 : sig type t = .. end +# module X2 : sig type t = .. end +# Characters 62-63: + type X2.t += A of {x: int} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. # diff --git a/testsuite/tests/typing-signatures/pr6371.ml b/testsuite/tests/typing-signatures/pr6371.ml new file mode 100644 index 000000000..d717b9e68 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6371.ml @@ -0,0 +1,7 @@ +module M = struct + type t = int * (< m : 'a > as 'a) +end;; + +module type S = + sig module M : sig type t end end with module M = M +;; diff --git a/testsuite/tests/typing-signatures/pr6371.ml.reference b/testsuite/tests/typing-signatures/pr6371.ml.reference new file mode 100644 index 000000000..d6d916a71 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6371.ml.reference @@ -0,0 +1,4 @@ + +# module M : sig type t = int * (< m : 'a > as 'a) end +# module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end +# diff --git a/testsuite/tests/typing-warnings/coercions.ml b/testsuite/tests/typing-warnings/coercions.ml new file mode 100644 index 000000000..1ca390b28 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml @@ -0,0 +1,5 @@ +(* comment 9644 of PR#6000 *) + +fun b -> if b then format_of_string "x" else "y";; +fun b -> if b then "x" else format_of_string "y";; +fun b -> (if b then "x" else "y" : (_,_,_) format);; diff --git a/testsuite/tests/typing-warnings/coercions.ml.principal.reference b/testsuite/tests/typing-warnings/coercions.ml.principal.reference new file mode 100644 index 000000000..d5397bf05 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.principal.reference @@ -0,0 +1,15 @@ + +# Characters 76-79: + fun b -> if b then format_of_string "x" else "y";; + ^^^ +Warning 18: this coercion to format6 is not principal. +- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type + ('a, 'b, 'c, 'd, 'd, 'a) format6 = + ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/testsuite/tests/typing-warnings/coercions.ml.reference b/testsuite/tests/typing-warnings/coercions.ml.reference new file mode 100644 index 000000000..f44213051 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.reference @@ -0,0 +1,11 @@ + +# - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type + ('a, 'b, 'c, 'd, 'd, 'a) format6 = + ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# |