testlabl/coerce.diffs

   1 Index: typing/ctype.ml
   2 ===================================================================
   3 RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
   4 retrieving revision 1.201
   5 diff -u -r1.201 ctype.ml
   6 --- typing/ctype.ml     5 Apr 2006 02:28:13 -0000       1.201
   7 +++ typing/ctype.ml     17 May 2006 23:48:22 -0000
   8 @@ -490,6 +490,31 @@
   9      unmark_class_signature sign;
  10      Some reason
  11
  12 +(* Variant for checking principality *)
  13 +
  14 +let rec free_nodes_rec ty =
  15 +  let ty = repr ty in
  16 +  if ty.level >= lowest_level then begin
  17 +    if ty.level <= !current_level then raise Exit;
  18 +    ty.level <- pivot_level - ty.level;
  19 +    begin match ty.desc with
  20 +      Tvar ->
  21 +        raise Exit
  22 +    | Tobject (ty, _) ->
  23 +        free_nodes_rec ty
  24 +    | Tfield (_, _, ty1, ty2) ->
  25 +        free_nodes_rec ty1; free_nodes_rec ty2
  26 +    | Tvariant row ->
  27 +        let row = row_repr row in
  28 +        iter_row free_nodes_rec {row with row_bound = []};
  29 +        if not (static_row row) then free_nodes_rec row.row_more
  30 +    | _    ->
  31 +        iter_type_expr free_nodes_rec ty
  32 +    end;
  33 +  end
  34 +
  35 +let has_free_nodes ty =
  36 +  try free_nodes_rec ty; false with Exit -> true
  37
  38                              (**********************)
  39                              (*  Type duplication  *)
  40 Index: typing/ctype.mli
  41 ===================================================================
  42 RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
  43 retrieving revision 1.54
  44 diff -u -r1.54 ctype.mli
  45 --- typing/ctype.mli    5 Apr 2006 02:28:13 -0000       1.54
  46 +++ typing/ctype.mli    17 May 2006 23:48:22 -0000
  47 @@ -228,6 +228,9 @@
  48  val closed_class:
  49          type_expr list -> class_signature -> closed_class_failure option
  50          (* Check whether all type variables are bound *)
  51 +val has_free_nodes: type_expr -> bool
  52 +        (* Check whether there are free type variables, or nodes with
  53 +           level lower or equal to !current_level *)
  54
  55  val unalias: type_expr -> type_expr
  56  val signature_of_class_type: class_type -> class_signature
  57 Index: typing/typecore.ml
  58 ===================================================================
  59 RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
  60 retrieving revision 1.181
  61 diff -u -r1.181 typecore.ml
  62 --- typing/typecore.ml  16 Apr 2006 23:28:22 -0000      1.181
  63 +++ typing/typecore.ml  17 May 2006 23:48:22 -0000
  64 @@ -1183,12 +1183,29 @@
  65              let (ty', force) =
  66                Typetexp.transl_simple_type_delayed env sty'
  67              in
  68 +            if !Clflags.principal then begin_def ();
  69              let arg = type_exp env sarg in
  70 +            let has_fv =
  71 +              if !Clflags.principal then begin
  72 +                end_def ();
  73 +                let b = has_free_nodes arg.exp_type in
  74 +                Ctype.unify env arg.exp_type (newvar ());
  75 +                b
  76 +              end else
  77 +                free_variables arg.exp_type <> []
  78 +            in
  79              begin match arg.exp_desc, !self_coercion, (repr ty').desc with
  80                Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
  81                Tconstr(path',_,_) when Path.same path path' ->
  82                  r := sexp.pexp_loc :: !r;
  83                  force ()
  84 +            | _ when not has_fv ->
  85 +                begin try
  86 +                  let force' = subtype env arg.exp_type ty' in
  87 +                  force (); force' ()
  88 +                with Subtype (tr1, tr2) ->
  89 +                  raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
  90 +                end
  91              | _ ->
  92                  let ty, b = enlarge_type env ty' in
  93                  force ();