diff options
| -rw-r--r-- | testlabl/coerce.diffs | 93 |
1 files changed, 93 insertions, 0 deletions
diff --git a/testlabl/coerce.diffs b/testlabl/coerce.diffs new file mode 100644 index 000000000..e90e1fc93 --- /dev/null +++ b/testlabl/coerce.diffs @@ -0,0 +1,93 @@ +Index: typing/ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.201 +diff -u -r1.201 ctype.ml +--- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201 ++++ typing/ctype.ml 17 May 2006 23:48:22 -0000 +@@ -490,6 +490,31 @@ + unmark_class_signature sign; + Some reason + ++(* Variant for checking principality *) ++ ++let rec free_nodes_rec ty = ++ let ty = repr ty in ++ if ty.level >= lowest_level then begin ++ if ty.level <= !current_level then raise Exit; ++ ty.level <- pivot_level - ty.level; ++ begin match ty.desc with ++ Tvar -> ++ raise Exit ++ | Tobject (ty, _) -> ++ free_nodes_rec ty ++ | Tfield (_, _, ty1, ty2) -> ++ free_nodes_rec ty1; free_nodes_rec ty2 ++ | Tvariant row -> ++ let row = row_repr row in ++ iter_row free_nodes_rec {row with row_bound = []}; ++ if not (static_row row) then free_nodes_rec row.row_more ++ | _ -> ++ iter_type_expr free_nodes_rec ty ++ end; ++ end ++ ++let has_free_nodes ty = ++ try free_nodes_rec ty; false with Exit -> true + + (**********************) + (* Type duplication *) +Index: typing/ctype.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v +retrieving revision 1.54 +diff -u -r1.54 ctype.mli +--- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54 ++++ typing/ctype.mli 17 May 2006 23:48:22 -0000 +@@ -228,6 +228,9 @@ + val closed_class: + type_expr list -> class_signature -> closed_class_failure option + (* Check whether all type variables are bound *) ++val has_free_nodes: type_expr -> bool ++ (* Check whether there are free type variables, or nodes with ++ level lower or equal to !current_level *) + + val unalias: type_expr -> type_expr + val signature_of_class_type: class_type -> class_signature +Index: typing/typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.181 +diff -u -r1.181 typecore.ml +--- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181 ++++ typing/typecore.ml 17 May 2006 23:48:22 -0000 +@@ -1183,12 +1183,29 @@ + let (ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in ++ if !Clflags.principal then begin_def (); + let arg = type_exp env sarg in ++ let has_fv = ++ if !Clflags.principal then begin ++ end_def (); ++ let b = has_free_nodes arg.exp_type in ++ Ctype.unify env arg.exp_type (newvar ()); ++ b ++ end else ++ free_variables arg.exp_type <> [] ++ in + begin match arg.exp_desc, !self_coercion, (repr ty').desc with + Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, + Tconstr(path',_,_) when Path.same path path' -> + r := sexp.pexp_loc :: !r; + force () ++ | _ when not has_fv -> ++ begin try ++ let force' = subtype env arg.exp_type ty' in ++ force (); force' () ++ with Subtype (tr1, tr2) -> ++ raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) ++ end + | _ -> + let ty, b = enlarge_type env ty' in + force (); |