Correction bug dans la determination des representations de records (e.g. {lbl=t} avec type t = float)

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

typing/ctype.ml

@@ -948,6 +948,8 @@ let _ = try_expand_head' := try_expand_head
 let rec expand_head env ty =
   try try_expand_head env ty with Cannot_expand -> repr ty
 
+let _ = Env.expand_head := expand_head
+
 (* Make sure that the type parameters of the type constructor [ty]
    respect the type constraints *)
 let enforce_constraints env ty =

typing/datarepr.ml

@@ -58,18 +58,19 @@ let dummy_label =
   { lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
     lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular }
 
-(* Cannot call ctype.repres here *)
+(* We cannot call Ctype.expand_head directly here, so we rely
+   on label_descrs being passed the partial application
+   (Ctype.expand_head current_env). *)
 
-let rec is_float = 
-  function
-    {desc = Tlink ty} -> is_float ty
-  | {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
+let is_float expand_fn ty =
+  match expand_fn ty with
+    {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
   | _ -> false
 
-let label_descrs ty_res lbls =
+let label_descrs expand_fn ty_res lbls_init lbls =
   let all_labels = Array.create (List.length lbls) dummy_label in
   let repres =
-    if List.for_all (fun (name, flag, ty) -> is_float ty) lbls
+    if List.for_all (fun (name, flag, ty) -> is_float expand_fn ty) lbls_init
     then Record_float
     else Record_regular in
   let rec describe_labels num = function

typing/datarepr.mli

@@ -24,7 +24,9 @@ val constructor_descrs:
 val exception_descr:
   Path.t -> type_expr list -> constructor_description
 val label_descrs:
-  type_expr -> (string * mutable_flag * type_expr) list ->
+  (type_expr -> type_expr) -> type_expr ->
+  (string * mutable_flag * type_expr) list ->
+  (string * mutable_flag * type_expr) list ->
     (string * label_description) list
 
 exception Constr_not_found

typing/env.ml

@@ -147,6 +147,11 @@ let check_modtype_inclusion =
   ref ((fun env mty1 mty2 -> fatal_error "Env.include_modtypes") :
        t -> module_type -> module_type -> unit)
 
+let expand_head =
+  (* to be filled with Ctype.expand_head *)
+  ref ((fun env ty -> fatal_error "Env.expand_head") :
+       t -> type_expr -> type_expr)
+
 (* Lookup by identifier *)
 
 let rec find_module_descr path env =
@@ -366,12 +371,23 @@ let constructors_of_type ty_path decl =
 
 (* Compute label descriptions *)
 
-let labels_of_type ty_path decl =
-  match decl.type_kind with
-    Type_record labels ->
+let labels_of_type env ty_path decl decl' =
+  match (decl.type_kind, decl'.type_kind) with
+    (Type_record labels, Type_record labels') ->
       Datarepr.label_descrs
+        (!expand_head env)
+(*
+          begin match ty with
+            {desc=Tconstr(p, _, _)} ->
+              print_string "Expanding ";
+              print_string (Path.name p);
+              print_newline()
+          | _ -> ()
+          end;
+          !expand_head env ty) *)
+
         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
-        labels
+        labels labels'
   | _ -> []
 
 (* Given a signature and a root path, prefix all idents in the signature
@@ -448,7 +464,8 @@ let rec components_of_module env sub path mty =
             List.iter
               (fun (name, descr) ->
                 c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
-              (labels_of_type path decl')
+              (labels_of_type !env path decl decl'); 
+            env := store_type_infos id path decl !env
         | Tsig_exception(id, decl) ->
             let decl' = Subst.exception_declaration sub decl in
             let cstr = Datarepr.exception_descr path decl' in
@@ -520,7 +537,7 @@ and store_type id path info env =
       List.fold_right
         (fun (name, descr) labels ->
           Ident.add (Ident.create name) descr labels)
-        (labels_of_type path info)
+        (labels_of_type env path info info)
         env.labels;
     types = Ident.add id (path, info) env.types;
     modules = env.modules;
@@ -530,6 +547,23 @@ and store_type id path info env =
     cltypes = env.cltypes;
     summary = Env_type(env.summary, id, info) }
 
+and store_type_infos id path info env =
+  (* Simplified version of store_type that doesn't compute and store
+     constructor and label infos, but simply record the arity and
+     manifest-ness of the type.  Used in components_of_module to
+     keep track of type abbreviations (e.g. type t = float) in the
+     computation of label representations. *)
+  { values = env.values;
+    constrs = env.constrs;
+    labels = env.labels;
+    types = Ident.add id (path, info) env.types;
+    modules = env.modules;
+    modtypes = env.modtypes;
+    components = env.components;
+    classes = env.classes;
+    cltypes = env.cltypes;
+    summary = Env_type(env.summary, id, info) }
+
 and store_exception id path decl env =
   { values = env.values;
     constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;

typing/env.mli

@@ -119,6 +119,9 @@ exception Error of error
 
 val report_error: error -> unit
 
-(* Forward declaration to break mutual recursion with includemod. *)
-
+(* Forward declaration to break mutual recursion with Includemod. *)
 val check_modtype_inclusion: (t -> module_type -> module_type -> unit) ref
+
+(* Forward declaration to break mutual recursion with Ctype. *)
+val expand_head: (t -> type_expr -> type_expr) ref
+