Bugs divers

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

typing/ctype.ml

@@ -334,32 +334,39 @@ let closed_schema ty =
     unmark_type ty;
     false
 
-exception Non_closed of type_expr
+exception Non_closed of type_expr * bool
 
 let free_variables = ref []
 
-let rec free_vars_rec ty =
+let rec free_vars_rec real ty =
   let ty = repr ty in
   if ty.level >= lowest_level then begin
+    ty.level <- pivot_level - ty.level;
     begin match ty.desc with
-      Tvar -> free_variables := ty :: !free_variables
-    | _    -> ()
+      Tvar ->
+        free_variables := (ty, real) :: !free_variables
+    | Tobject(ty, {contents = Some (_, p)}) ->
+        free_vars_rec false ty; List.iter (free_vars_rec true) p
+    | Tobject (ty, _) ->
+        free_vars_rec false ty
+    | Tfield (_, _, ty1, ty2) ->
+        free_vars_rec true ty1; free_vars_rec false ty2
+    | _    ->
+        iter_type_expr (free_vars_rec true) ty
     end;
-    ty.level <- pivot_level - ty.level;
-    iter_type_expr free_vars_rec ty
   end
 
 let free_vars ty =
   free_variables := [];
-  free_vars_rec ty;
+  free_vars_rec true ty;
   let res = !free_variables in
   free_variables := [];
   res
 
 let rec closed_type ty =
   match free_vars ty with
-      []   -> ()
-  | v :: _ -> raise (Non_closed v)
+      []           -> ()
+  | (v, real) :: _ -> raise (Non_closed (v, real))
 
 let closed_parameterized_type params ty =
   List.iter mark_type params;
@@ -390,13 +397,13 @@ let closed_type_decl decl =
     end;
     unmark_type_decl decl;
     None
-  with Non_closed ty ->
+  with Non_closed (ty, _) ->
     unmark_type_decl decl;
     Some ty
 
 type closed_class_failure =
-    CC_Method of type_expr * string * type_expr
-  | CC_Value of type_expr * string * type_expr
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
 
 exception Failure of closed_class_failure
 
@@ -409,31 +416,19 @@ let closed_class params sign =
     (fun (lab, _, ty) -> if lab = "*dummy method*" then mark_type ty)
     fields;
   try
-(*
-    List.iter
-      (fun (lab, kind, ty) ->
-        try closed_type ty with Non_closed ty0 ->
-          raise (Failure (CC_Method (ty0, lab, ty))))
-      fields;
-    Vars.iter
-      (fun lab (_, ty) ->
-        try closed_type ty with Non_closed ty0 ->
-          raise (Failure (CC_Value (ty0, lab, ty))))
-      sign.cty_vars;
-*)
     mark_type_node (repr sign.cty_self);
     List.iter
       (fun (lab, kind, ty) ->
         if field_kind_repr kind = Fpresent then
-        try closed_type ty with Non_closed ty0 ->
-          raise (Failure (CC_Method (ty0, lab, ty))))
+        try closed_type ty with Non_closed (ty0, real) ->
+          raise (Failure (CC_Method (ty0, real, lab, ty))))
       fields;
     mark_type_params (repr sign.cty_self);
     List.iter unmark_type params;
     unmark_class_signature sign;
     None
   with Failure reason ->
-    mark_type sign.cty_self;
+    mark_type_params (repr sign.cty_self);
     List.iter unmark_type params;
     unmark_class_signature sign;
     Some reason
@@ -855,18 +850,26 @@ let expand_abbrev env ty =
       begin match find_expans path !abbrev with
         Some ty ->
           if level <> generic_level then
-            update_level env level ty;
+            begin try
+              update_level env level ty
+            with Unify _ ->
+              (* XXX This should not happen.
+                 However, levels are not correctly restored after a
+                 typing error *)
+              ()
+            end;
           ty
       | None ->
           let (params, body) =
             try Env.find_type_expansion path env with Not_found ->
               raise Cannot_expand
           in
-          begin try
+(*          begin try *)
             subst env level abbrev (Some ty) params args body
-          with Unify _ ->
+(*          with Unify _ ->
             raise Cannot_expand
           end
+*)
       end
   | _ ->
       assert false
@@ -1743,7 +1746,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
           (Fvar _, Fvar _)
         | (Fpresent, Fpresent) -> err
         | (Fvar _, Fpresent)   -> CM_Private_method lab::err
-        | (Fpresent, Fabsent)  -> CM_Public_method lab::err
+        | (Fpresent, Fvar _)  -> CM_Public_method lab::err
         | _                    -> assert false)
       pairs error
   in

typing/ctype.mli

@@ -114,6 +114,7 @@ val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
         (* A special case of unification (with {m : 'a; 'b}). *)
 val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
         (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur: Env.t -> type_expr -> type_expr -> unit
 val filter_self_method:
         Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
         type_expr -> Ident.t * type_expr
@@ -178,8 +179,8 @@ val closed_schema: type_expr -> bool
 
 val closed_type_decl: type_declaration -> type_expr option
 type closed_class_failure =
-    CC_Method of type_expr * string * type_expr
-  | CC_Value of type_expr * string * type_expr
+    CC_Method of type_expr * bool * string * type_expr
+  | CC_Value of type_expr * bool * string * type_expr
 val closed_class:
         type_expr list -> class_signature -> closed_class_failure option
         (* Check whether all type variables are bound *)

typing/printtyp.ml

@@ -454,10 +454,12 @@ let rec prepare_class_type =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
       List.iter (fun (_, _, ty) -> mark_loops ty) fields;
+(*
       begin match sty.desc with
         Tobject (fi, _) -> mark_loops fi
       | _               -> assert false
       end;
+*)
       Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
   | Tcty_fun (ty, cty) ->
       mark_loops ty;

typing/typeclass.ml

@@ -1062,6 +1062,7 @@ let report_error = function
   | Unbound_val lab ->
       print_string "Unbound instance variable "; print_string lab
   | Unbound_type_var (printer, reason) ->
+      Printtyp.reset ();
       open_vbox 0;
       open_box 0;
       print_string "Some type variables are unbound in this type:";
@@ -1071,26 +1072,33 @@ let report_error = function
       print_space ();
       open_box 0;
       begin match reason with
-        Ctype.CC_Method (ty0, lab, ty) ->
-    (* XXX Cas ou une row variable n'est pas liee... *)
+        Ctype.CC_Method (ty0, real, lab, ty) ->
           Printtyp.reset ();
           Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
           print_string "The method"; print_space ();
           print_string lab; print_space ();
           print_string "has type"; print_break 1 2;
           Printtyp.type_expr ty; print_space ();
           print_string "where"; print_space ();
-          Printtyp.type_expr ty0; print_space ();
+          if real then begin
+            Printtyp.type_expr ty0; print_space ()
+          end else begin
+            print_string ".."; print_space ()
+          end;
           print_string "is unbound"
-      | Ctype.CC_Value (ty0, lab, ty) ->
+      | Ctype.CC_Value (ty0, real, lab, ty) ->
           Printtyp.reset ();
           Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
           print_string "The instance variable"; print_space ();
           print_string lab; print_space ();
           print_string "has type"; print_break 1 2;
           Printtyp.type_expr ty; print_space ();
           print_string "where"; print_space ();
-          Printtyp.type_expr ty0; print_space ();
+          if real then begin
+            Printtyp.type_expr ty0; print_space ()
+          end else begin
+            print_string ".."; print_space ()
+          end;
           print_string "is unbound"
       end;
       close_box ();

typing/typecore.mli

@@ -29,11 +29,11 @@ val type_let:
 val type_expression:
         Env.t -> Parsetree.expression -> Typedtree.expression
 val type_class_arg_pattern:
-        Env.t -> Env.t -> Parsetree.pattern ->
+        string -> Env.t -> Env.t -> Parsetree.pattern ->
         Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
         Env.t * Env.t
 val type_self_pattern:
-        Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        string -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
         Typedtree.pattern *
         (Ident.t * type_expr) Meths.t ref *
         (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *

typing/types.ml

@@ -58,11 +58,13 @@ type value_description =
 and value_kind =
     Val_reg                             (* Regular value *)
   | Val_prim of Primitive.description   (* Primitive *)
-  | Val_ivar of mutable_flag            (* Instance variable (mutable ?) *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
-                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref
+                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
+                string
                                         (* Self *)
-  | Val_anc of (string * Ident.t) list  (* Ancestor *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
   | Val_unbound                         (* Unbound variable *)
 
 (* Constructor descriptions *)

typing/types.mli

@@ -56,11 +56,13 @@ type value_description =
 and value_kind =
     Val_reg                             (* Regular value *)
   | Val_prim of Primitive.description   (* Primitive *)
-  | Val_ivar of mutable_flag            (* Instance variable (mutable ?) *)
+  | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
-                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref
+                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
+                string
                                         (* Self *)
-  | Val_anc of (string * Ident.t) list  (* Ancestor *)
+  | Val_anc of (string * Ident.t) list * string
+                                        (* Ancestor *)
   | Val_unbound                         (* Unbound variable *)
 
 (* Constructor descriptions *)

typing/typetexp.ml

@@ -40,7 +40,7 @@ let aliases        = ref (Tbl.empty : (string, type_expr) Tbl.t)
 let saved_type_variables = ref ([] : (string, type_expr) Tbl.t list)
 
 let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
-let bindings       = ref ([] : (type_expr * type_expr) list)
+let bindings       = ref ([] : (Location.t * type_expr * type_expr) list)
         (* These two variables are used for the "delayed" policy. *)
 
 let reset_type_variables () =
@@ -103,7 +103,7 @@ let rec transl_type env policy styp =
               let v1 = Tbl.find name !type_variables in
               let v2 = new_global_var () in
               used_variables := Tbl.add name v2 !used_variables;
-              bindings := (v1, v2)::!bindings;
+              bindings := (styp.ptyp_loc, v1, v2)::!bindings;
               v2
             with Not_found ->
               let v = new_global_var () in
@@ -130,7 +130,10 @@ let rec transl_type env policy styp =
       let args = List.map (transl_type env policy) stl in
       let params = List.map (fun _ -> Ctype.newvar ()) args in
       let cstr = newty (Tconstr(path, params, ref Mnil)) in
-      let _ = Ctype.expand_head env cstr in
+      let _ =
+        try Ctype.expand_head env cstr with Unify trace ->
+          raise (Error(styp.ptyp_loc, Type_mismatch trace))
+      in
       List.iter2
         (fun (sty, ty) ty' ->
            try unify env ty ty' with Unify trace ->
@@ -157,7 +160,12 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let ty = Ctype.expand_head env (newty (Tconstr(path, args, ref Mnil))) in
+      let ty =
+        try
+          Ctype.expand_head env (newty (Tconstr(path, args, ref Mnil)))
+        with Unify trace ->
+          raise (Error(styp.ptyp_loc, Type_mismatch trace))
+      in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
         (fun (sty, ty') ty ->
@@ -206,8 +214,12 @@ let transl_simple_type_delayed env styp =
   used_variables := Tbl.empty;
   bindings := [];
   (typ,
-(* XXX L'unification peut echouer... *)
-   function () -> List.iter (function (t1, t2) -> unify env t1 t2) b)
+   function () ->
+     List.iter
+       (function (loc, t1, t2) ->
+          try unify env t1 t2 with Unify trace ->
+            raise (Error(loc, Type_mismatch trace)))
+       b)
 
 let transl_type_scheme env styp =
   reset_type_variables();
@@ -246,7 +258,7 @@ let report_error = function
   | Type_mismatch trace ->
       Printtyp.unification_error true trace
         (function () ->
-           print_string "This type parameter")
+           print_string "This type")
         (function () ->
            print_string "should be an instance of type")
   | Alias_type_mismatch trace ->