Detect unused exception declarations (#5524).

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12195 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

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)

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) ->

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 :

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 *)

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;

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) }

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

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 *)

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 ()

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,_) :: _ ->

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 *)

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 *)
 

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 *)
 

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.";
   ]
 ;;
 

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;;