summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/typeopt.ml8
-rw-r--r--parsing/parser.mly2
-rw-r--r--parsing/printast.ml8
-rw-r--r--toplevel/genprintval.ml2
-rw-r--r--typing/btype.ml6
-rw-r--r--typing/ctype.ml254
-rw-r--r--typing/datarepr.ml6
-rw-r--r--typing/env.ml3
-rw-r--r--typing/env.mli2
-rw-r--r--typing/ident.ml2
-rw-r--r--typing/includecore.ml2
-rw-r--r--typing/oprint.ml2
-rw-r--r--typing/predef.ml4
-rw-r--r--typing/printtyp.ml2
-rw-r--r--typing/subst.ml4
-rw-r--r--typing/typecore.ml51
-rw-r--r--typing/typedecl.ml32
-rw-r--r--typing/typedecl.mli2
-rw-r--r--typing/typemod.ml2
-rw-r--r--typing/typetexp.ml2
20 files changed, 191 insertions, 205 deletions
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index 56c3a0075..b9b8de0e3 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -40,9 +40,9 @@ let maybe_pointer exp =
| {type_kind = Type_variant []} -> true (* type exn *)
| {type_kind = Type_generalized_variant []} -> true (* type exn *)
| {type_kind = Type_variant cstrs} ->
- List.exists (fun (name, args) -> args <> []) cstrs (* GAH: dunno what's going on *)
+ List.exists (fun (name, args) -> args <> []) cstrs
| {type_kind = Type_generalized_variant cstrs} ->
- List.exists (fun (name, args,_) -> args <> []) cstrs (* GAH: dunno what's going on *)
+ List.exists (fun (name, args,_) -> args <> []) cstrs
| _ -> true
with Not_found -> true
(* This can happen due to e.g. missing -I options,
@@ -72,10 +72,10 @@ let array_element_kind env ty =
{type_kind = Type_abstract} ->
Pgenarray
| {type_kind = Type_variant cstrs}
- when List.for_all (fun (name, args) -> args = []) cstrs -> (* GAH: guess? *)
+ when List.for_all (fun (name, args) -> args = []) cstrs ->
Pintarray
| {type_kind = Type_generalized_variant cstrs}
- when List.for_all (fun (name, args,_) -> args = []) cstrs -> (* GAH: guess? *)
+ when List.for_all (fun (name, args,_) -> args = []) cstrs ->
Pintarray
| {type_kind = _} ->
Paddrarray
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 30b95e77a..5e241d07a 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1130,7 +1130,7 @@ let_binding:
let core_type = varify_constructors newtypes core_type in
(ghpat(Ppat_constraint({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1},
- ghtyp(Ptyp_poly(newtypes,core_type)))),
+ ghtyp(Ptyp_poly(List.map (fun s -> "&" ^ s) newtypes,core_type)))),
exp)
}
| pattern EQUAL seq_expr
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 821f76096..91b3f8ceb 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -354,7 +354,7 @@ and type_declaration i ppf x =
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest;
-and type_kind i ppf x = (* GAH: why doesn't this module use Format?? *)
+and type_kind i ppf x =
match x with
| Ptype_abstract ->
line i ppf "Ptype_abstract\n"
@@ -671,16 +671,14 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct2;
and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
- match r_opt with
+ match r_opt with (* GAH : probably wrong, ask garrigue *)
| None ->
line i ppf "\"%s\" %a\n" s fmt_location loc;
list (i+1) core_type ppf l;
- | Some ret_type -> (* GAH: this is definately wrong *)
+ | Some ret_type -> (* GAH: this is definitely wrong *)
line i ppf "\"%s\" %a\n" s fmt_location loc;
list (i+1) core_type ppf l;
core_type i ppf ret_type
-
-
and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 5ac0e03fd..e8b566e4e 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -240,7 +240,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
- let (constr_name, constr_args,_) = (* GAH: this is definately wrong *)
+ let (constr_name, constr_args,_) = (* GAH: this is definitely wrong *)
Datarepr.find_constr_by_tag tag constr_list in
let ty_args =
List.map
diff --git a/typing/btype.ml b/typing/btype.ml
index c9ed577ac..602927812 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -286,7 +286,7 @@ let cleanup_types () =
(* Mark a type. *)
let rec mark_type ty =
- let ty = repr ty in (* GAH : why do we call repr? *)
+ let ty = repr ty in
if ty.level >= lowest_level then begin
ty.level <- pivot_level - ty.level;
iter_type_expr mark_type ty
@@ -317,13 +317,13 @@ let unmark_type_decl decl =
List.iter
(fun (c, tl) ->
List.iter unmark_type tl)
- cstrs (* GAH: WHAT DOES UNMARK DO??? *)
+ cstrs
| Type_generalized_variant cstrs ->
List.iter
(fun (c, tl,ret_type_opt) ->
List.iter unmark_type tl;
Misc.may unmark_type ret_type_opt)
- cstrs (* GAH: WHAT DOES UNMARK DO??? *)
+ cstrs
| Type_record(lbls, rep) ->
List.iter (fun (c, mut, t) -> unmark_type t) lbls
end;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 7cf2c665c..9e28c1485 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -661,12 +661,12 @@ let closed_type_decl decl =
| Some _ -> ()
| None ->
List.iter closed_type tyl)
- v (* GAH: is this correct ? *)
+ v
| Type_variant v ->
List.iter
(fun (_, tyl) ->
List.iter closed_type tyl)
- v (* GAH: is this correct ? *)
+ v
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> closed_type ty) r
end;
@@ -1062,8 +1062,18 @@ let get_new_abstract_name () =
incr reified_var_counter;
ret
-
-let instance_constructor ?(in_pattern=None) cstr = (* GAH : how the blazes does this work?? *)
+let new_declaration newtype manifest =
+ {
+ type_params = [];
+ type_arity = 0;
+ type_kind = Type_abstract;
+ type_private = Public;
+ type_manifest = manifest;
+ type_variance = [];
+ type_newtype = newtype;
+ }
+
+let instance_constructor ?(in_pattern=None) cstr =
let ty_res = copy cstr.cstr_res in
let ty_args = List.map copy cstr.cstr_args in
begin match in_pattern with
@@ -1071,16 +1081,7 @@ let instance_constructor ?(in_pattern=None) cstr = (* GAH : how the blazes does
| Some env ->
let existentials = List.map copy cstr.cstr_existentials in
let process existential =
- let decl = {
- type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype = true;
- }
- in
+ let decl = new_declaration true None in
let (id, new_env) = Env.enter_type (get_new_abstract_name ()) decl !env in
env := new_env;
let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
@@ -1365,7 +1366,7 @@ let expand_abbrev_gen kind find_type_expansion env ty =
| _ ->
assert false
-let expand_abbrev = expand_abbrev_gen Public Env.find_type_expansion
+let expand_abbrev ?(use_local=true) = expand_abbrev_gen Public (Env.find_type_expansion ~use_local)
let safe_abbrev env ty =
let snap = Btype.snapshot () in
@@ -1374,10 +1375,10 @@ let safe_abbrev env ty =
Btype.backtrack snap;
false
-let try_expand_once env ty =
+let try_expand_once ?(use_local=true) env ty =
let ty = repr ty in
match ty.desc with
- Tconstr _ -> repr (expand_abbrev env ty)
+ Tconstr _ -> repr (expand_abbrev ~use_local env ty)
| _ -> raise Cannot_expand
let _ = forward_try_expand_once := try_expand_once
@@ -1385,8 +1386,8 @@ let _ = forward_try_expand_once := try_expand_once
(* Fully expand the head of a type.
Raise Cannot_expand if the type cannot be expanded.
May raise Unify, if a recursion was hidden in the type. *)
-let rec try_expand_head env ty =
- let ty' = try_expand_once env ty in
+let rec try_expand_head ?(use_local=true) env ty =
+ let ty' = try_expand_once ~use_local env ty in
begin try
try_expand_head env ty'
with Cannot_expand ->
@@ -1398,8 +1399,8 @@ let expand_head_once env ty =
try expand_abbrev env (repr ty) with Cannot_expand -> assert false
(* Fully expand the head of a type. *)
-let expand_head_unif env ty =
- try try_expand_head env ty with Cannot_expand -> repr ty
+let expand_head_unif ?(use_local=true) env ty =
+ try try_expand_head ~use_local env ty with Cannot_expand -> repr ty
let expand_head env ty =
let snap = Btype.snapshot () in
@@ -1774,24 +1775,14 @@ let pattern_unification = ref false
let pattern_level = ref None
-
-let reify env t = (* GAH: ask garrigue, how do you close variants? *)
+let reify env t =
let pattern_level =
match !pattern_level with
| None -> assert false
| Some x -> x
in
let create_fresh_constr row =
- let decl = {
- type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_private = Public;
- type_manifest = None;
- type_variance = [];
- type_newtype = true;
- }
- in
+ let decl = new_declaration true None in
let name =
let name = get_new_abstract_name () in
if row then name ^ "#row" else name
@@ -1811,7 +1802,7 @@ let reify env t = (* GAH: ask garrigue, how do you close variants? *)
let t = create_fresh_constr true in
link_type tvar t;
iter_type_expr (iterator visited) ty
- | Tvariant r ->
+ | Tvariant r -> (* GAH: ask garrigue, what about [< `Foo of a & b] ? *)
if static_row r then
()
else
@@ -1841,14 +1832,16 @@ let reify env t = (* GAH: ask garrigue, how do you close variants? *)
let unify_eq_set = TypePairs.create 10
let add_type_equality t1 t2 =
- let do_it t1 t2 =
- TypePairs.add unify_eq_set (t1,t2) ()
- in
- if t1.id <= t2.id then do_it t1 t2 else do_it t2 t1
-
-let is_newtype env p =
+ let do_it t1 t2 =
+ TypePairs.add unify_eq_set (t1,t2) ()
+ in
+ if t1.id <= t2.id then do_it t1 t2 else do_it t2 t1
+
+let is_abstract_newtype env p =
let decl = Env.find_type p env in
- decl.type_newtype
+ decl.type_newtype &&
+ decl.type_manifest = None &&
+ decl.type_kind = Type_abstract
let definitely_abstract env p =
let is_abstract p =
@@ -1875,17 +1868,26 @@ let in_pervasives p =
with
_ -> false
-let unify_eq t1 t2 =
- let do_it t1 t2 =
- try
- TypePairs.find unify_eq_set (t1, t2);
- true
- with
- Not_found ->
- false
- in
- if t1 == t2 then true else
- if t1.id <= t2.id then do_it t1 t2 else do_it t2 t1
+type unification_mode =
+ | Expression (* unification in expression *)
+ | Pattern (* unification in pattern which may add local constraints *)
+ | Old (* unification in pattern, old style. local constraints are not used nor generated *)
+
+let unify_eq mode t1 t2 =
+ match mode with
+ | Old ->
+ t1 == t2
+ | Pattern | Expression ->
+ let do_it t1 t2 =
+ try
+ TypePairs.find unify_eq_set (t1, t2);
+ true
+ with
+ Not_found ->
+ false
+ in
+ if t1 == t2 then true else
+ if t1.id <= t2.id then do_it t1 t2 else do_it t2 t1
(* mcomp type_pairs subst env t1 t2 does not raise an
exception if it is possible that t1 and t2 are actually
@@ -2028,26 +2030,30 @@ and mcomp_row type_pairs subst env row1 row2 =
let mcomp env t1 t2 =
mcomp (TypePairs.create 5) () env t1 t2
-let rec unify (env:Env.t ref) t1 t2 =
+
+
+let rec unify mode (env:Env.t ref) t1 t2 =
(* First step: special cases (optimizations) *)
- if unify_eq t1 t2 then () else
+ if unify_eq mode t1 t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
- if unify_eq t1 t2 then () else
+ if unify_eq mode t1 t2 then () else
try
type_changed := true;
match (t1.desc, t2.desc) with
(Tvar, Tconstr _) when deep_occur t1 t2 ->
- unify2 env t1 t2
+ unify2 mode env t1 t2
| (Tconstr _, Tvar) when deep_occur t2 t1 ->
- unify2 env t1 t2
+ unify2 mode env t1 t2
| (Tvar, _) ->
- occur !env t1 t2; occur_univar !env t2;
+ occur !env t1 t2;
+ occur_univar !env t2;
link_type t1 t2;
update_level !env t1.level t2
| (_, Tvar) ->
- occur !env t2 t1; occur_univar !env t1;
+ occur !env t2 t1;
+ occur_univar !env t1;
link_type t2 t1;
update_level !env t2.level t1
| (Tunivar, Tunivar) ->
@@ -2064,104 +2070,82 @@ let rec unify (env:Env.t ref) t1 t2 =
update_level !env t1.level t2;
link_type t1 t2
| _ ->
- unify2 env t1 t2
+ unify2 mode env t1 t2
with Unify trace ->
raise (Unify ((t1, t2)::trace))
-and unify2 env t1 t2 =
+and unify2 mode env t1 t2 =
(* Second step: expansion of abbreviations *)
let rec expand_both t1'' t2'' =
let t1' = expand_head_unif !env t1 in
let t2' = expand_head_unif !env t2 in
(* Expansion may have changed the representative of the types... *)
- if unify_eq t1' t1'' && unify_eq t2' t2'' then (t1',t2') else
+ if unify_eq mode t1' t1'' && unify_eq mode t2' t2'' then (t1',t2') else
expand_both t1' t2'
in
let t1', t2' = expand_both t1 t2 in
- if unify_eq t1' t2' then () else
+ if unify_eq mode t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
- if unify_eq t1 t1' || not (unify_eq t2 t2') then
- unify3 env t1 t1' t2 t2'
+ if unify_eq mode t1 t1' || not (unify_eq mode t2 t2') then
+ unify3 mode env t1 t1' t2 t2'
else
- try unify3 env t2 t2' t1 t1' with Unify trace ->
+ try unify3 mode env t2 t2' t1 t1' with Unify trace ->
raise (Unify (List.map (fun (x, y) -> (y, x)) trace))
-and unify3 env t1 t1' t2 t2' =
+and unify3 mode env t1 t1' t2 t2' =
(* Third step: truly unification *)
(* Assumes either [t1 == t1'] or [t2 != t2'] *)
let d1 = t1'.desc and d2 = t2'.desc in
let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
occur !env t1' t2';
- add_type_equality t1' t2';
+ begin match mode with
+ | Old ->
+ link_type t1' t2
+ | Pattern | Expression ->
+ add_type_equality t1' t2' end;
try
begin match (d1, d2) with
(Tvar, _) ->
- update_level !env t1'.level t2;
- link_type t1' t2;
- occur_univar !env t2
+ (* case taken care of in unify *)
+ assert false
| (_, Tvar) ->
- update_level !env t2'.level t1;
- link_type t2' t1;
- occur_univar !env t1
+ (* case taken care of in unify *)
+ assert false
| (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
- unify env t1 t2; unify env u1 u2;
+ unify mode env t1 t2; unify mode env u1 u2;
begin match commu_repr c1, commu_repr c2 with
Clink r, c2 -> set_commu r c2
| c1, Clink r -> set_commu r c1
| _ -> ()
end
| (Ttuple tl1, Ttuple tl2) ->
- unify_list env tl1 tl2
+ unify_list mode env tl1 tl2
| (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
- unify_list env tl1 tl2
-(* | _,(Tconstr (Path.Pident p,[],_)) when not !pattern_unification -> (* GAH : must be abstract or else it would have been expanded, ask garrigue *)
- raise (Unify [])*)
-(* | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when incompatible_types !env p1 p2 -> raise (Unify [])*)
- | (Tconstr ((Path.Pident p) as path,[],_)),_ when is_newtype !env path && !pattern_unification ->
+ unify_list mode env tl1 tl2
+ | (Tconstr ((Path.Pident p) as path,[],_)),_ when is_abstract_newtype !env path && !pattern_unification ->
reify env t2 ;
begin_def ();
let t2 = duplicate_type t2 in
end_def ();
generalize t2 ;
- let decl = {
- type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_private = Public;
- type_manifest = Some t2;
- type_variance = [];
- type_newtype = false;
- }
- in
- let new_env = Env.add_type p decl !env in
- env := new_env
- | _,(Tconstr ((Path.Pident p) as path,[],_)) when is_newtype !env path && !pattern_unification ->
+ let decl = new_declaration true (Some t2) in
+ env := Env.add_type p decl !env
+ | _,(Tconstr ((Path.Pident p) as path,[],_)) when is_abstract_newtype !env path && !pattern_unification ->
reify env t1 ;
begin_def ();
let t1 = duplicate_type t1 in
end_def ();
generalize t1 ;
- let decl = {
- type_params = [];
- type_arity = 0;
- type_kind = Type_abstract;
- type_private = Public;
- type_manifest = Some t1;
- type_variance = [];
- type_newtype = false;
- }
- in
- let new_env = Env.add_type p decl !env in
- env := new_env
-
+ let decl = new_declaration true (Some t1) in
+ env := Env.add_type p decl !env
| Tconstr (p1,_,_), Tconstr (p2,_,_) when !pattern_unification ->
reify env t1;
reify env t2;
mcomp !env t1 t2
| (Tobject (fi1, nm1), Tobject (fi2, _)) ->
- unify_fields env fi1 fi2;
+ unify_fields Old env fi1 fi2;
(* Type [t2'] may have been instantiated by [unify_fields] *)
(* XXX One should do some kind of unification... *)
begin match (repr t2').desc with
@@ -2176,7 +2160,7 @@ and unify3 env t1 t1' t2 t2' =
| (Tvariant row1, Tvariant row2) ->
unify_row env row1 row2
| (Tfield _, Tfield _) -> (* Actually unused *)
- unify_fields env t1' t2'
+ unify_fields mode env t1' t2'
| (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
begin match field_kind_repr kind with
Fvar r when f <> dummy_method -> set_kind r Fabsent
@@ -2185,11 +2169,11 @@ and unify3 env t1 t1' t2 t2' =
| (Tnil, Tnil) ->
()
| (Tpoly (t1, []), Tpoly (t2, [])) ->
- unify env t1 t2
+ unify mode env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+ enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify mode env)
| (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 ->
- unify_list env tl1 tl2
+ unify_list mode env tl1 tl2
| (_, _) ->
raise (Unify [])
end;
@@ -2234,12 +2218,12 @@ and unify3 env t1 t1' t2 t2' =
t1'.desc <- d1;
raise (Unify trace)
-and unify_list env tl1 tl2 =
+and unify_list mode env tl1 tl2 =
if List.length tl1 <> List.length tl2 then
raise (Unify []);
- List.iter2 (unify env) tl1 tl2
+ List.iter2 (unify mode env) tl1 tl2
-and unify_fields env ty1 ty2 = (* Optimization *)
+and unify_fields mode env ty1 ty2 = (* Optimization *)
let (fields1, rest1) = flatten_fields ty1
and (fields2, rest2) = flatten_fields ty2 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
@@ -2251,12 +2235,12 @@ and unify_fields env ty1 ty2 = (* Optimization *)
in
let d1 = rest1.desc and d2 = rest2.desc in
try
- unify env (build_fields l1 miss1 va) rest2;
- unify env rest1 (build_fields l2 miss2 va);
+ unify mode env (build_fields l1 miss1 va) rest2;
+ unify mode env rest1 (build_fields l2 miss2 va);
List.iter
(fun (n, k1, t1, k2, t2) ->
unify_kind k1 k2;
- try unify env t1 t2 with Unify trace ->
+ try unify mode env t1 t2 with Unify trace ->
raise (Unify ((newty (Tfield(n, k1, t1, va)),
newty (Tfield(n, k2, t2, va)))::trace)))
pairs
@@ -2275,8 +2259,8 @@ and unify_kind k1 k2 =
| (Fpresent, Fpresent) -> ()
| _ -> assert false
-and unify_pairs env tpl =
- List.iter (fun (t1, t2) -> unify env t1 t2) tpl
+and unify_pairs mode env tpl =
+ List.iter (fun (t1, t2) -> unify mode env t1 t2) tpl
and unify_row env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
@@ -2340,7 +2324,7 @@ and unify_row env row1 row2 =
if row.row_fixed then
if row0.row_more == rm then () else
if rm.desc = Tvar then link_type rm row0.row_more else
- unify env rm row0.row_more
+ unify Old env rm row0.row_more
else
let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
update_level !env rm.level ty;
@@ -2365,7 +2349,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 == f2 then () else
match f1, f2 with
- Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+ Rpresent(Some t1), Rpresent(Some t2) -> unify Old env t1 t2
| Rpresent None, Rpresent None -> ()
| Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
if e1 == e2 then () else
@@ -2375,7 +2359,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
begin match tl1 @ tl2 with [] -> false
| t1 :: tl ->
if c1 || c2 then raise (Unify []);
- List.iter (unify env t1) tl;
+ List.iter (unify Old env t1) tl;
!e1 <> None || !e2 <> None
end in
if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
@@ -2396,11 +2380,11 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
| Rabsent, Rabsent -> ()
| Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
set_row_field e1 f2;
- (try List.iter (fun t1 -> unify env t1 t2) tl
+ (try List.iter (fun t1 -> unify Old env t1 t2) tl
with exn -> e1 := None; raise exn)
| Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
set_row_field e2 f1;
- (try List.iter (unify env t1) tl
+ (try List.iter (unify Old env t1) tl
with exn -> e2 := None; raise exn)
| Reither(true, [], _, e1), Rpresent None when not fixed1 ->
set_row_field e1 f2
@@ -2409,10 +2393,10 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
| _ -> raise (Unify [])
-let unify env ty1 ty2 =
+let unify mode env ty1 ty2 =
try
TypePairs.clear unify_eq_set;
- unify env ty1 ty2
+ unify mode env ty1 ty2
with Unify trace ->
raise (Unify (expand_trace !env trace))
@@ -2421,7 +2405,7 @@ let unify_gadt plev (env:Env.t ref) ty1 ty2 =
try
pattern_level := Some plev;
pattern_unification:=true;
- unify env ty1 ty2;
+ unify Pattern env ty1 ty2;
pattern_unification:=false;
pattern_level := None;
with
@@ -2446,17 +2430,17 @@ let unify_var env t1 t2 =
raise (Unify (expand_trace env ((t1,t2)::trace)))
end
| _ ->
- unify (ref env) t1 t2
+ unify Expression (ref env) t1 t2
let _ = unify' := unify_var
let unify_pairs env ty1 ty2 pairs =
univar_pairs := pairs;
- unify env ty1 ty2
+ unify Expression env ty1 ty2
let unify env ty1 ty2 =
univar_pairs := [];
- unify (ref env) ty1 ty2
+ unify Expression (ref env) ty1 ty2
let unify_gadt env ty1 ty2 =
univar_pairs := [];
@@ -2927,10 +2911,6 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 =
let (fields1, rest1) = flatten_fields ty1 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
eqtype rename type_pairs subst env rest1 rest2;
-(*
- let miss1 = List.filter (function (_,Fvar _,_) -> false | _ -> true) miss1 in (* GAH: should probably remove this *)
- let miss2 = List.filter (function (_,Fvar _,_) -> false | _ -> true) miss2 in
-*)
if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
List.iter
(function (n, k1, t1, k2, t2) ->
@@ -3944,7 +3924,7 @@ let nondep_type_decl env mid id is_covariant decl =
Type_variant
(List.map
(fun (c, tl) ->
- (c, List.map (nondep_type_rec env mid) tl)) (* GAH: HERE TOO? *)
+ (c, List.map (nondep_type_rec env mid) tl))
cstrs)
| Type_generalized_variant cstrs ->
Type_generalized_variant
@@ -3953,7 +3933,7 @@ let nondep_type_decl env mid id is_covariant decl =
let ret_type_opt =
may_map (nondep_type_rec env mid) ret_type_opt
in
- (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) (* GAH: HERE TOO? *)
+ (c, List.map (nondep_type_rec env mid) tl,ret_type_opt))
cstrs)
| Type_record(lbls, rep) ->
Type_record
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 274c48b16..a8b9a1a5f 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -19,7 +19,7 @@ open Misc
open Asttypes
open Types
-module Duplicated_code = (* GAH: causes a stack overflow when encountering recursive type *)
+module Duplicated_code = (* GAH : I'm duplicating this code from ctype *)
struct
let rec free_vars ty =
let ret = ref [] in
@@ -133,7 +133,7 @@ let constructor_descrs ty_res cstrs priv =
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
- cstr_existentials = [] ; (* GAH: is this correct? *)
+ cstr_existentials = [];
cstr_args = decl;
cstr_arity = List.length decl;
cstr_tag = Cstr_exception path_exc;
@@ -170,7 +170,7 @@ let label_descrs ty_res lbls repres priv =
exception Constr_not_found
-let rec find_constr tag num_const num_nonconst = function (* GAH: is this correct? *)
+let rec find_constr tag num_const num_nonconst = function
[] ->
raise Constr_not_found
| (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
diff --git a/typing/env.ml b/typing/env.ml
index ef898cbea..f37d8b5b5 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -275,8 +275,9 @@ and find_cltype =
(* Find the manifest type associated to a type when appropriate:
- the type should be public or should have a private row,
- the type should have an associated manifest type. *)
-let find_type_expansion path env =
+let find_type_expansion ?(use_local=true) path env =
let decl = find_type path env in
+ if not use_local && decl.type_newtype then raise Not_found;
match decl.type_manifest with
| Some body when decl.type_private = Public
|| decl.type_kind <> Type_abstract
diff --git a/typing/env.mli b/typing/env.mli
index 857e4c07b..a810e3c26 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -31,7 +31,7 @@ val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_declaration
val find_cltype: Path.t -> t -> cltype_declaration
-val find_type_expansion: Path.t -> t -> type_expr list * type_expr
+val find_type_expansion: ?use_local:bool -> Path.t -> t -> type_expr list * type_expr
val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
(* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *)
diff --git a/typing/ident.ml b/typing/ident.ml
index 82603d7d5..79e74a3c4 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -95,7 +95,7 @@ and 'a data =
data: 'a;
previous: 'a data option }
-let rec map_tbl f = (* GAH: THIS IS PROBABLY TOTALLY WRONG *)
+let rec map_tbl f =
function
| Empty -> Empty
| Node (t,{ident=id;data=d;previous=p},t',i) ->
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 2f8ba110e..537f6984e 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -161,7 +161,7 @@ let report_type_mismatch first second decl ppf =
Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
- match cstrs1, cstrs2 with (* GAH: most likely wrong, but I don't know what this function does *)
+ match cstrs1, cstrs2 with
[], [] -> []
| [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)]
| (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)]
diff --git a/typing/oprint.ml b/typing/oprint.ml
index f7a0c869f..34bb192f3 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -438,7 +438,7 @@ and print_out_constr ppf (name, tyl,ret_type_opt) =
(print_typlist print_simple_out_type " *") tyl end
| Some ret_type ->
begin match tyl with
- | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type (* GAH: IS THIS CORRECT? *)
+ | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type
| _ ->
fprintf ppf "@[<2>%s :@ %a -> %a@]" name
(print_typlist print_simple_out_type " *") tyl print_simple_out_type ret_type end
diff --git a/typing/predef.ml b/typing/predef.ml
index cf8f943d7..be6e8c32c 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -96,7 +96,7 @@ let build_initial_env add_type add_exception empty_env =
and decl_bool =
{type_params = [];
type_arity = 0;
- type_kind = Type_variant(["false", []; "true", []]); (* GAH: HOW DO I DEFINE THE BASIC BOOL TYPE? *)
+ type_kind = Type_variant(["false", []; "true", []]);
type_private = Public;
type_manifest = None;
type_variance = [];
@@ -131,7 +131,7 @@ let build_initial_env add_type add_exception empty_env =
{type_params = [tvar];
type_arity = 1;
type_kind =
- Type_variant(["[]", []; "::", [tvar; type_list tvar]]); (* GAH: IS THIS CORRECT? *)
+ Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
type_private = Public;
type_manifest = None;
type_variance = [true, false, false];
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 83e893aa3..73a9f6b16 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -608,7 +608,7 @@ and tree_of_constructor (name, args) =
and tree_of_constructor_ret =
function
| None -> None
- | Some ret_type -> Some (tree_of_typexp false ret_type) (* GAH: WHY FALSE?? *)
+ | Some ret_type -> Some (tree_of_typexp false ret_type)
and tree_of_label (name, mut, arg) =
(name, mut = Mutable, tree_of_typexp false arg)
diff --git a/typing/subst.ml b/typing/subst.ml
index 435ed289d..490ae42a9 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -169,7 +169,7 @@ let type_declaration s decl =
| Type_variant cstrs ->
Type_variant(
List.map (fun (n, args) ->
- (n, List.map (typexp s) args)) (* GAH: WHAT DOES typexp DO? *)
+ (n, List.map (typexp s) args))
cstrs)
| Type_generalized_variant cstrs ->
Type_generalized_variant(
@@ -177,7 +177,7 @@ let type_declaration s decl =
let ret_type_opt =
Misc.may_map (typexp s) ret_type_opt
in
- (n, List.map (typexp s) args,ret_type_opt)) (* GAH: WHAT DOES typexp DO? *)
+ (n, List.map (typexp s) args,ret_type_opt))
cstrs)
| Type_record(lbls, rep) ->
Type_record(
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 240c3bc4c..bcbec723b 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -432,7 +432,11 @@ let check_recordpat_labels loc lbl_pat_list closed =
(* Typing of patterns *)
-let rec type_pat (env:Env.t ref) sp expected_ty =
+type type_pat_mode =
+ | Normal
+ | Inside_or
+
+let rec type_pat mode (env:Env.t ref) sp expected_ty =
let loc = sp.ppat_loc in
match sp.ppat_desc with
Ppat_any ->
@@ -442,7 +446,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
pat_type = expected_ty;
pat_env = !env }
| Ppat_var name ->
- let id = enter_variable loc name expected_ty in (* GAH : what does this do? *)
+ let id = enter_variable loc name expected_ty in
rp {
pat_desc = Tpat_var id;
pat_loc = loc;
@@ -469,7 +473,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
| _ -> assert false
end
|Ppat_alias(sq, name) ->
- let q = type_pat env sq expected_ty in (* GAH: no idea *)
+ let q = type_pat mode env sq expected_ty in
begin_def ();
let ty_var = build_as_type !env q in
end_def ();
@@ -491,7 +495,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
let spl_ann = List.map (fun p -> (p,newvar ())) spl in
let ty = newty (Ttuple(List.map snd spl_ann)) in
unify_pat_types loc !env ty expected_ty;
- let pl = List.map (fun (p,t) -> type_pat env p t) spl_ann in
+ let pl = List.map (fun (p,t) -> type_pat mode env p t) spl_ann in
rp {
pat_desc = Tpat_tuple pl;
@@ -505,7 +509,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
match (repr ty_res).desc with
| Tconstr(p,args,m) ->
ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); (* GAH: ask garrigue if this is the best way to only unify the head *)
- enforce_constraints !env ty_res;
+ enforce_constraints !env ty_res;
unify_pat_types loc !env ty_res expected_ty
| _ -> fatal_error "constructor type does not have correct description"
in
@@ -524,15 +528,19 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
raise(Error(loc, Constructor_arity_mismatch(lid,
constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) = instance_constructor ~in_pattern:(Some env) constr in
- unify_pat_types_gadt loc env ty_res expected_ty;
- let args: Typedtree.pattern list = List.map2 (fun p t -> type_pat env p t) sargs ty_args in (* GAH : might be wrong *)
+ begin match mode with
+ | Inside_or ->
+ unify_pat_types loc !env ty_res expected_ty
+ | Normal ->
+ unify_pat_types_gadt loc env ty_res expected_ty end;
+ let args: Typedtree.pattern list = List.map2 (fun p t -> type_pat mode env p t) sargs ty_args in
rp {
pat_desc = Tpat_construct(constr, args);
pat_loc = loc;
pat_type = expected_ty;
pat_env = !env }
|Ppat_variant(l, sarg) ->
- let arg = may_map (fun p -> type_pat env p (newvar())) sarg in (* GAH: this is certainly false *)
+ let arg = may_map (fun p -> type_pat mode env p (newvar())) sarg in
let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
let row = { row_fields =
[l, Reither(arg = None, arg_type, true, ref None)];
@@ -541,11 +549,11 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
row_more = newvar ();
row_fixed = false;
row_name = None } in
- unify_pat_types loc !env (newty (Tvariant row)) expected_ty; (* GAH : probably wrong *)
+ unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
rp {
pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
pat_loc = loc;
- pat_type = expected_ty; (*newty (Tvariant row); (* GAH : should probably expected_ty *)*)
+ pat_type = expected_ty;
pat_env = !env }
|Ppat_record(lid_sp_list, closed) ->
@@ -559,7 +567,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
with Unify trace ->
raise(Error(loc, Label_mismatch(lid, trace)))
end;
- let arg = type_pat env sarg ty_arg in
+ let arg = type_pat mode env sarg ty_arg in
if vars <> [] then begin
end_def ();
generalize ty_arg;
@@ -583,18 +591,18 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
let ty_elt = newvar() in
unify_pat_types loc !env (instance (Predef.type_array ty_elt)) expected_ty;
let spl_ann = List.map (fun p -> (p,newvar())) spl in
- let pl = List.map (fun (p,t) -> type_pat env p ty_elt) spl_ann in
+ let pl = List.map (fun (p,t) -> type_pat mode env p ty_elt) spl_ann in
rp {
pat_desc = Tpat_array pl;
pat_loc = loc;
pat_type = expected_ty;
pat_env = !env }
- |Ppat_or(sp1, sp2) -> (* GAH: note to self, lock it *)
+ |Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in
- let p1 = type_pat env sp1 expected_ty in
+ let p1 = type_pat Inside_or env sp1 expected_ty in
let p1_variables = !pattern_variables in
pattern_variables := initial_pattern_variables ;
- let p2 = type_pat env sp2 expected_ty in
+ let p2 = type_pat Inside_or env sp2 expected_ty in
let p2_variables = !pattern_variables in
let alpha_env =
enter_orpat_variables loc !env p1_variables p2_variables in
@@ -607,7 +615,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
|Ppat_lazy sp1 ->
let nv = newvar () in
unify_pat_types loc !env (instance (Predef.type_lazy_t nv)) expected_ty;
- let p1 = type_pat env sp1 nv in
+ let p1 = type_pat mode env sp1 nv in
rp {
pat_desc = Tpat_lazy p1;
pat_loc = loc;
@@ -616,9 +624,9 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
|Ppat_constraint(sp, sty) ->
let ty, force = Typetexp.transl_simple_type_delayed !env sty in
unify_pat_types loc !env ty expected_ty;
- let p = type_pat env sp expected_ty in (* GAH: so wrong *)
+ let p = type_pat mode env sp expected_ty in
pattern_force := force :: !pattern_force;
- p (* GAH: this pattern will have the wrong location! *)
+ p
|Ppat_type lid ->
let (r,ty) = build_or_pat !env loc lid in
unify_pat_types loc !env ty expected_ty;
@@ -627,7 +635,7 @@ let rec type_pat (env:Env.t ref) sp expected_ty =
let type_pat env sp expected_ty =
pattern_level := Some (get_current_level ());
try
- let r = type_pat env sp expected_ty in
+ let r = type_pat Normal env sp expected_ty in
pattern_level := None;
r
with
@@ -735,7 +743,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
in
reset_pattern None;
let nv = newvar() in
- let pat = type_pat (ref val_env) spat nv in (* GAH: so wrong *)
+ let pat = type_pat (ref val_env) spat nv in
List.iter (fun f -> f()) (get_ref pattern_force);
let meths = ref Meths.empty in
let vars = ref Vars.empty in
@@ -2311,7 +2319,6 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
{ pat with pat_type = instance pat.pat_type }
end else pat
in
-(* unify_pat env pat ty_arg'; (* GAH: probably wrong. what in the blazes does ty_arg' do?? *)*)
(pat, ext_env))
caselist in
@@ -2365,7 +2372,7 @@ and type_let env rec_flag spat_sexp_list scope =
begin_def();
if !Clflags.principal then begin_def ();
let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
- let nvs = List.map (fun _ -> newvar ()) spatl in (* GAH: so wrong *)
+ let nvs = List.map (fun _ -> newvar ()) spatl in
let (pat_list, new_env, force) = type_pattern_list env spatl scope nvs in
if rec_flag = Recursive then
List.iter2
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 6303fed61..15dc934c5 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -30,7 +30,7 @@ type error =
| Recursive_abbrev of string
| Definition_mismatch of type_expr * Includecore.type_mismatch list
| Constraint_failed of type_expr * type_expr
- | Unconsistent_constraint of (type_expr * type_expr) list
+ | Inconsistent_constraint of (type_expr * type_expr) list
| Type_clash of (type_expr * type_expr) list
| Parameters_differ of Path.t * type_expr * type_expr
| Null_arity_external
@@ -160,9 +160,9 @@ let transl_declaration env (name, sdecl) id =
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
- if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs) (* GAH: MIGHT BE WRONG *)
+ if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs)
> (Config.max_tag + 1) then
- raise(Error(sdecl.ptype_loc, Too_many_constructors));
+ raise(Error(sdecl.ptype_loc, Too_many_constructors)); (* GAH : decide or not to add the following code *)
(* if List.for_all (fun (_,_,x,_) -> match x with Some _ -> false | None -> true) cstrs then
Type_variant
(List.map
@@ -188,7 +188,7 @@ let transl_declaration env (name, sdecl) id =
let args = List.map (transl_simple_type env false) args in
let ret_type = may_map (transl_simple_type env false) ret_type in
restore ();
- (name, args,ret_type)) (* GAH: calling transl_simple_type with fixed=false, ask garrigue if this is ok *)
+ (name, args,ret_type))
cstrs)
in
ret
@@ -228,7 +228,7 @@ let transl_declaration env (name, sdecl) id =
List.iter
(fun (ty, ty', loc) ->
try Ctype.unify env ty ty' with Ctype.Unify tr ->
- raise(Error(loc, Unconsistent_constraint tr)))
+ raise(Error(loc, Inconsistent_constraint tr)))
cstrs;
Ctype.end_def ();
(* Add abstract row *)
@@ -254,9 +254,9 @@ let generalize_decl decl =
Type_abstract ->
()
| Type_variant v ->
- List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v (* GAH: almost sure this is wrong *)
+ List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
| Type_generalized_variant v ->
- List.iter (fun (_, tyl,ret_type_opt) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type_opt) v (* GAH: almost sure this is wrong *)
+ List.iter (fun (_, tyl,ret_type_opt) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type_opt) v
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
end;
@@ -305,9 +305,9 @@ let check_constraints env (_, sdecl) (_, decl) =
in
let pl = find_pl sdecl.ptype_kind in
List.iter
- (fun (name, tyl,ret_type_opt) -> (* GAH: again, no idea *)
+ (fun (name, tyl,ret_type_opt) ->
let styl,sret_type_opt =
- try let (_,sty,sret_type_opt (* added by me *) ,_) = List.find (fun (n,_,_,_) -> n = name) pl in sty,sret_type_opt (* GAH: lord, I have no idea what this is about *)
+ try let (_,sty,sret_type_opt,_) = List.find (fun (n,_,_,_) -> n = name) pl in sty,sret_type_opt
with Not_found -> assert false in
List.iter2
(fun sty ty ->
@@ -531,10 +531,10 @@ let whole_type decl =
match decl.type_kind with
| Type_generalized_variant tll ->
Btype.newgenty
- (Ttuple (List.map (fun (_, tl,_ (* added by me *)) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
+ (Ttuple (List.map (fun (_, tl,_) -> Btype.newgenty (Ttuple tl)) tll))
| Type_variant tll ->
Btype.newgenty
- (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
+ (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
| Type_record (ftl, _) ->
Btype.newgenty
(Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
@@ -557,7 +557,7 @@ let compute_variance_decl env check decl (required, loc) =
let tvl = tvl0 @ tvl1 in
let is_gadt =
match decl.type_kind with
- | Type_generalized_variant tll -> (* GAH: what in the blazes *)
+ | Type_generalized_variant tll ->
let ret = ref false in
List.iter
(function
@@ -577,12 +577,12 @@ let compute_variance_decl env check decl (required, loc) =
None -> assert false
| Some ty -> compute_variance env tvl true false false ty
end
- | Type_variant tll -> (* GAH: what in the blazes *)
+ | Type_variant tll ->
List.iter
(fun (_,tl) ->
List.iter (compute_variance env tvl true false false) tl)
tll
- | Type_generalized_variant tll -> (* GAH: what in the blazes *)
+ | Type_generalized_variant tll ->
List.iter
(fun (_,tl,ret_type_opt) ->
match ret_type_opt with
@@ -872,7 +872,7 @@ let transl_with_constraint env id row_path sdecl =
Ctype.unify env (transl_simple_type env false ty)
(transl_simple_type env false ty')
with Ctype.Unify tr ->
- raise(Error(loc, Unconsistent_constraint tr))) (* GAH : Unconsistent is not a word *)
+ raise(Error(loc, Inconsistent_constraint tr)))
sdecl.ptype_cstrs;
let no_row = not (is_fixed_type sdecl) in
let decl =
@@ -1008,7 +1008,7 @@ let report_error ppf = function
fprintf ppf
"@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
(Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
- | Unconsistent_constraint trace ->
+ | Inconsistent_constraint trace ->
fprintf ppf "The type constraints are not consistent.@.";
Printtyp.report_unification_error ppf trace
(fun ppf -> fprintf ppf "Type")
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index fb7b219be..f8404e6d5 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -59,7 +59,7 @@ type error =
| Recursive_abbrev of string
| Definition_mismatch of type_expr * Includecore.type_mismatch list
| Constraint_failed of type_expr * type_expr
- | Unconsistent_constraint of (type_expr * type_expr) list
+ | Inconsistent_constraint of (type_expr * type_expr) list
| Type_clash of (type_expr * type_expr) list
| Parameters_differ of Path.t * type_expr * type_expr
| Null_arity_external
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 4d5024802..59a35571d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -169,7 +169,7 @@ let merge_constraint initial_env loc sg lid constr =
List.map
(function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)
stl in
- if (List.map (fun x -> Some x) params) <> sdecl.ptype_params then raise Exit; (* GAH : ask garrigue, is this ok? *)
+ if (List.map (fun x -> Some x) params) <> sdecl.ptype_params then raise Exit; (* GAH : ask garrigue, is this ok? where does the optional return type enter? *)
lid
| _ -> raise Exit
with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 5de281366..047b60ec2 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -529,7 +529,7 @@ let globalize_used_variables env fixed =
raise (Error(loc, Type_mismatch trace)))
!r
-let transl_simple_type env fixed styp = (* GAH : ask garrigue, might be ugly *)
+let transl_simple_type env fixed styp =
univars := []; used_variables := Tbl.empty;
let typ = transl_type env (if fixed then Fixed else Extensible) styp in
globalize_used_variables env fixed ();
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-14 07:27:54 +0000