Commit e9e425c1 authored by POTTIER Francois's avatar POTTIER Francois

Renamed two exceptions, for compatibility with OCaml 4.03.

parent 41a6303d
......@@ -355,7 +355,7 @@ let rec filter_row_fields erase = function
(**************************************)
exception Non_closed
exception NonClosed
let rec closed_schema_rec ty =
let ty = repr ty in
......@@ -364,7 +364,7 @@ let rec closed_schema_rec ty =
ty.level <- pivot_level - level;
match ty.desc with
Tvar when level <> generic_level ->
raise Non_closed
raise NonClosed
| Tfield(_, kind, t1, t2) ->
if field_kind_repr kind = Fpresent then
closed_schema_rec t1;
......@@ -383,7 +383,7 @@ let closed_schema ty =
closed_schema_rec ty;
unmark_type ty;
true
with Non_closed ->
with NonClosed ->
unmark_type ty;
false
......@@ -476,7 +476,7 @@ type closed_class_failure =
CC_Method of type_expr * bool * string * type_expr
| CC_Value of type_expr * bool * string * type_expr
exception Failure of closed_class_failure
exception ClosedClassFailure of closed_class_failure
let closed_class params sign =
let ty = object_fields (repr sign.cty_self) in
......@@ -492,13 +492,13 @@ let closed_class params sign =
(fun (lab, kind, ty) ->
if field_kind_repr kind = Fpresent then
try closed_type ty with Non_closed (ty0, real) ->
raise (Failure (CC_Method (ty0, real, lab, ty))))
raise (ClosedClassFailure (CC_Method (ty0, real, lab, ty))))
fields;
mark_type_params (repr sign.cty_self);
List.iter unmark_type params;
unmark_class_signature sign;
None
with Failure reason ->
with ClosedClassFailure reason ->
mark_type_params (repr sign.cty_self);
List.iter unmark_type params;
unmark_class_signature sign;
......@@ -2455,7 +2455,7 @@ type class_match_failure =
| CM_Private_method of string
| CM_Virtual_method of string
exception Failure of class_match_failure list
exception ClassMatchFailure of class_match_failure list
let rec moregen_clty trace type_pairs env cty1 cty2 =
try
......@@ -2466,7 +2466,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
moregen_clty true type_pairs env cty1 cty2
| Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
raise (ClassMatchFailure [CM_Parameter_mismatch (expand_trace env trace)])
end;
moregen_clty false type_pairs env cty1' cty2'
| Cty_signature sign1, Cty_signature sign2 ->
......@@ -2478,7 +2478,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
List.iter
(fun (lab, k1, t1, k2, t2) ->
begin try moregen true type_pairs env t1 t2 with Unify trace ->
raise (Failure [CM_Meth_type_mismatch
raise (ClassMatchFailure [CM_Meth_type_mismatch
(lab, expand_trace env trace)])
end)
pairs;
......@@ -2486,14 +2486,14 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
(fun lab (mut, v, ty) ->
let (mut', v', ty') = Vars.find lab sign1.cty_vars in
try moregen true type_pairs env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
raise (ClassMatchFailure [CM_Val_type_mismatch
(lab, expand_trace env trace)]))
sign2.cty_vars
| _ ->
raise (Failure [])
raise (ClassMatchFailure [])
with
Failure error when trace || error = [] ->
raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
ClassMatchFailure error when trace || error = [] ->
raise (ClassMatchFailure (CM_Class_type_mismatch (cty1, cty2)::error))
let match_class_types ?(trace=true) env pat_sch subj_sch =
let type_pairs = TypePairs.create 53 in
......@@ -2582,7 +2582,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
moregen_clty trace type_pairs env patt subj;
[]
with
Failure r -> r
ClassMatchFailure r -> r
end
| error ->
CM_Class_type_mismatch (patt, subj)::error
......@@ -2601,7 +2601,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
equal_clty true type_pairs subst env cty1 cty2
| Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
raise (ClassMatchFailure [CM_Parameter_mismatch (expand_trace env trace)])
end;
equal_clty false type_pairs subst env cty1' cty2'
| Cty_signature sign1, Cty_signature sign2 ->
......@@ -2614,7 +2614,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
(fun (lab, k1, t1, k2, t2) ->
begin try eqtype true type_pairs subst env t1 t2 with
Unify trace ->
raise (Failure [CM_Meth_type_mismatch
raise (ClassMatchFailure [CM_Meth_type_mismatch
(lab, expand_trace env trace)])
end)
pairs;
......@@ -2622,16 +2622,16 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
(fun lab (_, _, ty) ->
let (_, _, ty') = Vars.find lab sign1.cty_vars in
try eqtype true type_pairs subst env ty' ty with Unify trace ->
raise (Failure [CM_Val_type_mismatch
raise (ClassMatchFailure [CM_Val_type_mismatch
(lab, expand_trace env trace)]))
sign2.cty_vars
| _ ->
raise
(Failure (if trace then []
(ClassMatchFailure (if trace then []
else [CM_Class_type_mismatch (cty1, cty2)]))
with
Failure error when trace ->
raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
ClassMatchFailure error when trace ->
raise (ClassMatchFailure (CM_Class_type_mismatch (cty1, cty2)::error))
let match_class_declarations env patt_params patt_type subj_params subj_type =
let type_pairs = TypePairs.create 53 in
......@@ -2713,10 +2713,10 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
let lp = List.length patt_params in
let ls = List.length subj_params in
if lp <> ls then
raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]);
raise (ClassMatchFailure [CM_Parameter_arity_mismatch (lp, ls)]);
List.iter2 (fun p s ->
try eqtype true type_pairs subst env p s with Unify trace ->
raise (Failure [CM_Type_parameter_mismatch
raise (ClassMatchFailure [CM_Type_parameter_mismatch
(expand_trace env trace)]))
patt_params subj_params;
(* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
......@@ -2728,7 +2728,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
match_class_types ~trace:false env
(clty_params patt_params patt_type) (clty_params subj_params subj_type)
with
Failure r -> r
ClassMatchFailure r -> r
end
| error ->
error
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment