Keep attributes on value declarations in .cmi files (but clear all the location fields, except if -keep-locs is used, of course). Use this to report a warning when a value marked as [@@deprecated] is referenced (#5854)

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

16 files changed, 46 insertions, 7 deletions

diff --git a/Changes b/Changes
index dd3212e617..b7445c556b 100644
--- a/Changes
+++ b/Changes
@@ -14,6 +14,8 @@ Compilers:
 - PR#6182: better message for virtual objects and class types
   (Leo P. White, Stephen Dolan)
 - PR#5817: new flag to keep locations in cmi files
+- PR#5854: issue warning 3 when referring to a value marked with
+  the [@@deprecated] attribute
 
 Bug fixes:
 - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows)
diff --git a/boot/ocamlc b/boot/ocamlc
index 38bfdb395d..ff670166b4 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 463d9ca36d..d048187a71 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 2ea42538b4..69f789bdad 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 092eeba259..af38a8b270 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -531,6 +531,7 @@ let rec push_defaults loc bindings cases partial =
             ({exp with exp_type = pat.pat_type; exp_desc =
               Texp_ident (Path.Pident param, mknoloc (Longident.Lident name),
                           {val_type = pat.pat_type; val_kind = Val_reg;
+                           val_attributes = [];
                            Types.val_loc = Location.none;
                           })},
              cases, partial) }
diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared
index 83e04d7046..815ab3258b 100644
--- a/debugger/Makefile.shared
+++ b/debugger/Makefile.shared
@@ -30,6 +30,7 @@ OTHEROBJS=\
   ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \
   ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \
   ../parsing/location.cmo ../parsing/longident.cmo \
+  ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \
   ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
   ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
   ../typing/subst.cmo ../typing/predef.cmo \
diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index ffc387184e..a0004a1ed2 100644
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -153,6 +153,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \
 	$(OCAMLSRCDIR)/parsing/parser.cmo \
 	$(OCAMLSRCDIR)/parsing/lexer.cmo \
 	$(OCAMLSRCDIR)/parsing/parse.cmo \
+	$(OCAMLSRCDIR)/parsing/ast_mapper.cmo \
 	$(OCAMLSRCDIR)/typing/types.cmo \
 	$(OCAMLSRCDIR)/typing/path.cmo \
 	$(OCAMLSRCDIR)/typing/btype.cmo \
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 074d476be9..ab03704903 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -28,6 +28,8 @@ COMPILEROBJS=\
   ../../utils/terminfo.cmo ../../utils/warnings.cmo \
   ../../parsing/asttypes.cmi \
   ../../parsing/location.cmo ../../parsing/longident.cmo \
+  ../../parsing/ast_helper.cmo \
+  ../../parsing/ast_mapper.cmo \
   ../../typing/ident.cmo ../../typing/path.cmo \
   ../../typing/primitive.cmo ../../typing/types.cmo \
   ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index ec0fc3b646..76ed3c67e1 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -211,6 +211,7 @@ READ_CMT= \
           ../parsing/lexer.cmo \
           ../parsing/pprintast.cmo \
           ../parsing/ast_helper.cmo \
+          ../parsing/ast_mapper.cmo \
           ../typing/ident.cmo \
           ../typing/path.cmo \
           ../typing/types.cmo \
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 3d7dc2234e..de54658916 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -108,10 +108,9 @@ let nondep_supertype env mid mty =
       let rem' = nondep_sig env va rem in
       match item with
         Sig_value(id, d) ->
-          Sig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
-                          val_kind = d.val_kind;
-                          val_loc = d.val_loc;
-                        }) :: rem'
+          Sig_value(id,
+                    {d with val_type = Ctype.nondep_type env mid d.val_type})
+          :: rem'
       | Sig_type(id, d, rs) ->
           Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
           :: rem'
diff --git a/typing/subst.ml b/typing/subst.ml
index a159b77dd8..844a5b49dd 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -250,10 +250,18 @@ let class_type s cty =
   cleanup_types ();
   cty
 
+let remove_loc =
+  let open Ast_mapper in
+  {default_mapper with location = (fun _this _loc -> Location.none)}
+
 let value_description s descr =
   { val_type = type_expr s descr.val_type;
     val_kind = descr.val_kind;
     val_loc = loc s descr.val_loc;
+    val_attributes =
+      if s.for_saving && not !Clflags.keep_locs
+      then remove_loc.Ast_mapper.attributes remove_loc descr.val_attributes
+      else descr.val_attributes;
    }
 
 let exception_declaration s descr =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c60d24e93f..9106c2c33b 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -202,12 +202,15 @@ let rc node =
 let enter_met_env ?check loc lab kind ty val_env met_env par_env =
   let (id, val_env) =
     Env.enter_value lab {val_type = ty; val_kind = Val_unbound;
+                         val_attributes = [];
                          Types.val_loc = loc} val_env
   in
   (id, val_env,
    Env.add_value ?check id {val_type = ty; val_kind = kind;
+                            val_attributes = [];
                             Types.val_loc = loc} met_env,
    Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                     val_attributes = [];
                      Types.val_loc = loc} par_env)
 
 (* Enter an instance variable in the environment *)
@@ -1081,6 +1084,7 @@ and class_expr cl_num val_env met_env scl =
              let desc =
                {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
                                                                cl_num);
+                val_attributes = [];
                 Types.val_loc = vd.Types.val_loc;
                }
              in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d2dc188768..42b1da7c46 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1230,7 +1230,9 @@ let add_pattern_variables ?check ?check_as env =
      (fun (id, ty, name, loc, as_var) env ->
        let check = if as_var then check_as else check in
        Env.add_value ?check id
-         {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env
+         {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+          val_attributes = [];
+         } env
      )
      pv env,
    get_ref module_variables)
@@ -1272,6 +1274,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
          ((id', name, id, ty)::pv,
           Env.add_value id' {val_type = ty;
                              val_kind = Val_ivar (Immutable, cl_num);
+                             val_attributes = [];
                              Types.val_loc = loc;
                             } ~check
             env))
@@ -1299,16 +1302,19 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
       (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty;
                             val_kind = Val_unbound;
+                            val_attributes = [];
                             Types.val_loc = loc;
                            } val_env,
           Env.add_value id {val_type = ty;
                             val_kind = Val_self (meths, vars, cl_num, privty);
+                            val_attributes = [];
                             Types.val_loc = loc;
                            }
             ~check:(fun s -> if as_var then Warnings.Unused_var s
                              else Warnings.Unused_var_strict s)
             met_env,
           Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                            val_attributes = [];
                             Types.val_loc = loc;
                            } par_env))
       pv (val_env, met_env, par_env)
@@ -1907,6 +1913,13 @@ and type_expect_ ?in_function env sexp ty_expected =
           let name = Path.name ~paren:Oprint.parenthesized_ident path in
           Stypes.record (Stypes.An_ident (loc, name, annot))
         end;
+        if
+          List.exists
+            (function ({txt = "deprecated"; _}, _) -> true | _ ->  false)
+            desc.val_attributes
+        then
+          Location.prerr_warning loc (Warnings.Deprecated (Path.name path));
+
         rue {
           exp_desc =
             begin match desc.val_kind with
@@ -2302,6 +2315,7 @@ and type_expect_ ?in_function env sexp ty_expected =
       let high = type_expect env shigh Predef.type_int in
       let (id, new_env) =
         Env.enter_value param.txt {val_type = instance_def Predef.type_int;
+          val_attributes = [];
           val_kind = Val_reg; Types.val_loc = loc; } env
           ~check:(fun s -> Warnings.Unused_for_index s)
       in
@@ -2460,6 +2474,7 @@ and type_expect_ ?in_function env sexp ty_expected =
                                 Texp_ident(Path.Pident method_id, lid,
                                            {val_type = method_type;
                                             val_kind = Val_reg;
+                                            val_attributes = [];
                                             Types.val_loc = Location.none});
                                 exp_loc = loc; exp_extra = [];
                                 exp_type = method_type;
@@ -2952,6 +2967,7 @@ and type_argument env sarg ty_expected' ty_expected =
          exp_desc =
          Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
                     {val_type = ty; val_kind = Val_reg;
+                     val_attributes = [];
                      Types.val_loc = Location.none})}
       in
       let eta_pat, eta_var = var_pair "eta" ty_arg in
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 23d986bbf2..025113d85e 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1047,7 +1047,8 @@ let transl_value_decl env loc valdecl =
   let v =
   match valdecl.pval_prim with
     [] ->
-      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc }
+      { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes }
   | decl ->
       let arity = Ctype.arity ty in
       if arity = 0 then
@@ -1057,7 +1058,8 @@ let transl_value_decl env loc valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
-      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc }
+      { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
+        val_attributes = valdecl.pval_attributes }
   in
   let (id, newenv) =
     Env.enter_value valdecl.pval_name.txt v env
diff --git a/typing/types.ml b/typing/types.ml
index 3b1d1141e3..6318d6b949 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -87,6 +87,7 @@ type value_description =
   { val_type: type_expr;                (* Type of the value *)
     val_kind: value_kind;
     val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
  }
 
 and value_kind =
diff --git a/typing/types.mli b/typing/types.mli
index a9c8d11c7c..8d8730cfdc 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -85,6 +85,7 @@ type value_description =
   { val_type: type_expr;                (* Type of the value *)
     val_kind: value_kind;
     val_loc: Location.t;
+    val_attributes: Parsetree.attributes;
    }
 
 and value_kind =