essai d'ajout de let open ... inletopen

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

4 files changed, 31 insertions, 0 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index a96f05774e..1a2282e0c9 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -750,6 +750,8 @@ expr:
       { mkexp(Pexp_let($2, List.rev $3, $5)) }
   | LET MODULE UIDENT module_binding IN seq_expr %prec prec_let
       { mkexp(Pexp_letmodule($3, $4, $6)) }
+  | LET OPEN mod_longident IN seq_expr %prec prec_let
+      { mkexp(Pexp_letopen($3, $5)) }
   | PARSER opt_pat opt_bar parser_cases %prec prec_fun
       { Pstream.cparser ($2, List.rev $4) }
   | FUNCTION opt_bar match_cases %prec prec_fun
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 99c19a0b65..89c8810ba0 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -103,6 +103,7 @@ and expression_desc =
   | Pexp_letmodule of string * module_expr * expression
   | Pexp_assert of expression
   | Pexp_assertfalse
+  | Pexp_letopen of Longident.t * expression
 
 (* Value descriptions *)
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 987b27a385..6b34736d01 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -54,6 +54,8 @@ type error =
   | Scoping_let_module of string * type_expr
   | Masked_instance_variable of Longident.t
   | Not_a_variant_type of Longident.t
+  | Unbound_module of Longident.t
+  | Structure_expected of module_type
 
 exception Error of Location.t * error
 
@@ -586,6 +588,21 @@ let rec type_approx env sexp =
       end
   | _ -> newvar ()
 
+(* Extract a signature from a module type *)
+
+let extract_sig_open env loc mty =
+  match Mtype.scrape env mty with
+    Tmty_signature sg -> sg
+  | _ -> raise(Error(loc, Structure_expected mty))
+
+(* Lookup the type of a module path *)
+
+let type_module_path env loc lid =
+  try
+    Env.lookup_module lid env
+  with Not_found ->
+    raise(Error(loc, Unbound_module lid))
+
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
@@ -1017,6 +1034,11 @@ let rec type_exp env sexp =
          exp_type = newvar ();
          exp_env = env;
        }
+  | Pexp_letopen (lid, sbody) ->
+      let (path, mty) = type_module_path env sexp.pexp_loc lid in
+      let sg = extract_sig_open env sexp.pexp_loc mty in
+      let new_env = Env.open_signature path sg env in
+      type_exp new_env sbody
 
 and type_argument env sarg ty_expected =
   let rec no_labels ty =
@@ -1526,3 +1548,7 @@ let report_error ppf = function
         longident lid
   | Not_a_variant_type lid ->
       fprintf ppf "The type %a@ is not a variant type" longident lid
+  | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid
+  | Structure_expected mty ->
+      fprintf ppf
+        "@[This module is not a structure; it has type@ %a" modtype mty
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 788ec75f25..ec74fa5bc3 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -84,6 +84,8 @@ type error =
   | Scoping_let_module of string * type_expr
   | Masked_instance_variable of Longident.t
   | Not_a_variant_type of Longident.t
+  | Unbound_module of Longident.t
+  | Structure_expected of module_type
 
 exception Error of Location.t * error