summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--typing/includemod.ml2
-rw-r--r--typing/parmatch.ml7
-rw-r--r--typing/printtyp.ml43
-rw-r--r--typing/printtyp.mli2
-rw-r--r--typing/typeclass.ml13
-rw-r--r--typing/typecore.ml13
-rw-r--r--typing/typetexp.ml11
7 files changed, 40 insertions, 51 deletions
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 098b82025..59510e86c 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -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
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 8bb62071e..24962803f 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -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
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 78dcd0441..24b0c70ec 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -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 =
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index a91523e5b..93a4e5870 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -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. *)
(* *)
(***********************************************************************)
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 8a4738b0d..90fa3b721 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -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
diff --git a/typing/typecore.ml b/typing/typecore.ml
index cd029e212..e27f2ab72 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -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
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 65fc11313..c6f617b02 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -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
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-25 10:35:02 +0000