Initial commit on this branch.letopenin

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

9 files changed, 34 insertions, 15 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 761b5a9741..f7de4188f0 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -825,6 +825,10 @@ expr:
       { mkexp(Pexp_let($2, List.rev $3, $5)) }
   | LET MODULE UIDENT module_binding IN seq_expr
       { mkexp(Pexp_letmodule($3, $4, $6)) }
+  | LET OPEN mod_longident IN seq_expr
+      { mkexp(Pexp_open($3, $5)) }
+  | mod_longident DOT LPAREN seq_expr RPAREN
+      { mkexp(Pexp_open($1, $4)) }
   | FUNCTION opt_bar match_cases
       { mkexp(Pexp_function("", None, List.rev $3)) }
   | FUN labeled_simple_pattern fun_def
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 0be71b4e7c..a67d50e196 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -113,6 +113,7 @@ and expression_desc =
   | Pexp_poly of expression * core_type option
   | Pexp_object of class_structure
   | Pexp_newtype of string * expression
+  | Pexp_open of Longident.t * expression
 
 (* Value descriptions *)
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index a81c9e6753..0d30b4f33c 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -308,6 +308,9 @@ and expression i ppf x =
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype \"%s\"\n" s;
       expression i ppf e
+  | Pexp_open (m, e) ->
+      line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
+      expression i ppf e
 
 and value_description i ppf x =
   line i ppf "value_description\n";
diff --git a/tools/depend.ml b/tools/depend.ml
index f4bebad294..effe26fc1b 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -158,6 +158,7 @@ let rec add_expr bv exp =
   | Pexp_object (pat, fieldl) ->
       add_pattern bv pat; List.iter (add_class_field bv) fieldl
   | Pexp_newtype (_, e) -> add_expr bv e
+  | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
 
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 2425a9adcd..221875cc28 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -285,8 +285,8 @@ and rw_exp iflag sexp =
   | Pexp_object (_, fieldl) ->
       List.iter (rewrite_class_field iflag) fieldl
 
-  | Pexp_newtype (_, sexp) ->
-      rewrite_exp iflag sexp
+  | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
+  | Pexp_open (_, e) -> rewrite_exp iflag e
 
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 7083887e9c..68c6a8681e 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -71,6 +71,12 @@ let type_module =
   ref ((fun env md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
+(* Forward declaration, to be filled in by Typemod.type_open *)
+
+let type_open =
+  ref (fun _ -> assert false)
+
+
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
   ref (fun env s -> assert false :
@@ -1631,7 +1637,8 @@ let rec type_exp env sexp =
       (* non-expansive if the body is non-expansive, so we don't introduce
          any new extra node in the typed AST. *)
       re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
-
+  | Pexp_open (lid, e) ->
+      type_exp (!type_open env sexp.pexp_loc lid) e
 
 and type_argument env sarg ty_expected' =
   (* ty_expected' may be generic *)
diff --git a/typing/typecore.mli b/typing/typecore.mli
index d4cfb85671..60303c924a 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -109,6 +109,8 @@ val report_error: formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typemod.type_open *)
+val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 21e4f2a024..5ee9e5d15b 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -62,6 +62,13 @@ let type_module_path env loc lid =
   with Not_found ->
     raise(Error(loc, Unbound_module lid))
 
+(* Compute the environment after opening a module *)
+
+let type_open env loc lid =
+  let (path, mty) = type_module_path env loc lid in
+  let sg = extract_sig_open env loc mty in
+  Env.open_signature path sg env
+
 (* Record a module type *)
 let rm node =
   Stypes.record (Stypes.Ti_mod node);
@@ -201,10 +208,7 @@ and approx_sig env ssg =
           let (id, newenv) = Env.enter_modtype name info env in
           Tsig_modtype(id, info) :: approx_sig newenv srem
       | Psig_open lid ->
-          let (path, mty) = type_module_path env item.psig_loc lid in
-          let sg = extract_sig_open env item.psig_loc mty in
-          let newenv = Env.open_signature path sg env in
-          approx_sig newenv srem
+          approx_sig (type_open env item.psig_loc lid) srem
       | Psig_include smty ->
           let mty = approx_modtype env smty in
           let sg = Subst.signature Subst.identity
@@ -340,10 +344,7 @@ and transl_signature env sg =
             let rem = transl_sig newenv srem in
             Tsig_modtype(id, info) :: rem
         | Psig_open lid ->
-            let (path, mty) = type_module_path env item.psig_loc lid in
-            let sg = extract_sig_open env item.psig_loc mty in
-            let newenv = Env.open_signature path sg env in
-            transl_sig newenv srem
+            transl_sig (type_open env item.psig_loc lid) srem
         | Psig_include smty ->
             let mty = transl_modtype env smty in
             let sg = Subst.signature Subst.identity
@@ -744,9 +745,7 @@ and type_structure anchor env sstr scope =
          Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem,
          final_env)
     | {pstr_desc = Pstr_open lid; pstr_loc = loc} :: srem ->
-        let (path, mty) = type_module_path env loc lid in
-        let sg = extract_sig_open env loc mty in
-        type_struct (Env.open_signature path sg env) srem
+        type_struct (type_open env loc lid) srem
     | {pstr_desc = Pstr_class cl; pstr_loc = loc} :: srem ->
          List.iter
            (fun {pci_name = name} -> check "type" loc type_names name)
@@ -816,7 +815,8 @@ let type_structure = type_structure None
 
 (* Fill in the forward declaration *)
 let _ =
-  Typecore.type_module := type_module
+  Typecore.type_module := type_module;
+  Typecore.type_open := type_open
 
 (* Normalize types in a signature *)
 
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 633de59643..72a5b864bf 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -174,6 +174,7 @@ and expression ppf tbl e =
   | Pexp_poly (e, _) -> expression ppf tbl e;
   | Pexp_object cs -> class_structure ppf tbl cs;
   | Pexp_newtype (_, e) -> expression ppf tbl e
+  | Pexp_open (_, e) -> expression ppf tbl e
 
 and expression_option ppf tbl eo =
   match eo with