Direct implementation of the approximation of free identifiers + get rid of Unused_var module.

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

4 files changed, 110 insertions, 326 deletions

diff --git a/.depend b/.depend
index e6c68ebc02..cbd911ff81 100644
--- a/.depend
+++ b/.depend
@@ -108,7 +108,6 @@ typing/types.cmi: typing/primitive.cmi typing/path.cmi parsing/longident.cmi \
     parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi
 typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi
-typing/unused_var.cmi: parsing/parsetree.cmi
 typing/btype.cmo: typing/types.cmi typing/path.cmi utils/misc.cmi \
     typing/btype.cmi
 typing/btype.cmx: typing/types.cmx typing/path.cmx utils/misc.cmx \
@@ -223,23 +222,21 @@ typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi typing/typeclass.cmi
-typing/typecore.cmo: utils/warnings.cmi typing/unused_var.cmi \
-    typing/typetexp.cmi typing/types.cmi typing/typedtree.cmi \
-    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
-    parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
-    utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
+typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
+    typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \
+    typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
+    typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
+    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
     typing/typecore.cmi
-typing/typecore.cmx: utils/warnings.cmx typing/unused_var.cmx \
-    typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \
-    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
-    parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
-    utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
+typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
+    typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
+    typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
+    typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
+    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
     typing/typecore.cmi
 typing/typedecl.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
@@ -293,12 +290,6 @@ typing/typetexp.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
     parsing/longident.cmx parsing/location.cmx typing/env.cmx \
     typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/typetexp.cmi
-typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
-    typing/unused_var.cmi
-typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \
-    parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
-    typing/unused_var.cmi
 bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi
 bytecomp/bytelibrarian.cmi:
 bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 9a7a1d849e..b141d4ed65 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -101,6 +101,100 @@ let rp node =
   node
 ;;
 
+(* Upper approximation of free identifiers on the parse tree *)
+
+let iter_expression f e =
+
+  let rec expr e =
+    f e;
+    match e.pexp_desc with
+    | Pexp_ident _
+    | Pexp_assertfalse
+    | Pexp_new _
+    | Pexp_constant _ -> ()
+    | Pexp_function (_, eo, pel) -> may expr eo; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
+    | Pexp_let (_, pel, e)
+    | Pexp_match (e, pel)
+    | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_array el
+    | Pexp_tuple el -> List.iter expr el
+    | Pexp_construct (_, eo, _)
+    | Pexp_variant (_, eo) -> may expr eo
+    | Pexp_record (iel, eo) -> may expr eo; List.iter (fun (_, e) -> expr e) iel
+    | Pexp_open (_, e)
+    | Pexp_newtype (_, e)
+    | Pexp_poly (e, _)
+    | Pexp_lazy e
+    | Pexp_assert e
+    | Pexp_setinstvar (_, e)
+    | Pexp_send (e, _)
+    | Pexp_constraint (e, _, _)
+    | Pexp_field (e, _) -> expr e
+    | Pexp_when (e1, e2)
+    | Pexp_while (e1, e2)
+    | Pexp_sequence (e1, e2)
+    | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
+    | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
+    | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
+    | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
+    | Pexp_letmodule (_, me, e) -> expr e; module_expr me
+    | Pexp_object (_, cs) -> List.iter class_field cs
+    | Pexp_pack me -> module_expr me
+
+  and module_expr me =
+    match me.pmod_desc with
+    | Pmod_ident _ -> ()
+    | Pmod_structure str -> List.iter structure_item str
+    | Pmod_constraint (me, _)
+    | Pmod_functor (_, _, me) -> module_expr me
+    | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
+    | Pmod_unpack e -> expr e
+
+  and structure_item str =
+    match str.pstr_desc with
+    | Pstr_eval e -> expr e
+    | Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
+    | Pstr_primitive _
+    | Pstr_type _
+    | Pstr_exception _
+    | Pstr_modtype _
+    | Pstr_open _
+    | Pstr_class_type _
+    | Pstr_exn_rebind _ -> ()
+    | Pstr_include me
+    | Pstr_module (_, me) -> module_expr me
+    | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
+    | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
+
+  and class_expr ce =
+    match ce.pcl_desc with
+    | Pcl_constr _ -> ()
+    | Pcl_structure (_, cfl) -> List.iter class_field cfl
+    | Pcl_fun (_, eo, _,  ce) -> may expr eo; class_expr ce
+    | Pcl_apply (ce, lel) -> class_expr ce; List.iter (fun (_, e) -> expr e) lel
+    | Pcl_let (_, pel, ce) -> List.iter (fun (_, e) -> expr e) pel; class_expr ce
+    | Pcl_constraint (ce, _) -> class_expr ce
+
+  and class_field = function
+    | Pcf_inher (_, ce, _) -> class_expr ce
+    | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
+    | Pcf_val (_,_,_, e, _) | Pcf_meth (_,_,_, e, _) -> expr e
+    | Pcf_init e -> expr e
+
+  in
+  expr e
+
+
+let free_idents el =
+  let idents = Hashtbl.create 8 in
+  let f = function
+    | {pexp_desc=Pexp_ident (Longident.Lident id); _} -> Hashtbl.replace idents id ()
+    | _ -> ()
+  in
+  List.iter (iter_expression f) el;
+  Hashtbl.fold (fun x () rest -> x :: rest) idents []
+
 
 (* Typing of constants *)
 
@@ -1273,11 +1367,11 @@ let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
 
 (* Duplicate types of values in the environment *)
 (* XXX Should we do something about global type variables too? *)
+
 let duplicate_ident_types loc caselist env =
   let caselist =
     List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
-  let idents = Unused_var.free_idents
-      {pexp_desc = Pexp_match(dummy_expr,caselist); pexp_loc = loc} in
+  let idents = free_idents (List.map snd caselist) in
   List.fold_left
     (fun env s ->
       try
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
deleted file mode 100644
index 3a6eeaeb50..0000000000
--- a/typing/unused_var.ml
+++ /dev/null
@@ -1,285 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 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.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Parsetree
-
-(* TODO: simpler implementation for free_idents *)
-
-let silent v = String.length v > 0 && v.[0] = '_';;
-
-let add_vars tbl (vll1, vll2) =
-  let add_var (v, _loc, used) = Hashtbl.add tbl v used in
-  List.iter add_var vll1;
-  List.iter add_var vll2;
-;;
-
-let rm_vars tbl (vll1, vll2) =
-  let rm_var (v, _, _) = Hashtbl.remove tbl v in
-  List.iter rm_var vll1;
-  List.iter rm_var vll2;
-;;
-
-let w_suspicious x = Warnings.Unused_var x;;
-let w_strict x = Warnings.Unused_var_strict x;;
-
-type ppf_or_idents = Ppf of Format.formatter | Free of string list ref
-
-let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
-  let check_rm_var kind (v, loc, used) =
-    begin match ppf with
-      Ppf ppf when not !used && not (silent v) ->
-        Location.print_warning loc ppf (kind v)
-    | _ -> ()
-    end;
-    Hashtbl.remove tbl v;
-  in
-  List.iter (check_rm_var w_strict) vlul_pat;
-  List.iter (check_rm_var w_suspicious) vlul_as;
-;;
-
-let check_rm_let ppf tbl vlulpl =
-  let check_rm_one flag (v, loc, used) =
-    Hashtbl.remove tbl v;
-    flag && (silent v || not !used)
-  in
-  let warn_var w_kind (v, loc, used) =
-    match ppf with
-      Ppf ppf when not (silent v) && not !used ->
-        Location.print_warning loc ppf (w_kind v)
-    | _ -> ()
-  in
-  let check_rm_pat (def, def_as) =
-    let def_unused = List.fold_left check_rm_one true def in
-    let all_unused = List.fold_left check_rm_one def_unused def_as in
-    List.iter (warn_var (if all_unused then w_suspicious else w_strict)) def;
-    List.iter (warn_var w_suspicious) def_as;
-  in
-  List.iter check_rm_pat vlulpl;
-;;
-
-let add_free_ident ppf s =
-  match ppf with
-    Free r ->
-      if List.mem s !r then () else
-      r := s :: !r
-  | _ -> ()
-;;
-
-let rec get_vars ((vacc, asacc) as acc) p =
-  match p.ppat_desc with
-  | Ppat_any -> acc
-  | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
-  | Ppat_alias (pp, v) ->
-      get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
-  | Ppat_constant _ -> acc
-  | Ppat_tuple pl -> List.fold_left get_vars acc pl
-  | Ppat_construct (_, po, _) -> get_vars_option acc po
-  | Ppat_variant (_, po) -> get_vars_option acc po
-  | Ppat_record (ipl, cls) ->
-      List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
-  | Ppat_array pl -> List.fold_left get_vars acc pl
-  | Ppat_or (p1, _p2) -> get_vars acc p1
-  | Ppat_lazy p -> get_vars acc p
-  | Ppat_constraint (pp, _) -> get_vars acc pp
-  | Ppat_type _ -> acc
-  | Ppat_unpack _ -> acc
-
-and get_vars_option acc po =
-  match po with
-  | Some p -> get_vars acc p
-  | None -> acc
-;;
-
-let get_pel_vars pel =
-  List.map (fun (p, _) -> get_vars ([], []) p) pel
-;;
-
-let rec structure ppf tbl l =
-  List.iter (structure_item ppf tbl) l
-
-and structure_item ppf tbl s =
-  match s.pstr_desc with
-  | Pstr_eval e -> expression ppf tbl e;
-  | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
-  | Pstr_primitive _ -> ()
-  | Pstr_type _ -> ()
-  | Pstr_exception _ -> ()
-  | Pstr_exn_rebind _ -> ()
-  | Pstr_module (_, me) -> module_expr ppf tbl me;
-  | Pstr_recmodule stml ->
-      List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
-  | Pstr_modtype _ -> ()
-  | Pstr_open _ -> ()
-  | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
-  | Pstr_class_type _ -> ()
-  | Pstr_include me -> module_expr ppf tbl me;
-
-and expression ppf tbl e =
-  match e.pexp_desc with
-  | Pexp_ident (Longident.Lident id) ->
-      begin try (Hashtbl.find tbl id) := true;
-      with Not_found -> add_free_ident ppf id
-      end;
-  | Pexp_ident _ -> ()
-  | Pexp_constant _ -> ()
-  | Pexp_let (recflag, pel, e) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
-  | Pexp_function (_, eo, pel) ->
-      expression_option ppf tbl eo;
-      match_pel ppf tbl pel;
-  | Pexp_apply (e, lel) ->
-      expression ppf tbl e;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pexp_match (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_try (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_tuple el -> List.iter (expression ppf tbl) el;
-  | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
-  | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
-  | Pexp_record (iel, eo) ->
-      List.iter (fun (_, e) -> expression ppf tbl e) iel;
-      expression_option ppf tbl eo;
-  | Pexp_field (e, _) ->
-      expression ppf tbl e;
-  | Pexp_setfield (e1, _, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_array el -> List.iter (expression ppf tbl) el;
-  | Pexp_ifthenelse (e1, e2, eo) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      expression_option ppf tbl eo;
-  | Pexp_sequence (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_while (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_for (id, e1, e2, _, e3) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      let defined = ([ (id, e.pexp_loc, ref true) ], []) in
-      add_vars tbl defined;
-      expression ppf tbl e3;
-      check_rm_vars ppf tbl defined;
-  | Pexp_constraint (e, _, _) -> expression ppf tbl e;
-  | Pexp_when (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_send (e, _) -> expression ppf tbl e;
-  | Pexp_new _ -> ()
-  | Pexp_setinstvar (f, e) ->
-      add_free_ident ppf f;
-      expression ppf tbl e;
-  | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
-  | Pexp_letmodule (_, me, e) ->
-      module_expr ppf tbl me;
-      expression ppf tbl e;
-  | Pexp_assert e -> expression ppf tbl e;
-  | Pexp_assertfalse -> ()
-  | Pexp_lazy e -> expression ppf tbl e;
-  | Pexp_poly (e, _) -> expression ppf tbl e;
-  | Pexp_object cs -> class_structure ppf tbl cs;
-  | Pexp_newtype (_, e) -> expression ppf tbl e
-  | Pexp_pack me -> module_expr ppf tbl me
-  | Pexp_open (_, e) -> expression ppf tbl e
-
-and expression_option ppf tbl eo =
-  match eo with
-  | Some e -> expression ppf tbl e;
-  | None -> ()
-
-and let_pel ppf tbl recflag pel body =
-  match recflag with
-  | Asttypes.Recursive ->
-      let defined = get_pel_vars pel in
-      List.iter (add_vars tbl) defined;
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None ->
-          List.iter (rm_vars tbl) defined;
-      | Some f ->
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-  | _ ->
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None -> ()
-      | Some f ->
-          let defined = get_pel_vars pel in
-          List.iter (add_vars tbl) defined;
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-
-and match_pel ppf tbl pel =
-  List.iter (match_pe ppf tbl) pel
-
-and match_pe ppf tbl (p, e) =
- let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  expression ppf tbl e;
-  check_rm_vars ppf tbl defined;
-
-and module_expr ppf tbl me =
-  match me.pmod_desc with
-  | Pmod_ident _ -> ()
-  | Pmod_structure s -> structure ppf tbl s
-  | Pmod_functor (_, _, me) -> module_expr ppf tbl me
-  | Pmod_apply (me1, me2) ->
-      module_expr ppf tbl me1;
-      module_expr ppf tbl me2;
-  | Pmod_constraint (me, _) -> module_expr ppf tbl me
-  | Pmod_unpack (e) -> expression ppf tbl e
-
-and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
-
-and class_expr ppf tbl ce =
-  match ce.pcl_desc with
-  | Pcl_constr _ -> ()
-  | Pcl_structure cs -> class_structure ppf tbl cs;
-  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
-  | Pcl_apply (ce, lel) ->
-      class_expr ppf tbl ce;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pcl_let (recflag, pel, ce) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
-  | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
-
-and class_structure ppf tbl (p, cfl) =
-  let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  List.iter (class_field ppf tbl) cfl;
-  check_rm_vars ppf tbl defined;
-
-and class_field ppf tbl cf =
-  match cf with
-  | Pcf_inher (_, ce, _) -> class_expr ppf tbl ce;
-  | Pcf_val (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_virt _ | Pcf_valvirt _ -> ()
-  | Pcf_meth (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_cstr _ -> ()
-  | Pcf_init e -> expression ppf tbl e;
-;;
-
-let free_idents e =
-  let tbl = Hashtbl.create 7 in
-  let idents = ref [] in
-  expression (Free idents) tbl e;
-  !idents
-;;
diff --git a/typing/unused_var.mli b/typing/unused_var.mli
deleted file mode 100644
index 957fac5d9e..0000000000
--- a/typing/unused_var.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 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.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val free_idents : Parsetree.expression -> string list
-(* Conservatively approximate the free variables of an expression. *)