Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Ajout du warning de la séquence et pilotage des warnings par l'utilisateur. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2149 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Pierre Weis 1998-11-05 08:07:15 +00:00
parent af0a7574c8
commit 7298911eae
7 changed files with 40 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
typing/includemod.ml
View File

@ -289,7 +289,7 @@ and check_modtype_equiv env mty1 mty2 =
let check_modtype_inclusion env mty1 mty2 =
try
modtypes env Subst.identity mty1 mty2; ()
let _ = modtypes env Subst.identity mty1 mty2 in ()
with Error reasons ->
raise Not_found

7
typing/parmatch.ml
View File

@ -5,7 +5,7 @@
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
@ -260,7 +260,7 @@ let check_partial loc casel =
if match pss with
[] -> if casel = [] then false else true
| ps::_ -> satisfiable pss (List.map (fun _ -> omega) ps)
then Location.print_warning loc "this pattern-matching is not exhaustive"
then Location.print_warning loc Warnings.Partial_match
let location_of_clause = function
pat :: _ -> pat.pat_loc
@ -278,6 +278,5 @@ let check_unused casel =
List.iter
(fun (pss, ((qs, _) as clause)) ->
if not (satisfiable pss qs) then
Location.print_warning (location_of_clause qs)
"this match case is unused.")
Location.print_warning (location_of_clause qs) Warnings.Unused_match)
prefs

43
typing/printtyp.ml
View File

@ -5,7 +5,7 @@
(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
@ -72,15 +72,14 @@ let name_of_type t =
names := (t, name) :: !names;
name
let rec list_removeq a =
function
[] ->
[]
| (b, _) as e::l ->
if a == b then l else e::list_removeq a l
let print_name_of_type t =
print_string (name_of_type t)
let check_name_of_type t =
let _ = name_of_type t in ()
let remove_name_of_type t =
names := list_removeq t !names
names := List.removeq t !names
let visited_objects = ref ([] : type_expr list)
let aliased = ref ([] : type_expr list)
@ -143,16 +142,15 @@ let reset () =
let rec typexp sch prio0 ty =
let ty = repr ty in
try
List.assq ty !names;
if List.mem_assq ty !names then begin
if (ty.desc = Tvar) && sch && (ty.level <> generic_level)
then print_string "'_"
else print_string "'";
print_string (name_of_type ty)
with Not_found ->
print_name_of_type ty
end else begin
let alias = List.memq ty !aliased in
if alias then begin
name_of_type ty;
check_name_of_type ty;
if prio0 >= 1 then begin open_box 1; print_string "(" end
else open_box 0
end;
@ -162,7 +160,7 @@ let rec typexp sch prio0 ty =
if (not sch) or ty.level = generic_level
then print_string "'"
else print_string "'_";
print_string(name_of_type ty)
print_name_of_type ty
| Tarrow(ty1, ty2) ->
if prio >= 2 then begin open_box 1; print_string "(" end
else open_box 0;
@ -201,12 +199,13 @@ let rec typexp sch prio0 ty =
if alias then begin
print_string " as ";
print_string "'";
print_string (name_of_type ty);
print_name_of_type ty;
if not (opened_object ty) then
remove_name_of_type ty;
if prio0 >= 1 then print_string ")";
close_box()
end
end
(*; print_string "["; print_int ty.level; print_string "]"*)
and typlist sch prio sep = function
@ -313,7 +312,7 @@ let rec type_decl kwd id decl =
aliased := params @ !aliased;
List.iter mark_loops params;
List.iter (fun x -> name_of_type x; ()) params;
List.iter check_name_of_type params;
begin match decl.type_manifest with
None -> ()
| Some ty -> mark_loops ty
@ -469,7 +468,7 @@ let rec perform_class_type sch p params =
print_space ();
open_box 0;
print_string "['";
print_string (name_of_type sty);
print_name_of_type sty;
print_string "]";
close_box ()
end;
@ -483,7 +482,7 @@ let rec perform_class_type sch p params =
print_space ();
open_box 0;
print_string "('";
print_string (name_of_type sty);
print_name_of_type sty;
print_string ")";
close_box ()
end;
@ -529,9 +528,9 @@ let class_declaration id cl =
let sty = self_type cl.cty_type in
List.iter mark_loops params;
List.iter (fun x -> name_of_type x; ()) params;
List.iter check_name_of_type params;
if List.memq sty !aliased then
(name_of_type sty; ());
check_name_of_type sty;
open_box 2;
print_string "class";
@ -563,9 +562,9 @@ let cltype_declaration id cl =
let sty = self_type cl.clty_type in
List.iter mark_loops params;
List.iter (fun x -> name_of_type x; ()) params;
List.iter check_name_of_type params;
if List.memq sty !aliased then
(name_of_type sty; ());
check_name_of_type sty;
let sign = Ctype.signature_of_class_type cl.clty_type in
let virt =

2
typing/printtyp.mli
View File

@ -5,7 +5,7 @@
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)

13
typing/typeclass.ml
View File

@ -5,7 +5,7 @@
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
@ -213,8 +213,7 @@ let inheritance impl self_type env concr_meths loc parent =
let overridings = Concr.inter cl_sig.cty_concr concr_meths in
if not (Concr.is_empty overridings) then begin
Location.print_warning loc
("the following methods are overriden by the inherited class:\n "
^ (String.concat " " (Concr.elements overridings)))
(Warnings.Method_override (Concr.elements overridings))
end
end;
let concr_meths = Concr.union cl_sig.cty_concr concr_meths in
@ -358,9 +357,7 @@ let rec class_field self_type meths vars
in
if StringSet.mem lab inh_vals then
Location.print_warning sparent.pcl_loc
("this definition of an instance variable " ^ lab ^
" hides a previously\ndefined instance variable of \
the same name");
(Warnings.Hide_instance_variable lab);
(val_env, met_env, par_env, (lab, id) :: inh_vars,
StringSet.add lab inh_vals))
cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
@ -388,9 +385,7 @@ let rec class_field self_type meths vars
| Pcf_val (lab, mut, sexp, loc) ->
if StringSet.mem lab inh_vals then
Location.print_warning loc
("this definition of an instance variable " ^ lab ^
" hides a previously\ndefined instance variable of the same name");
Location.print_warning loc (Warnings.Hide_instance_variable lab);
let exp = type_exp val_env sexp in
if not (Typecore.is_nonexpansive exp) then
begin try

13
typing/typecore.ml
View File

@ -5,7 +5,7 @@
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
@ -826,11 +826,12 @@ and type_expect env sexp ty_expected =
and type_statement env sexp =
let exp = type_exp env sexp in
match (repr exp.exp_type).desc with
Tarrow(_, _) ->
Location.print_warning sexp.pexp_loc
"this function application is partial,\n\
maybe some arguments are missing.";
match (expand_head env exp.exp_type).desc with
| Tarrow(_, _) ->
Location.print_warning sexp.pexp_loc Warnings.Partial_application;
exp
| Tconstr (p, _, _) when not (Path.same p Predef.path_unit) ->
Location.print_warning sexp.pexp_loc Warnings.Statement_type;
exp
| _ -> exp

11
typing/typetexp.ml
View File

@ -130,7 +130,7 @@ let rec transl_type env policy styp =
let args = List.map (transl_type env policy) stl in
let params = List.map (fun _ -> Ctype.newvar ()) args in
let cstr = newty (Tconstr(path, params, ref Mnil)) in
Ctype.expand_head env cstr;
let _ = Ctype.expand_head env cstr in
List.iter2
(fun (sty, ty) ty' ->
try unify env ty ty' with Unify trace ->
@ -166,13 +166,9 @@ let rec transl_type env policy styp =
(List.combine stl args) params;
ty
| Ptyp_alias(st, alias) ->
begin try
Tbl.find alias !type_variables;
if Tbl.mem alias !type_variables || Tbl.mem alias !aliases then
raise(Error(styp.ptyp_loc, Bound_type_variable alias))
with Not_found -> try
Tbl.find alias !aliases;
raise(Error(styp.ptyp_loc, Bound_type_variable alias))
with Not_found ->
else
let ty' = newvar () in
aliases := Tbl.add alias ty' !aliases;
let ty = transl_type env policy st in
@ -180,7 +176,6 @@ let rec transl_type env policy styp =
raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
end;
ty
end
and transl_fields env policy =
function