allow coercions from self to own class (when safe!)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3978 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 76 insertions, 16 deletions

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 785a94ddc..5d1958923 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -44,6 +44,7 @@ type error =
   | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
   | Make_nongen_seltype of type_expr
   | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
 
 exception Error of Location.t * error
 
@@ -867,9 +868,21 @@ let class_infos define_class kind
     with Already_bound ->
       raise(Error(snd cl.pci_params, Repeated_parameter))
   in
+
+  (* Allow self coercions (only for class declarations) *)
+  let coercion_locs = ref [] in
   
   (* Type the class expression *)
-  let (expr, typ) = kind env cl.pci_expr in
+  let (expr, typ) =
+    try
+      Typecore.self_coercion :=
+        (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+      let res = kind env cl.pci_expr in
+      Typecore.self_coercion := List.tl !Typecore.self_coercion;
+      res
+    with exn ->
+      Typecore.self_coercion := []; raise exn
+  in
   
   Ctype.end_def ();
   
@@ -926,7 +939,7 @@ let class_infos define_class kind
       raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
     end
   end;
-  
+
   (* Type of the class constructor *)
   begin try
     Ctype.unify env (constructor_type constr obj_type) constr_type
@@ -1001,12 +1014,12 @@ let class_infos define_class kind
      type_variance = List.map (fun _ -> true, true) cl_params}
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-    arity, pub_meths, expr) :: res,
+    arity, pub_meths, List.rev !coercion_locs, expr) :: res,
    env)
 
 let final_decl define_class
     (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, expr) =
+     arity, pub_meths, coe, expr) =
 
   List.iter Ctype.generalize clty.cty_params;
   generalize_class_type clty.cty_type;
@@ -1043,11 +1056,11 @@ let final_decl define_class
   end;
 
   (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-   arity, pub_meths, expr, (cl.pci_variance, cl.pci_loc))
+   arity, pub_meths, coe, expr, (cl.pci_variance, cl.pci_loc))
 
 let extract_type_decls
     (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, expr, required) decls =
+     arity, pub_meths, coe, expr, required) decls =
   ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
 
 let rec compact = function
@@ -1057,18 +1070,46 @@ let rec compact = function
 
 let merge_type_decls
     (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
-     arity, pub_meths, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+     arity, pub_meths, coe, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
   (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-   arity, pub_meths, expr)
+   arity, pub_meths, coe, expr)
 
 let final_env define_class env
     (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, expr) =
+     arity, pub_meths, coe, expr) =
   Env.add_type obj_id obj_abbr (
   Env.add_type cl_id cl_abbr (
   Env.add_cltype ty_id cltydef (
   if define_class then Env.add_class id clty env else env)))
 
+(* Check that #c is coercible to c if there is a self-coercion *)
+let check_coercions env
+    (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+     arity, pub_meths, coercion_locs, expr) =
+  begin match coercion_locs with [] -> ()
+  | loc :: _ ->
+      let cl_ty, obj_ty =
+        match cl_abbr.type_manifest, obj_abbr.type_manifest with
+          Some cl_ab, Some obj_ab ->
+            let cl_params, cl_ty =
+              Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
+            and obj_params, obj_ty =
+              Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
+            in
+            List.iter2 (Ctype.unify env) cl_params obj_params;
+            cl_ty, obj_ty
+        | _ -> assert false
+      in
+      begin try Ctype.subtype env cl_ty obj_ty ()
+      with Ctype.Subtype (tr1, tr2) ->
+        raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2)))
+      end;
+      if not (Ctype.opened_object cl_ty) then
+        raise(Error(loc, Cannot_coerce_self obj_ty))
+  end;
+  (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+   arity, pub_meths, expr)
+
 (*******************************)
 
 let type_classes define_class approx kind env cls =
@@ -1094,6 +1135,7 @@ let type_classes define_class approx kind env cls =
   let decls = Typedecl.compute_variance_decls env decls in
   let res = List.map2 merge_type_decls res (compact decls) in
   let env = List.fold_left (final_env define_class) env res in
+  let res = List.map (check_coercions env) res in
   (res, env)
 
 let class_num = ref 0
@@ -1118,7 +1160,7 @@ let class_type_declarations env cls =
   in
   (List.map
      (function
-          (_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) ->
+       (_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) ->
         (ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr))
      decl,
    env)
@@ -1250,3 +1292,9 @@ let report_error ppf = function
         "@[The type of this class,@ %a,@ \
            contains type variables that cannot be generalized@]"
         (Printtyp.class_declaration id) clty
+  | Cannot_coerce_self ty ->
+      fprintf ppf
+        "@[The type of self cannot be coerced to@ \
+           the type of the current class:@ %a.@.\
+           Some occurences are contravariant@]"
+        Printtyp.type_scheme ty
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index bee4b21e1..577c0a6a9 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -62,6 +62,7 @@ type error =
   | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
   | Make_nongen_seltype of type_expr
   | Non_generalizable_class of Ident.t * Types.class_declaration
+  | Cannot_coerce_self of type_expr
 
 exception Error of Location.t * error
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 7610be73f..1685238c9 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -658,6 +658,8 @@ let rec type_approx env sexp =
       end
   | _ -> newvar ()
 
+let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
+
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
@@ -905,12 +907,19 @@ let rec type_exp env sexp =
             let (ty', force) =
               Typetexp.transl_simple_type_delayed env sty'
             in
-            let ty = enlarge_type env ty' in
-            force ();
             let arg = type_exp env sarg in
-            begin try Ctype.unify env arg.exp_type ty with Unify trace ->
-              raise(Error(sarg.pexp_loc,
-                    Coercion_failure(ty', full_expand env ty', trace)))
+            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 ()
+            | _ ->
+                let ty = enlarge_type env ty' in
+                force ();
+                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
+                  raise(Error(sarg.pexp_loc,
+                        Coercion_failure(ty', full_expand env ty', trace)))
+                end
             end;
             (arg, ty')
         | (Some sty, Some sty') ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 667cf657a..a8779ac71 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -53,6 +53,8 @@ val option_some: Typedtree.expression -> Typedtree.expression
 val option_none: type_expr -> Location.t -> Typedtree.expression
 val extract_option_type: Env.t -> type_expr -> type_expr
 
+val self_coercion : (Path.t * Location.t list ref) list ref
+
 type error =
     Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
diff --git a/utils/config.mlp b/utils/config.mlp
index 201fd4b5d..c8411052a 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "3.03 ALPHA+2 (2001-10-29)"
+let version = "3.03 ALPHA+3 (2001-11-05)"
 
 let standard_library =
   try