diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index a464590e4..f0b223747 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2037,7 +2037,7 @@ let combine_constructor arg ex_pat cstr partial ctx def List.fold_right (fun (ex, act) rem -> match ex with - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lifthenelse(Lprim(Pintcomp Ceq, [Lprim(Pfield 0, [arg]); transl_path path]), act, rem) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 906031ce1..77468a58f 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -668,7 +668,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) end | Texp_variant(l, arg) -> diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend index 5e3e2a2b8..4a0040b3b 100644 --- a/otherlibs/labltk/browser/.depend +++ b/otherlibs/labltk/browser/.depend @@ -1,97 +1,101 @@ -editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ +editor.cmo : viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ fileselect.cmi editor.cmi -editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ +editor.cmx : viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ fileselect.cmx editor.cmi -fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ - jg_entry.cmo jg_box.cmo fileselect.cmi -fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ - jg_entry.cmx jg_box.cmx fileselect.cmi -help.cmo: -help.cmx: -jg_bind.cmo: jg_bind.cmi -jg_bind.cmx: jg_bind.cmi -jg_box.cmo: jg_completion.cmi jg_bind.cmi -jg_box.cmx: jg_completion.cmx jg_bind.cmx -jg_button.cmo: -jg_button.cmx: -jg_completion.cmo: jg_completion.cmi -jg_completion.cmx: jg_completion.cmi -jg_config.cmo: jg_tk.cmo jg_config.cmi -jg_config.cmx: jg_tk.cmx jg_config.cmi -jg_entry.cmo: jg_bind.cmi -jg_entry.cmx: jg_bind.cmx -jg_memo.cmo: jg_memo.cmi -jg_memo.cmx: jg_memo.cmi -jg_menu.cmo: -jg_menu.cmx: -jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ +fileselect.cmo : useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo \ + jg_memo.cmi jg_entry.cmo jg_box.cmo fileselect.cmi +fileselect.cmx : useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx \ + jg_memo.cmx jg_entry.cmx jg_box.cmx fileselect.cmi +help.cmo : +help.cmx : +jg_bind.cmo : jg_bind.cmi +jg_bind.cmx : jg_bind.cmi +jg_box.cmo : jg_completion.cmi jg_bind.cmi +jg_box.cmx : jg_completion.cmx jg_bind.cmx +jg_button.cmo : +jg_button.cmx : +jg_completion.cmo : jg_completion.cmi +jg_completion.cmx : jg_completion.cmi +jg_config.cmo : jg_tk.cmo jg_config.cmi +jg_config.cmx : jg_tk.cmx jg_config.cmi +jg_entry.cmo : jg_bind.cmi +jg_entry.cmx : jg_bind.cmx +jg_memo.cmo : jg_memo.cmi +jg_memo.cmx : jg_memo.cmi +jg_menu.cmo : +jg_menu.cmx : +jg_message.cmo : jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ jg_message.cmi -jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ +jg_message.cmx : jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ jg_message.cmi -jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi -jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi -jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi -jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi -jg_tk.cmo: -jg_tk.cmx: -jg_toplevel.cmo: -jg_toplevel.cmx: -lexical.cmo: jg_tk.cmo lexical.cmi -lexical.cmx: jg_tk.cmx lexical.cmi -list2.cmo: -list2.cmx: -main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ +jg_multibox.cmo : jg_completion.cmi jg_bind.cmi jg_multibox.cmi +jg_multibox.cmx : jg_completion.cmx jg_bind.cmx jg_multibox.cmi +jg_text.cmo : jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi \ + jg_text.cmi +jg_text.cmx : jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx \ + jg_text.cmi +jg_tk.cmo : +jg_tk.cmx : +jg_toplevel.cmo : +jg_toplevel.cmx : +lexical.cmo : jg_tk.cmo lexical.cmi +lexical.cmx : jg_tk.cmx lexical.cmi +list2.cmo : +list2.cmx : +main.cmo : viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ editor.cmi -main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ +main.cmx : viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ editor.cmx -searchid.cmo: list2.cmo searchid.cmi -searchid.cmx: list2.cmx searchid.cmi -searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ - jg_memo.cmi jg_bind.cmi searchpos.cmi -searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ - jg_memo.cmx jg_bind.cmx searchpos.cmi -setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ +searchid.cmo : list2.cmo searchid.cmi +searchid.cmx : list2.cmx searchid.cmi +searchpos.cmo : searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi \ + jg_message.cmi jg_memo.cmi jg_bind.cmi searchpos.cmi +searchpos.cmx : searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx \ + jg_message.cmx jg_memo.cmx jg_bind.cmx searchpos.cmi +setpath.cmo : useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ jg_bind.cmi setpath.cmi -setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ +setpath.cmx : useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ jg_bind.cmx setpath.cmi -shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ +shell.cmo : list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi -shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ +shell.cmx : list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi -typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi -typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi -useunix.cmo: useunix.cmi -useunix.cmx: useunix.cmi -viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ +typecheck.cmo : mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ + typecheck.cmi +typecheck.cmx : mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx \ + typecheck.cmi +useunix.cmo : useunix.cmi +useunix.cmx : useunix.cmi +viewer.cmo : useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ jg_box.cmo jg_bind.cmi help.cmo viewer.cmi -viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ +viewer.cmx : useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ jg_box.cmx jg_bind.cmx help.cmx viewer.cmi -dummy.cmi: -dummyUnix.cmi: -dummyWin.cmi: -editor.cmi: -fileselect.cmi: -jg_bind.cmi: -jg_completion.cmi: -jg_config.cmi: -jg_memo.cmi: -jg_message.cmi: -jg_multibox.cmi: -jg_text.cmi: -lexical.cmi: -mytypes.cmi: shell.cmi -searchid.cmi: -searchpos.cmi: -setpath.cmi: -shell.cmi: -typecheck.cmi: mytypes.cmi -useunix.cmi: -viewer.cmi: +dummy.cmi : +dummyUnix.cmi : +dummyWin.cmi : +editor.cmi : +fileselect.cmi : +jg_bind.cmi : +jg_completion.cmi : +jg_config.cmi : +jg_memo.cmi : +jg_message.cmi : +jg_multibox.cmi : +jg_text.cmi : +lexical.cmi : +mytypes.cmi : shell.cmi +searchid.cmi : +searchpos.cmi : +setpath.cmi : +shell.cmi : +typecheck.cmi : mytypes.cmi +useunix.cmi : +viewer.cmi : diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 9d4311c85..2bf72f19c 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -354,7 +354,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct let cstr = Env.lookup_constructor lid env in let path = match cstr.cstr_tag with - Cstr_exception p -> p | _ -> raise Not_found in + Cstr_exception (p, _) -> p | _ -> raise Not_found in (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 637c4cd83..bc05d2a84 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -91,7 +91,7 @@ let exception_descr path_exc decl = cstr_existentials = []; cstr_args = decl.exn_args; cstr_arity = List.length decl.exn_args; - cstr_tag = Cstr_exception path_exc; + cstr_tag = Cstr_exception (path_exc, decl.exn_loc); cstr_consts = -1; cstr_nonconsts = -1; cstr_private = Public; diff --git a/typing/env.ml b/typing/env.ml index ce30ef418..f4dbcf516 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -161,7 +161,7 @@ let is_ident = function let is_local (p, _) = is_ident p let is_local_exn = function - {cstr_tag = Cstr_exception p} -> is_ident p + {cstr_tag = Cstr_exception (p, _)} -> is_ident p | _ -> false let diff env1 env2 = @@ -515,6 +515,10 @@ let mark_constructor_used name vd constr = try Hashtbl.find used_constructors (name, vd.type_loc, constr) () with Not_found -> () +let mark_exception_used ed constr = + try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) () + with Not_found -> () + let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in try @@ -555,10 +559,17 @@ let lookup_constructor lid env = desc let mark_constructor env name desc = - let ty_path = ty_path desc.cstr_res in - let ty_decl = try find_type ty_path env with Not_found -> assert false in - let ty_name = Path.last ty_path in - mark_constructor_used ty_name ty_decl name + match desc.cstr_tag with + | Cstr_exception (_, loc) -> + begin + try Hashtbl.find used_constructors ("exn", loc, name) () + with Not_found -> () + end + | _ -> + let ty_path = ty_path desc.cstr_res in + let ty_decl = try find_type ty_path env with Not_found -> assert false in + let ty_name = Path.last ty_path in + mark_constructor_used ty_name ty_decl name let lookup_label lid env = let desc = lookup_label lid env in @@ -877,7 +888,21 @@ and store_type_infos id path info env = summary = Env_type(env.summary, id, info) } and store_exception id path decl env = - + let loc = decl.exn_loc in + if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception "") then begin + let ty = "exn" in + let c = Ident.name id in + let k = (ty, loc, c) in + if not (Hashtbl.mem used_constructors k) then begin + let used = ref false in + Hashtbl.add used_constructors k (fun () -> used := true); + !add_delayed_check_forward + (fun () -> + if not !used then + Location.prerr_warning loc (Warnings.Unused_exception c) + ) + end; + end; { env with constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs; summary = Env_exception(env.summary, id, decl) } diff --git a/typing/env.mli b/typing/env.mli index 9323047c3..9befc7df7 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -156,6 +156,7 @@ val mark_value_used: string -> value_description -> unit val mark_type_used: string -> type_declaration -> unit val mark_constructor_used: string -> type_declaration -> string -> unit val mark_constructor: t -> string -> constructor_description -> unit +val mark_exception_used: exception_declaration -> string -> unit val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit diff --git a/typing/includecore.ml b/typing/includecore.ml index 0c5c757e1..23c715f4d 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -253,7 +253,6 @@ let type_declarations env id decl1 decl2 = (* Inclusion between exception declarations *) let exception_declarations env ed1 ed2 = - (* TODO: mark ed1 as being used *) Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1.exn_args ed2.exn_args (* Inclusion between class types *) diff --git a/typing/includemod.ml b/typing/includemod.ml index d9465ddb2..4cc290408 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -69,6 +69,7 @@ let type_declarations env cxt subst id decl1 decl2 = (* Inclusion between exception declarations *) let exception_declarations env cxt subst id decl1 decl2 = + Env.mark_exception_used decl1 (Ident.name id); let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 015d1d608..99bb5afe9 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -153,7 +153,7 @@ open Format ;; let get_constr_name tag ty tenv = match tag with -| Cstr_exception path -> Path.name path +| Cstr_exception (path, _) -> Path.name path | _ -> try let name,_,_ = get_constr tag ty tenv in name @@ -777,7 +777,7 @@ let build_other ext env = match env with (Tpat_construct ({c with cstr_tag=(Cstr_exception - (Path.Pident (Ident.create "*exception*")))}, + (Path.Pident (Ident.create "*exception*"), Location.none))}, [])) Ctype.none Env.empty | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 9d9ce4265..3f483c8df 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -842,8 +842,10 @@ let transl_exn_rebind env loc lid = Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in + Env.mark_constructor env (Longident.last lid) cdescr; match cdescr.cstr_tag with - Cstr_exception path -> (path, {exn_args = cdescr.cstr_args; exn_loc = loc}) + Cstr_exception (path, _) -> + (path, {exn_args = cdescr.cstr_args; exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception lid)) (* Translate a value declaration *) diff --git a/typing/types.ml b/typing/types.ml index e473cb49a..982dd76ab 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -121,7 +121,7 @@ type constructor_description = and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t (* Exception constructor *) + | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) diff --git a/typing/types.mli b/typing/types.mli index 1fe1fa481..cf897bd7a 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -118,7 +118,7 @@ type constructor_description = and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t (* Exception constructor *) + | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) diff --git a/utils/warnings.ml b/utils/warnings.ml index 22960cdb1..e6ea56e9a 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -57,6 +57,7 @@ type t = | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string (* 37 *) + | Unused_exception of string (* 38 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -103,9 +104,10 @@ let number = function | Unused_for_index _ -> 35 | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 + | Unused_exception _ -> 38 ;; -let last_warning_number = 37;; +let last_warning_number = 38;; (* Must be the max number returned by the [number] function. *) let letter = function @@ -121,7 +123,7 @@ let letter = function | 'h' -> [] | 'i' -> [] | 'j' -> [] - | 'k' -> [32; 33; 34; 35; 36; 37] + | 'k' -> [32; 33; 34; 35; 36; 37; 38] | 'l' -> [6] | 'm' -> [7] | 'n' -> [] @@ -200,7 +202,7 @@ let parse_opt flags s = let parse_options errflag s = parse_opt (if errflag then error else active) s;; (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-32..37";; +let defaults_w = "+a-4-6-7-9-27-29-32..38";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -284,6 +286,7 @@ let message = function | Unused_for_index s -> "unused for-loop index " ^ s ^ "." | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "." | Unused_constructor s -> "unused constructor " ^ s ^ "." + | Unused_exception s -> "unused exception constructor " ^ s ^ "." ;; let nerrors = ref 0;; @@ -367,6 +370,7 @@ let descriptions = 35, "Unused for-loop index."; 36, "Unused ancestor variable."; 37, "Unused constructor."; + 38, "Unused exception constructor."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 99c153ffd..6cb7ce561 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -52,6 +52,7 @@ type t = | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string (* 37 *) + | Unused_exception of string (* 38 *) ;; val parse_options : bool -> string -> unit;;