Permalink
Browse files

Revise behavior of ocaml.warning attribute: when used as a floating a…

…ttribute (in a signature or structure), the scope is restricted to the current signature/structure instead of being global. Also support the new floating attributes in classes, with the same behavior.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14752 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent 110e97d commit 0736512709e873c74bf743079cf6d94d42ff38b2 @alainfrisch alainfrisch committed May 6, 2014
Showing with 31 additions and 10 deletions.
  1. +6 −0 typing/typeclass.ml
  2. +3 −2 typing/typecore.ml
  3. +6 −2 typing/typemod.ml
  4. +13 −5 typing/typetexp.ml
  5. +3 −1 typing/typetexp.mli
View
@@ -411,6 +411,7 @@ let rec class_type_field env self_type meths
val_sig, concr_meths, inher)
| Pctf_attribute x ->
+ Typetexp.warning_attribute [x];
(mkctf (Tctf_attribute x) :: fields,
val_sig, concr_meths, inher)
@@ -436,11 +437,13 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
end;
(* Class type fields *)
+ Typetexp.warning_enter_scope ();
let (fields, val_sig, concr_meths, inher) =
List.fold_left (class_type_field env self_type meths)
([], Vars.empty, Concr.empty, [])
sign
in
+ Typetexp.warning_leave_scope ();
let cty = {csig_self = self_type;
csig_vars = val_sig;
csig_concr = concr_meths;
@@ -705,6 +708,7 @@ let rec class_field self_loc cl_num self_type meths vars
(val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
inher, local_meths, local_vals)
| Pcf_attribute x ->
+ Typetexp.warning_attribute [x];
(val_env, met_env, par_env,
lazy (mkcf (Tcf_attribute x)) :: fields,
concr_meths, warn_vals, inher, local_meths, local_vals)
@@ -758,12 +762,14 @@ and class_structure cl_num final val_env met_env loc
end;
(* Typing of class fields *)
+ Typetexp.warning_enter_scope ();
let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
List.fold_left (class_field self_loc cl_num self_type meths vars)
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
Concr.empty, Concr.empty)
str
in
+ Typetexp.warning_leave_scope ();
Ctype.unify val_env self_type (Ctype.newvar ());
let sign =
{csig_self = public_self;
View
@@ -1923,9 +1923,10 @@ let rec type_exp env sexp =
and type_expect ?in_function env sexp ty_expected =
let previous_saved_types = Cmt_format.get_saved_types () in
- let prev_warnings = Typetexp.warning_attribute sexp.pexp_attributes in
+ Typetexp.warning_enter_scope ();
+ Typetexp.warning_attribute sexp.pexp_attributes;
let exp = type_expect_ ?in_function env sexp ty_expected in
- may Warnings.restore prev_warnings;
+ Typetexp.warning_leave_scope ();
Cmt_format.set_saved_types
(Cmt_format.Partial_expression exp :: previous_saved_types);
exp
View
@@ -707,15 +707,17 @@ and transl_signature env sg =
classes [rem]),
final_env
| Psig_attribute x ->
- let _back = Typetexp.warning_attribute [x] in
+ Typetexp.warning_attribute [x];
let (trem,rem, final_env) = transl_sig env srem in
mksig (Tsig_attribute x) env loc :: trem, rem, final_env
| Psig_extension ((s, _), _) ->
raise (Error (s.loc, env, Extension s.txt))
in
let previous_saved_types = Cmt_format.get_saved_types () in
+ Typetexp.warning_enter_scope ();
let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in
let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in
+ Typetexp.warning_leave_scope ();
Cmt_format.set_saved_types
((Cmt_format.Partial_signature sg) :: previous_saved_types);
sg
@@ -1386,7 +1388,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
| Pstr_extension ((s, _), _) ->
raise (Error (s.loc, env, Extension s.txt))
| Pstr_attribute x ->
- let _back = Typetexp.warning_attribute [x] in
+ Typetexp.warning_attribute [x];
Tstr_attribute x, [], env
in
let rec type_struct env sstr =
@@ -1406,8 +1408,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(* moved to genannot *)
List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
let previous_saved_types = Cmt_format.get_saved_types () in
+ Typetexp.warning_enter_scope ();
let (items, sg, final_env) = type_struct env sstr in
let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+ Typetexp.warning_leave_scope ();
Cmt_format.set_saved_types
(Cmt_format.Partial_structure str :: previous_saved_types);
str, sg, final_env
View
@@ -75,8 +75,19 @@ let check_deprecated loc attrs s =
| _ -> ())
attrs
+let warning_scope = ref []
+
+let warning_enter_scope () =
+ warning_scope := ref None :: !warning_scope
+let warning_leave_scope () =
+ match !warning_scope with
+ | [] -> assert false
+ | hd :: tl ->
+ may Warnings.restore !hd;
+ warning_scope := tl
+
let warning_attribute attrs =
- let prev_warnings = ref None in
+ let prev_warnings = List.hd !warning_scope in
List.iter
(function
| ({txt = "ocaml.warning"|"warning"; loc}, payload) ->
@@ -101,10 +112,7 @@ let warning_attribute attrs =
| _ ->
()
)
- attrs;
- !prev_warnings
-
-
+ attrs
type variable_context = int * (string, type_expr) Tbl.t
View
@@ -113,4 +113,6 @@ val spellcheck_simple:
val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
-val warning_attribute: Parsetree.attributes -> Warnings.state option
+val warning_enter_scope: unit -> unit
+val warning_leave_scope: unit -> unit
+val warning_attribute: Parsetree.attributes -> unit

0 comments on commit 0736512

Please sign in to comment.