diff options
| -rw-r--r-- | Changes | 1 | ||||
| -rw-r--r-- | testsuite/tests/typing-modules/Test.ml | 4 | ||||
| -rw-r--r-- | testsuite/tests/typing-modules/Test.ml.principal.reference | 1 | ||||
| -rw-r--r-- | testsuite/tests/typing-modules/Test.ml.reference | 1 | ||||
| -rw-r--r-- | typing/typemod.ml | 20 |
5 files changed, 22 insertions, 5 deletions
@@ -104,6 +104,7 @@ Bug fixes: - PR#5806: ensure that backtrace tests are always run (testsuite) - PR#5810: error in switch printing when using -dclambda - PR#5813: GC not called when unmarshaling repeatedly in a tight loop (ocamlopt) +- PR#5815: Multiple exceptions in signatures gives an error - PR#5819: segfault when using [with] on large recursive record (ocamlopt) - PR#5821: Wrong record field is reported as duplicate - PR#5824: Generate more efficient code for immediate right shifts. diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index bcdfa81ac..e5cbe9f39 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -50,3 +50,7 @@ module M : sig type -'a t = private int end = module type A = sig type t = X of int end;; type u = X of bool;; module type B = A with type t = u;; (* fail *) + +(* PR#5815 *) + +module type S = sig exception Foo of int exception Foo of bool end;; diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index eebe307ed..8e993fa3a 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -28,4 +28,5 @@ 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 # diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index eebe307ed..8e993fa3a 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -28,4 +28,5 @@ 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 # diff --git a/typing/typemod.ml b/typing/typemod.ml index 47c3d80c2..475cb9b48 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -378,17 +378,25 @@ let check_sig_item type_names module_names modtype_names loc = function check "module type" loc modtype_names (Ident.name id) | _ -> () -let rec remove_values ids = function +let rec remove_duplicates val_ids exn_ids = function [] -> [] | Sig_value (id, _) :: rem - when List.exists (Ident.equal id) ids -> remove_values ids rem - | f :: rem -> f :: remove_values ids rem + when List.exists (Ident.equal id) val_ids -> remove_duplicates val_ids exn_ids rem + | Sig_exception(id, _) :: rem + when List.exists (Ident.equal id) exn_ids -> remove_duplicates val_ids exn_ids rem + | f :: rem -> f :: remove_duplicates val_ids exn_ids rem let rec get_values = function [] -> [] | Sig_value (id, _) :: rem -> id :: get_values rem | f :: rem -> get_values rem +let rec get_exceptions = function + [] -> [] + | Sig_exception (id, _) :: rem -> id :: get_exceptions rem + | f :: rem -> get_exceptions rem + + (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = @@ -483,7 +491,8 @@ and transl_signature env sg = let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception (id, name, arg)) env loc :: trem, - Sig_exception(id, arg.exn_exn) :: rem, + (if List.exists (Ident.equal id) (get_exceptions rem) then rem + else Sig_exception(id, arg.exn_exn) :: rem), final_env | Psig_module(name, smty) -> check "module" item.psig_loc module_names name.txt; @@ -531,7 +540,8 @@ and transl_signature env sg = let newenv = Env.add_signature sg env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_include (tmty, sg)) env loc :: trem, - remove_values (get_values rem) sg @ rem, final_env + remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem, + final_env | Psig_class cl -> List.iter (fun {pci_name = name} -> |