l4/pkg/ocaml/contrib/typing/unused_var.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
   6 (*                                                                     *)
   7 (*  Copyright 2004 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: unused_var.ml 8906 2008-07-09 13:03:38Z mauny $ *)
  14
  15 open Parsetree
  16
  17 let silent v = String.length v > 0 && v.[0] = '_';;
  18
  19 let add_vars tbl (vll1, vll2) =
  20   let add_var (v, _loc, used) = Hashtbl.add tbl v used in
  21   List.iter add_var vll1;
  22   List.iter add_var vll2;
  23 ;;
  24
  25 let rm_vars tbl (vll1, vll2) =
  26   let rm_var (v, _, _) = Hashtbl.remove tbl v in
  27   List.iter rm_var vll1;
  28   List.iter rm_var vll2;
  29 ;;
  30
  31 let w_suspicious x = Warnings.Unused_var x;;
  32 let w_strict x = Warnings.Unused_var_strict x;;
  33
  34 let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
  35   let check_rm_var kind (v, loc, used) =
  36     if not !used && not (silent v)
  37     then Location.print_warning loc ppf (kind v);
  38     Hashtbl.remove tbl v;
  39   in
  40   List.iter (check_rm_var w_strict) vlul_pat;
  41   List.iter (check_rm_var w_suspicious) vlul_as;
  42 ;;
  43
  44 let check_rm_let ppf tbl vlulpl =
  45   let check_rm_one flag (v, loc, used) =
  46     Hashtbl.remove tbl v;
  47     flag && (silent v || not !used)
  48   in
  49   let warn_var w_kind (v, loc, used) =
  50     if not (silent v) && not !used
  51     then Location.print_warning loc ppf (w_kind v)
  52   in
  53   let check_rm_pat (def, def_as) =
  54     let def_unused = List.fold_left check_rm_one true def in
  55     let all_unused = List.fold_left check_rm_one def_unused def_as in
  56     List.iter (warn_var (if all_unused then w_suspicious else w_strict)) def;
  57     List.iter (warn_var w_suspicious) def_as;
  58   in
  59   List.iter check_rm_pat vlulpl;
  60 ;;
  61
  62 let rec get_vars ((vacc, asacc) as acc) p =
  63   match p.ppat_desc with
  64   | Ppat_any -> acc
  65   | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
  66   | Ppat_alias (pp, v) ->
  67       get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
  68   | Ppat_constant _ -> acc
  69   | Ppat_tuple pl -> List.fold_left get_vars acc pl
  70   | Ppat_construct (_, po, _) -> get_vars_option acc po
  71   | Ppat_variant (_, po) -> get_vars_option acc po
  72   | Ppat_record ipl ->
  73       List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
  74   | Ppat_array pl -> List.fold_left get_vars acc pl
  75   | Ppat_or (p1, _p2) -> get_vars acc p1
  76   | Ppat_lazy p -> get_vars acc p
  77   | Ppat_constraint (pp, _) -> get_vars acc pp
  78   | Ppat_type _ -> acc
  79
  80 and get_vars_option acc po =
  81   match po with
  82   | Some p -> get_vars acc p
  83   | None -> acc
  84 ;;
  85
  86 let get_pel_vars pel =
  87   List.map (fun (p, _) -> get_vars ([], []) p) pel
  88 ;;
  89
  90 let rec structure ppf tbl l =
  91   List.iter (structure_item ppf tbl) l
  92
  93 and structure_item ppf tbl s =
  94   match s.pstr_desc with
  95   | Pstr_eval e -> expression ppf tbl e;
  96   | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
  97   | Pstr_primitive _ -> ()
  98   | Pstr_type _ -> ()
  99   | Pstr_exception _ -> ()
 100   | Pstr_exn_rebind _ -> ()
 101   | Pstr_module (_, me) -> module_expr ppf tbl me;
 102   | Pstr_recmodule stml ->
 103       List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
 104   | Pstr_modtype _ -> ()
 105   | Pstr_open _ -> ()
 106   | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
 107   | Pstr_class_type _ -> ()
 108   | Pstr_include _ -> ()
 109
 110 and expression ppf tbl e =
 111   match e.pexp_desc with
 112   | Pexp_ident (Longident.Lident id) ->
 113       begin try (Hashtbl.find tbl id) := true;
 114       with Not_found -> ()
 115       end;
 116   | Pexp_ident _ -> ()
 117   | Pexp_constant _ -> ()
 118   | Pexp_let (recflag, pel, e) ->
 119       let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
 120   | Pexp_function (_, eo, pel) ->
 121       expression_option ppf tbl eo;
 122       match_pel ppf tbl pel;
 123   | Pexp_apply (e, lel) ->
 124       expression ppf tbl e;
 125       List.iter (fun (_, e) -> expression ppf tbl e) lel;
 126   | Pexp_match (e, pel) ->
 127       expression ppf tbl e;
 128       match_pel ppf tbl pel;
 129   | Pexp_try (e, pel) ->
 130       expression ppf tbl e;
 131       match_pel ppf tbl pel;
 132   | Pexp_tuple el -> List.iter (expression ppf tbl) el;
 133   | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
 134   | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
 135   | Pexp_record (iel, eo) ->
 136       List.iter (fun (_, e) -> expression ppf tbl e) iel;
 137       expression_option ppf tbl eo;
 138   | Pexp_field (e, _) -> expression ppf tbl e;
 139   | Pexp_setfield (e1, _, e2) ->
 140       expression ppf tbl e1;
 141       expression ppf tbl e2;
 142   | Pexp_array el -> List.iter (expression ppf tbl) el;
 143   | Pexp_ifthenelse (e1, e2, eo) ->
 144       expression ppf tbl e1;
 145       expression ppf tbl e2;
 146       expression_option ppf tbl eo;
 147   | Pexp_sequence (e1, e2) ->
 148       expression ppf tbl e1;
 149       expression ppf tbl e2;
 150   | Pexp_while (e1, e2) ->
 151       expression ppf tbl e1;
 152       expression ppf tbl e2;
 153   | Pexp_for (id, e1, e2, _, e3) ->
 154       expression ppf tbl e1;
 155       expression ppf tbl e2;
 156       let defined = ([ (id, e.pexp_loc, ref true) ], []) in
 157       add_vars tbl defined;
 158       expression ppf tbl e3;
 159       check_rm_vars ppf tbl defined;
 160   | Pexp_constraint (e, _, _) -> expression ppf tbl e;
 161   | Pexp_when (e1, e2) ->
 162       expression ppf tbl e1;
 163       expression ppf tbl e2;
 164   | Pexp_send (e, _) -> expression ppf tbl e;
 165   | Pexp_new _ -> ()
 166   | Pexp_setinstvar (_, e) -> expression ppf tbl e;
 167   | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
 168   | Pexp_letmodule (_, me, e) ->
 169       module_expr ppf tbl me;
 170       expression ppf tbl e;
 171   | Pexp_assert e -> expression ppf tbl e;
 172   | Pexp_assertfalse -> ()
 173   | Pexp_lazy e -> expression ppf tbl e;
 174   | Pexp_poly (e, _) -> expression ppf tbl e;
 175   | Pexp_object cs -> class_structure ppf tbl cs;
 176
 177 and expression_option ppf tbl eo =
 178   match eo with
 179   | Some e -> expression ppf tbl e;
 180   | None -> ()
 181
 182 and let_pel ppf tbl recflag pel body =
 183   match recflag with
 184   | Asttypes.Recursive ->
 185       let defined = get_pel_vars pel in
 186       List.iter (add_vars tbl) defined;
 187       List.iter (fun (_, e) -> expression ppf tbl e) pel;
 188       begin match body with
 189       | None ->
 190           List.iter (rm_vars tbl) defined;
 191       | Some f ->
 192           f ppf tbl;
 193           check_rm_let ppf tbl defined;
 194       end;
 195   | _ ->
 196       List.iter (fun (_, e) -> expression ppf tbl e) pel;
 197       begin match body with
 198       | None -> ()
 199       | Some f ->
 200           let defined = get_pel_vars pel in
 201           List.iter (add_vars tbl) defined;
 202           f ppf tbl;
 203           check_rm_let ppf tbl defined;
 204       end;
 205
 206 and match_pel ppf tbl pel =
 207   List.iter (match_pe ppf tbl) pel
 208
 209 and match_pe ppf tbl (p, e) =
 210  let defined = get_vars ([], []) p in
 211   add_vars tbl defined;
 212   expression ppf tbl e;
 213   check_rm_vars ppf tbl defined;
 214
 215 and module_expr ppf tbl me =
 216   match me.pmod_desc with
 217   | Pmod_ident _ -> ()
 218   | Pmod_structure s -> structure ppf tbl s
 219   | Pmod_functor (_, _, me) -> module_expr ppf tbl me
 220   | Pmod_apply (me1, me2) ->
 221       module_expr ppf tbl me1;
 222       module_expr ppf tbl me2;
 223   | Pmod_constraint (me, _) -> module_expr ppf tbl me
 224
 225 and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
 226
 227 and class_expr ppf tbl ce =
 228   match ce.pcl_desc with
 229   | Pcl_constr _ -> ()
 230   | Pcl_structure cs -> class_structure ppf tbl cs;
 231   | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
 232   | Pcl_apply (ce, lel) ->
 233       class_expr ppf tbl ce;
 234       List.iter (fun (_, e) -> expression ppf tbl e) lel;
 235   | Pcl_let (recflag, pel, ce) ->
 236       let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
 237   | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
 238
 239 and class_structure ppf tbl (p, cfl) =
 240   let defined = get_vars ([], []) p in
 241   add_vars tbl defined;
 242   List.iter (class_field ppf tbl) cfl;
 243   check_rm_vars ppf tbl defined;
 244
 245 and class_field ppf tbl cf =
 246   match cf with
 247   | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
 248   | Pcf_val (_, _, e, _) -> expression ppf tbl e;
 249   | Pcf_virt _ | Pcf_valvirt _ -> ()
 250   | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
 251   | Pcf_cstr _ -> ()
 252   | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
 253   | Pcf_init e -> expression ppf tbl e;
 254 ;;
 255
 256 let warn ppf ast =
 257   if Warnings.is_active (w_suspicious "") || Warnings.is_active (w_strict "")
 258   then begin
 259     let tbl = Hashtbl.create 97 in
 260     structure ppf tbl ast;
 261   end;
 262   ast
 263 ;;