ajout du champ cty_inher dans Types.class_declaration

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

8 files changed, 60 insertions, 29 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 3be8d5ac5..0bd9bd5aa 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 87997a330..f4e949d97 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 17eb73d3e..1aa9a5dce 100644
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -89,6 +89,7 @@ let simpl_class_type t =
                                                   Types.desc = Types.Tobject (tnil, ref None) };
                                Types.cty_vars = Types.Vars.empty ;
                                Types.cty_concr = Types.Concr.empty ;
+                               Types.cty_inher = []
                              }
     | Types.Tcty_fun (l, texp, ct) ->
         let new_ct = iter ct in
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 106ad389b..9ff854cdb 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -821,7 +821,9 @@ let instance_class params cty =
           {cty_self = copy sign.cty_self;
            cty_vars =
              Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
-           cty_concr = sign.cty_concr}
+           cty_concr = sign.cty_concr;
+           cty_inher =
+             List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
     | Tcty_fun (l, ty, cty) ->
         Tcty_fun (l, copy ty, copy_class_type cty)
   in
@@ -3177,7 +3179,10 @@ let nondep_class_signature env id sign =
     cty_vars =
       Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
         sign.cty_vars;
-    cty_concr = sign.cty_concr }
+    cty_concr = sign.cty_concr;
+    cty_inher =
+      List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+        sign.cty_inher }
 
 let rec nondep_class_type env id =
   function
diff --git a/typing/subst.ml b/typing/subst.ml
index 438adb524..1ce87c9c8 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -183,7 +183,11 @@ let type_declaration s decl =
 let class_signature s sign =
   { cty_self = typexp s sign.cty_self;
     cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
-    cty_concr = sign.cty_concr }
+    cty_concr = sign.cty_concr;
+    cty_inher =
+      List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+        sign.cty_inher
+  }
 
 let rec class_type s =
   function
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index a0f9dd64e..591393959 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -88,9 +88,10 @@ let rec generalize_class_type =
     Tcty_constr (_, params, cty) ->
       List.iter Ctype.generalize params;
       generalize_class_type cty
-  | Tcty_signature {cty_self = sty; cty_vars = vars } ->
+  | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
       Ctype.generalize sty;
-      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
+      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
+      List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
   | Tcty_fun (_, ty, cty) ->
       Ctype.generalize ty;
       generalize_class_type cty
@@ -172,7 +173,9 @@ let rec limited_generalize rv =
   | Tcty_signature sign ->
       Ctype.limited_generalize rv sign.cty_self;
       Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
-        sign.cty_vars
+        sign.cty_vars;
+      List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+        sign.cty_inher
   | Tcty_fun (_, ty, cty) ->
       Ctype.limited_generalize rv ty;
       limited_generalize rv cty
@@ -272,10 +275,15 @@ let make_method cl_num expr =
 
 (*******************************)
 
-let rec class_type_field env self_type meths (val_sig, concr_meths) =
+let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
   function
     Pctf_inher sparent ->
       let parent = class_type env sparent in
+      let inher =
+        match parent with
+          Tcty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
       let (cl_sig, concr_meths, _) =
         inheritance self_type env concr_meths Concr.empty sparent.pcty_loc
           parent
@@ -285,7 +293,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
           (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
           cl_sig.cty_vars val_sig
       in
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
   | Pctf_val (lab, mut, sty_opt, loc) ->
       let (mut, ty) =
@@ -299,19 +307,19 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
         | Some sty ->
             mut, transl_simple_type env false sty
       in
-      (Vars.add lab (mut, ty) val_sig, concr_meths)
+      (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
 
   | Pctf_virt (lab, priv, sty, loc) ->
       declare_method env meths self_type lab priv sty loc;
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
   | Pctf_meth (lab, priv, sty, loc)  ->
       declare_method env meths self_type lab priv sty loc;
-      (val_sig, Concr.add lab concr_meths)
+      (val_sig, Concr.add lab concr_meths, inher)
 
   | Pctf_cstr (sty, sty', loc) ->
       type_constraint env sty sty' loc;
-      (val_sig, concr_meths)
+      (val_sig, concr_meths, inher)
 
 and class_signature env sty sign =
   let meths = ref Meths.empty in
@@ -328,15 +336,16 @@ and class_signature env sty sign =
   end;
   
   (* Class type fields *)
-  let (val_sig, concr_meths) =
+  let (val_sig, concr_meths, inher) =
     List.fold_left (class_type_field env self_type meths)
-      (Vars.empty, Concr.empty)
+      (Vars.empty, Concr.empty, [])
       sign
   in
   
   {cty_self = self_type;
    cty_vars = val_sig;
-   cty_concr = concr_meths }
+   cty_concr = concr_meths;
+   cty_inher = inher}
 
 and class_type env scty =
   match scty.pcty_desc with
@@ -376,10 +385,16 @@ and class_type env scty =
 module StringSet = Set.Make(struct type t = string let compare = compare end)
 
 let rec class_field cl_num self_type meths vars
-    (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals) =
+    (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+     inh_vals, inher) =
   function
     Pcf_inher (sparent, super) ->
       let parent = class_expr cl_num val_env par_env sparent in
+      let inher =
+        match parent.cl_type with
+          Tcty_constr (p, tl, _) -> (p, tl) :: inher
+        | _ -> inher
+      in
       let (cl_sig, concr_meths, warn_meths) =
         inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc
           parent.cl_type
@@ -417,7 +432,7 @@ let rec class_field cl_num self_type meths vars
       in
       (val_env, met_env, par_env,
        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_val (lab, mut, sexp, loc) ->
       if StringSet.mem lab inh_vals then
@@ -435,12 +450,13 @@ let rec class_field cl_num self_type meths vars
         enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
       in
       (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_virt (lab, priv, sty, loc) ->
       virtual_method val_env meths self_type lab priv sty loc;
       let warn_meths = Concr.remove lab warn_meths in
-      (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+      (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+       inh_vals, inher)
 
   | Pcf_meth (lab, priv, expr, loc)  ->
       let (_, ty) =
@@ -483,11 +499,12 @@ let rec class_field cl_num self_type meths vars
           Cf_meth (lab, texp)
         end in
       (val_env, met_env, par_env, field::fields,
-       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals)
+       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
 
   | Pcf_cstr (sty, sty', loc) ->
       type_constraint val_env sty sty' loc;
-      (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+      (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+       inh_vals, inher)
 
   | Pcf_let (rec_flag, sdefs, loc) ->
       let (defs, val_env) =
@@ -517,7 +534,7 @@ let rec class_field cl_num self_type meths vars
           ([], met_env, par_env)
       in
       (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
   | Pcf_init expr ->
       let expr = make_method cl_num expr in
@@ -534,7 +551,7 @@ let rec class_field cl_num self_type meths vars
           Cf_init texp
         end in
       (val_env, met_env, par_env, field::fields,
-       concr_meths, warn_meths, inh_vals)
+       concr_meths, warn_meths, inh_vals, inher)
 
 and class_structure cl_num final val_env met_env loc (spat, str) =
   (* Environment for substructures *)
@@ -575,17 +592,18 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
   end;
 
   (* Typing of class fields *)
-  let (_, _, _, fields, concr_meths, _, _) =
+  let (_, _, _, fields, concr_meths, _, _, inher) =
     List.fold_left (class_field cl_num self_type meths vars)
       (val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
-       StringSet.empty)
+       StringSet.empty, [])
       str
   in
   Ctype.unify val_env self_type (Ctype.newvar ());
   let sign =
     {cty_self = public_self;
      cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-     cty_concr = concr_meths } in
+     cty_concr = concr_meths;
+     cty_inher = inher} in
   let methods = get_methods self_type in
   let priv_meths =
     List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
@@ -948,7 +966,8 @@ let rec initial_env define_class approx
     Tcty_signature
       { cty_self = Ctype.newvar ();
         cty_vars = Vars.empty;
-        cty_concr = Concr.empty }
+        cty_concr = Concr.empty;
+        cty_inher = [] }
   in
   let dummy_class =
     {cty_params = [];             (* Dummy value *)
diff --git a/typing/types.ml b/typing/types.ml
index 81efda3b8..a697256fe 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -157,7 +157,8 @@ type class_type =
 and class_signature =
   { cty_self: type_expr;
     cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-    cty_concr: Concr.t }
+    cty_concr: Concr.t;
+    cty_inher: (Path.t * type_expr list) list }
 
 type class_declaration =
   { cty_params: type_expr list;
diff --git a/typing/types.mli b/typing/types.mli
index 77164cd5d..c9235b09c 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -159,7 +159,8 @@ type class_type =
 and class_signature =
   { cty_self: type_expr;
     cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-    cty_concr: Concr.t }
+    cty_concr: Concr.t;
+    cty_inher: (Path.t * type_expr list) list }
 
 type class_declaration =
   { cty_params: type_expr list;