update #show patch to access environment in toplevel

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

1 files changed, 0 insertions, 403 deletions

diff --git a/experimental/garrigue/module-errors.diffs b/experimental/garrigue/module-errors.diffs
deleted file mode 100644
index 2f8c2bc28..000000000
--- a/experimental/garrigue/module-errors.diffs
+++ /dev/null
@@ -1,403 +0,0 @@
-Index: typing/includemod.ml
-===================================================================
---- typing/includemod.ml	(revision 11161)
-+++ typing/includemod.ml	(working copy)
-@@ -19,7 +19,7 @@
- open Types
- open Typedtree
- 
--type error =
-+type symptom =
-     Missing_field of Ident.t
-   | Value_descriptions of Ident.t * value_description * value_description
-   | Type_declarations of Ident.t * type_declaration
-@@ -38,6 +38,10 @@
-       Ctype.class_match_failure list
-   | Unbound_modtype_path of Path.t
- 
-+type pos =
-+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-+type error = pos list * symptom
-+
- exception Error of error list
- 
- (* All functions "blah env x1 x2" check that x1 is included in x2,
-@@ -46,51 +50,52 @@
- 
- (* Inclusion between value descriptions *)
- 
--let value_descriptions env subst id vd1 vd2 =
-+let value_descriptions env cxt subst id vd1 vd2 =
-   let vd2 = Subst.value_description subst vd2 in
-   try
-     Includecore.value_descriptions env vd1 vd2
-   with Includecore.Dont_match ->
--    raise(Error[Value_descriptions(id, vd1, vd2)])
-+    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
- 
- (* Inclusion between type declarations *)
- 
--let type_declarations env subst id decl1 decl2 =
-+let type_declarations env cxt subst id decl1 decl2 =
-   let decl2 = Subst.type_declaration subst decl2 in
-   let err = Includecore.type_declarations env id decl1 decl2 in
--  if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
-+  if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
- 
- (* Inclusion between exception declarations *)
- 
--let exception_declarations env subst id decl1 decl2 =
-+let exception_declarations env cxt subst id decl1 decl2 =
-   let decl2 = Subst.exception_declaration subst decl2 in
-   if Includecore.exception_declarations env decl1 decl2
-   then ()
--  else raise(Error[Exception_declarations(id, decl1, decl2)])
-+  else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
- 
- (* Inclusion between class declarations *)
- 
--let class_type_declarations env subst id decl1 decl2 =
-+let class_type_declarations env cxt subst id decl1 decl2 =
-   let decl2 = Subst.cltype_declaration subst decl2 in
-   match Includeclass.class_type_declarations env decl1 decl2 with
-     []     -> ()
--  | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
-+  | reason ->
-+      raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
- 
--let class_declarations env subst id decl1 decl2 =
-+let class_declarations env cxt subst id decl1 decl2 =
-   let decl2 = Subst.class_declaration subst decl2 in
-   match Includeclass.class_declarations env decl1 decl2 with
-     []     -> ()
--  | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
-+  | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
- 
- (* Expand a module type identifier when possible *)
- 
- exception Dont_match
- 
--let expand_module_path env path =
-+let expand_module_path env cxt path =
-   try
-     Env.find_modtype_expansion path env
-   with Not_found ->
--    raise(Error[Unbound_modtype_path path])
-+    raise(Error[cxt, Unbound_modtype_path path])
- 
- (* Extract name, kind and ident from a signature item *)
- 
-@@ -128,28 +133,29 @@
-    Return the restriction that transforms a value of the smaller type
-    into a value of the bigger type. *)
- 
--let rec modtypes env subst mty1 mty2 =
-+let rec modtypes env cxt subst mty1 mty2 =
-   try
--    try_modtypes env subst mty1 mty2
-+    try_modtypes env cxt subst mty1 mty2
-   with
-     Dont_match ->
--      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
-+      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
-   | Error reasons ->
--      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
-+      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
-+                  :: reasons))
- 
--and try_modtypes env subst mty1 mty2 =
-+and try_modtypes env cxt subst mty1 mty2 =
-   match (mty1, mty2) with
-     (_, Tmty_ident p2) ->
--      try_modtypes2 env mty1 (Subst.modtype subst mty2)
-+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
-   | (Tmty_ident p1, _) ->
--      try_modtypes env subst (expand_module_path env p1) mty2
-+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
-   | (Tmty_signature sig1, Tmty_signature sig2) ->
--      signatures env subst sig1 sig2
-+      signatures env cxt subst sig1 sig2
-   | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
-       let arg2' = Subst.modtype subst arg2 in
--      let cc_arg = modtypes env Subst.identity arg2' arg1 in
-+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
-       let cc_res =
--        modtypes (Env.add_module param1 arg2' env)
-+        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
-           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
-       begin match (cc_arg, cc_res) with
-           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
-@@ -158,19 +164,19 @@
-   | (_, _) ->
-       raise Dont_match
- 
--and try_modtypes2 env mty1 mty2 =
-+and try_modtypes2 env cxt mty1 mty2 =
-   (* mty2 is an identifier *)
-   match (mty1, mty2) with
-     (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
-       Tcoerce_none
-   | (_, Tmty_ident p2) ->
--      try_modtypes env Subst.identity mty1 (expand_module_path env p2)
-+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
-   | (_, _) ->
-       assert false
- 
- (* Inclusion between signatures *)
- 
--and signatures env subst sig1 sig2 =
-+and signatures env cxt subst sig1 sig2 =
-   (* Environment used to check inclusion of components *)
-   let new_env =
-     Env.add_signature sig1 env in
-@@ -202,7 +208,7 @@
-   let rec pair_components subst paired unpaired = function
-       [] ->
-         begin match unpaired with
--            [] -> signature_components new_env subst (List.rev paired)
-+            [] -> signature_components new_env cxt subst (List.rev paired)
-           | _  -> raise(Error unpaired)
-         end
-     | item2 :: rem ->
-@@ -234,7 +240,7 @@
-             ((item1, item2, pos1) :: paired) unpaired rem
-         with Not_found ->
-           let unpaired =
--            if report then Missing_field id2 :: unpaired else unpaired in
-+            if report then (cxt, Missing_field id2) :: unpaired else unpaired in
-           pair_components subst paired unpaired rem
-         end in
-   (* Do the pairing and checking, and return the final coercion *)
-@@ -242,65 +248,67 @@
- 
- (* Inclusion between signature components *)
- 
--and signature_components env subst = function
-+and signature_components env cxt subst = function
-     [] -> []
-   | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
--      let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
-+      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
-       begin match valdecl2.val_kind with
--        Val_prim p -> signature_components env subst rem
--      | _ -> (pos, cc) :: signature_components env subst rem
-+        Val_prim p -> signature_components env cxt subst rem
-+      | _ -> (pos, cc) :: signature_components env cxt subst rem
-       end
-   | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
--      type_declarations env subst id1 tydecl1 tydecl2;
--      signature_components env subst rem
-+      type_declarations env cxt subst id1 tydecl1 tydecl2;
-+      signature_components env cxt subst rem
-   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
-     :: rem ->
--      exception_declarations env subst id1 excdecl1 excdecl2;
--      (pos, Tcoerce_none) :: signature_components env subst rem
-+      exception_declarations env cxt subst id1 excdecl1 excdecl2;
-+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
-   | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
-       let cc =
--        modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
--      (pos, cc) :: signature_components env subst rem
-+        modtypes env (Module id1::cxt) subst
-+          (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-+      (pos, cc) :: signature_components env cxt subst rem
-   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
--      modtype_infos env subst id1 info1 info2;
--      signature_components env subst rem
-+      modtype_infos env cxt subst id1 info1 info2;
-+      signature_components env cxt subst rem
-   | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
--      class_declarations env subst id1 decl1 decl2;
--      (pos, Tcoerce_none) :: signature_components env subst rem
-+      class_declarations env cxt subst id1 decl1 decl2;
-+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
-   | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
--      class_type_declarations env subst id1 info1 info2;
--      signature_components env subst rem
-+      class_type_declarations env cxt subst id1 info1 info2;
-+      signature_components env cxt subst rem
-   | _ ->
-       assert false
- 
- (* Inclusion between module type specifications *)
- 
--and modtype_infos env subst id info1 info2 =
-+and modtype_infos env cxt subst id info1 info2 =
-   let info2 = Subst.modtype_declaration subst info2 in
-+  let cxt' = Modtype id :: cxt in
-   try
-     match (info1, info2) with
-       (Tmodtype_abstract, Tmodtype_abstract) -> ()
-     | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
-     | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
--        check_modtype_equiv env mty1 mty2
-+        check_modtype_equiv env cxt' mty1 mty2
-     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
--        check_modtype_equiv env (Tmty_ident(Pident id)) mty2
-+        check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
-   with Error reasons ->
--    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
-+    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
- 
--and check_modtype_equiv env mty1 mty2 =
-+and check_modtype_equiv env cxt mty1 mty2 =
-   match
--    (modtypes env Subst.identity mty1 mty2,
--     modtypes env Subst.identity mty2 mty1)
-+    (modtypes env cxt Subst.identity mty1 mty2,
-+     modtypes env cxt Subst.identity mty2 mty1)
-   with
-     (Tcoerce_none, Tcoerce_none) -> ()
--  | (_, _) -> raise(Error [Modtype_permutation])
-+  | (_, _) -> raise(Error [cxt, Modtype_permutation])
- 
- (* Simplified inclusion check between module types (for Env) *)
- 
- let check_modtype_inclusion env mty1 path1 mty2 =
-   try
--    ignore(modtypes env Subst.identity
-+    ignore(modtypes env [] Subst.identity
-                     (Mtype.strengthen env mty1 path1) mty2)
-   with Error reasons ->
-     raise Not_found
-@@ -312,16 +320,16 @@
- 
- let compunit impl_name impl_sig intf_name intf_sig =
-   try
--    signatures Env.initial Subst.identity impl_sig intf_sig
-+    signatures Env.initial [] Subst.identity impl_sig intf_sig
-   with Error reasons ->
--    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
-+    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
- 
--(* Hide the substitution parameter to the outside world *)
-+(* Hide the context and substitution parameters to the outside world *)
- 
--let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
--let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
-+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
-+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
- let type_declarations env id decl1 decl2 =
--  type_declarations env Subst.identity id decl1 decl2
-+  type_declarations env [] Subst.identity id decl1 decl2
- 
- (* Error report *)
- 
-@@ -384,9 +392,62 @@
-   | Unbound_modtype_path path ->
-       fprintf ppf "Unbound module type %a" Printtyp.path path
- 
--let report_error ppf = function
--  |  [] -> ()
--  | err :: errs ->
--      let print_errs ppf errs =
--         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
--      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
-+let rec context ppf = function
-+    Module id :: rem ->
-+      fprintf ppf "@[<2>module %a%a@]" ident id args rem
-+  | Modtype id :: rem ->
-+      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
-+  | Body x :: rem ->
-+      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
-+  | Arg x :: rem ->
-+      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
-+  | [] ->
-+      fprintf ppf "<here>"
-+and context_mty ppf = function
-+    (Module _ | Modtype _) :: _ as rem ->
-+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
-+  | cxt -> context ppf cxt
-+and args ppf = function
-+    Body x :: rem ->
-+      fprintf ppf "(%a)%a" ident x args rem
-+  | Arg x :: rem ->
-+      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
-+  | cxt ->
-+      fprintf ppf " :@ %a" context_mty cxt
-+
-+let path_of_context = function
-+    Module id :: rem ->
-+      let rec subm path = function
-+          [] -> path
-+        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
-+        | _ -> assert false
-+      in subm (Pident id) rem
-+  | _ -> assert false
-+
-+let context ppf cxt =
-+  if cxt = [] then () else
-+  if List.for_all (function Module _ -> true | _ -> false) cxt then
-+    fprintf ppf "In module %a:@ " path (path_of_context cxt)
-+  else
-+    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
-+
-+let include_err ppf (cxt, err) =
-+  fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
-+
-+let max_size = 500
-+let buffer = String.create max_size
-+let is_big obj =
-+  try ignore (Marshal.to_buffer buffer 0 max_size obj []); false
-+  with _ -> true
-+
-+let report_error ppf errs =
-+  if errs = [] then () else
-+  let (errs , err) = split_last errs in
-+  let pe = ref true in
-+  let include_err' ppf err =
-+    if !Clflags.show_trace || not (is_big err) then
-+      fprintf ppf "%a@ " include_err err
-+    else if !pe then (fprintf ppf "...@ "; pe := false)
-+  in
-+  let print_errs ppf = List.iter (include_err' ppf) in
-+  fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
-Index: typing/includemod.mli
-===================================================================
---- typing/includemod.mli	(revision 11161)
-+++ typing/includemod.mli	(working copy)
-@@ -24,7 +24,7 @@
- val type_declarations:
-       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
- 
--type error =
-+type symptom =
-     Missing_field of Ident.t
-   | Value_descriptions of Ident.t * value_description * value_description
-   | Type_declarations of Ident.t * type_declaration
-@@ -43,6 +43,10 @@
-       Ctype.class_match_failure list
-   | Unbound_modtype_path of Path.t
- 
-+type pos =
-+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-+type error = pos list * symptom
-+
- exception Error of error list
- 
- val report_error: formatter -> error list -> unit
-Index: utils/clflags.ml
-===================================================================
---- utils/clflags.ml	(revision 11161)
-+++ utils/clflags.ml	(working copy)
-@@ -53,6 +53,7 @@
- and dllpaths = ref ([] : string list)   (* -dllpath *)
- and make_package = ref false            (* -pack *)
- and for_package = ref (None: string option) (* -for-pack *)
-+and show_trace = ref false              (* -show-trace *)
- let dump_parsetree = ref false          (* -dparsetree *)
- and dump_rawlambda = ref false          (* -drawlambda *)
- and dump_lambda = ref false             (* -dlambda *)
-Index: utils/clflags.mli
-===================================================================
---- utils/clflags.mli	(revision 11161)
-+++ utils/clflags.mli	(working copy)
-@@ -50,6 +50,7 @@
- val dllpaths : string list ref
- val make_package : bool ref
- val for_package : string option ref
-+val show_trace : bool ref
- val dump_parsetree : bool ref
- val dump_rawlambda : bool ref
- val dump_lambda : bool ref