Foncteurs applicatifs.

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

12 files changed, 219 insertions, 60 deletions

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 01dd26d01..6540f8f7a 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -11,6 +11,7 @@
 
 (* $Id$ *)
 
+open Misc
 open Path
 open Asttypes
 open Typedtree
@@ -180,4 +181,5 @@ let rec transl_path = function
       if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
   | Pdot(p, s, pos) ->
       Lprim(Pfield pos, [transl_path p])
-
+  | Papply(p1, p2) ->
+      fatal_error "Lambda.transl_path"
diff --git a/parsing/longident.mli b/parsing/longident.mli
index 374ff5a00..b296bcb63 100644
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -16,3 +16,4 @@
 type t =
     Lident of string
   | Ldot of t * string
+  | Lapply of t * t
\ No newline at end of file
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 5b3817151..1ab0de6ff 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -212,8 +212,8 @@ module_expr:
   | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
     %prec prec_fun
       { mkmod(Pmod_functor($3, $5, $8)) }
-  | module_expr module_expr %prec prec_appl
-      { mkmod(Pmod_apply($1, $2)) }
+  | module_expr LPAREN module_expr RPAREN
+      { mkmod(Pmod_apply($1, $3)) }
   | LPAREN module_expr COLON module_type RPAREN
       { mkmod(Pmod_constraint($2, $4)) }
   | LPAREN module_expr RPAREN
@@ -662,16 +662,20 @@ label_longident:
 ;
 type_longident:
     LIDENT                                      { Lident $1 }
-  | mod_longident DOT LIDENT                    { Ldot($1, $3) }
+  | mod_ext_longident DOT LIDENT                { Ldot($1, $3) }
 ;
 mod_longident:
     UIDENT                                      { Lident $1 }
   | mod_longident DOT UIDENT                    { Ldot($1, $3) }
 ;
+mod_ext_longident:
+    UIDENT                                      { Lident $1 }
+  | mod_ext_longident DOT UIDENT                { Ldot($1, $3) }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN { Lapply($1, $3) }
+;
 mty_longident:
     ident                                       { Lident $1 }
-  | mod_longident DOT ident                     { Ldot($1, $3) }
-;
+  | mod_ext_longident DOT ident                 { Ldot($1, $3) }
 
 /* Miscellaneous */
 
diff --git a/typing/env.ml b/typing/env.ml
index 9d6eddf5b..daedcc431 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -36,9 +36,13 @@ type t = {
   types: (Path.t * type_declaration) Ident.tbl;
   modules: (Path.t * module_type) Ident.tbl;
   modtypes: (Path.t * modtype_declaration) Ident.tbl;
-  components: (Path.t * structure_components) Ident.tbl
+  components: (Path.t * module_components) Ident.tbl
 }
 
+and module_components =
+    Structure_comps of structure_components
+  | Functor_comps of functor_components
+
 and structure_components = {
   mutable comp_values: (string, (value_description * int)) Tbl.t;
   mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
@@ -46,7 +50,14 @@ and structure_components = {
   mutable comp_types: (string, (type_declaration * int)) Tbl.t;
   mutable comp_modules: (string, (module_type * int)) Tbl.t;
   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
-  mutable comp_components: (string, (structure_components * int)) Tbl.t
+  mutable comp_components: (string, (module_components * int)) Tbl.t
+}
+
+and functor_components = {
+  fcomp_param: Ident.t;
+  fcomp_arg: module_type;
+  fcomp_res: module_type;
+  fcomp_env: t
 }
 
 let empty = {
@@ -60,7 +71,7 @@ let empty = {
 type pers_struct =
   { ps_name: string;
     ps_sig: signature;
-    ps_comps: structure_components }
+    ps_comps: module_components }
 
 let persistent_structures =
   (Hashtbl.new 17 : (string, pers_struct) Hashtbl.t)
@@ -101,6 +112,17 @@ let reset_cache() =
   Hashtbl.clear persistent_structures;
   imported_units := []
 
+(* Forward declarations *)
+
+let components_of_functor_appl =
+  ref ((fun f p1 p2 -> fatal_error "Env.components_of_functor_appl") :
+       functor_components -> Path.t -> Path.t -> module_components)
+
+let check_modtype_inclusion =
+  (* to be filled with includemod.check_modtype_inclusion *)
+  ref ((fun env mty1 mty2 -> fatal_error "Env.include_modtypes") :
+       t -> module_type -> module_type -> unit)
+
 (* Lookup by identifier *)
 
 let rec find_module_descr path env =
@@ -115,9 +137,20 @@ let rec find_module_descr path env =
         else raise Not_found
       end
   | Pdot(p, s, pos) ->
-      let descr_p = find_module_descr p env in
-      let (descr, pos) = Tbl.find s descr_p.comp_components in
-      descr
+      begin match find_module_descr p env with
+      	Structure_comps c ->
+	  let (descr, pos) = Tbl.find s c.comp_components in
+          descr
+      | Functor_comps f ->
+      	 raise Not_found
+      end
+  | Papply(p1, p2) ->
+      begin match find_module_descr p1 env with
+      	Functor_comps f ->
+          !components_of_functor_appl f p1 p2
+      | Structure_comps c ->
+      	  raise Not_found
+      end
 
 let find proj1 proj2 path env =
   try
@@ -126,8 +159,14 @@ let find proj1 proj2 path env =
         let (p, data) = Ident.find_same id (proj1 env)
         in data
     | Pdot(p, s, pos) ->
-        let (data, pos) = Tbl.find s (proj2 (find_module_descr p env))
-        in data
+        begin match find_module_descr p env with
+      	  Structure_comps c ->
+      	    let (data, pos) = Tbl.find s (proj2 c) in data
+        | Functor_comps f ->
+      	    fatal_error "Env.find"
+	end
+    | Papply(p1, p2) ->
+      	fatal_error "Env.find"
   with Not_found ->
     fatal_error "Env.find"
 
@@ -145,28 +184,86 @@ let rec lookup_module_descr lid env =
       with Not_found ->
         (Pident(Ident.new_persistent s), (find_pers_struct s).ps_comps)
       end
-  | Ldot(p, s) ->
-      let (path, descr_p) = lookup_module_descr p env in
-      let (descr, pos) = Tbl.find s descr_p.comp_components in
-      (Pdot(path, s, pos), descr)
+  | Ldot(l, s) ->
+      let (p, descr) = lookup_module_descr l env in
+      begin match descr with
+      	Structure_comps c ->
+	  let (descr, pos) = Tbl.find s c.comp_components in
+          (Pdot(p, s, pos), descr)
+      | Functor_comps f ->
+      	  raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      let (p1, desc1) = lookup_module_descr l1 env in
+      let (p2, mty2) = lookup_module l2 env in
+      begin match desc1 with
+      	Functor_comps f ->
+          !check_modtype_inclusion env mty2 f.fcomp_arg;
+          (Papply(p1, p2), !components_of_functor_appl f p1 p2)
+      | Structure_comps c ->
+      	  raise Not_found
+      end
+
+and lookup_module lid env =
+  match lid with
+    Lident s ->
+      begin try
+        Ident.find_name s env.modules
+      with Not_found ->
+        (Pident(Ident.new_persistent s), 
+         Tmty_signature(find_pers_struct s).ps_sig)
+      end
+  | Ldot(l, s) ->
+      let (p, descr) = lookup_module_descr l env in
+      begin match descr with
+      	Structure_comps c ->
+          let (data, pos) = Tbl.find s c.comp_modules in
+          (Pdot(p, s, pos), data)
+      | Functor_comps f ->
+      	  raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      let (p1, desc1) = lookup_module_descr l1 env in
+      let (p2, mty2) = lookup_module l2 env in
+      let p = Papply(p1, p2) in
+      begin match desc1 with
+      	Functor_comps f ->
+          !check_modtype_inclusion env mty2 f.fcomp_arg;
+          (p, Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
+      	                    f.fcomp_res)
+      | Structure_comps c ->
+      	  raise Not_found
+      end
 
 let lookup proj1 proj2 lid env =
   match lid with
     Lident s ->
       Ident.find_name s (proj1 env)
-  | Ldot(p, s) ->
-      let (path, descr) = lookup_module_descr p env in
-      let (data, pos) = Tbl.find s (proj2 descr) in
-      (Pdot(path, s, pos), data)
+  | Ldot(l, s) ->
+      begin match lookup_module_descr l env with
+      	(p, Structure_comps c) ->
+	  let (data, pos) = Tbl.find s (proj2 c) in
+          (Pdot(p, s, pos), data)
+      | (p, Functor_comps f) ->
+      	  raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      raise Not_found
 
 let lookup_simple proj1 proj2 lid env =
   match lid with
     Lident s ->
       Ident.find_name s (proj1 env)
-  | Ldot(p, s) ->
-      let (path, descr) = lookup_module_descr p env in
-      let (data, pos) = Tbl.find s (proj2 descr) in
-      data
+  | Ldot(l, s) ->
+      begin match lookup_module_descr l env with
+      	(p, Structure_comps c) ->
+	  let (data, pos) = Tbl.find s (proj2 c) in
+          data
+      | (p, Functor_comps f) ->
+      	  raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      raise Not_found
 
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
@@ -179,20 +276,6 @@ and lookup_type =
 and lookup_modtype =
   lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
 
-let lookup_module lid env =
-  match lid with
-    Lident s ->
-      begin try
-        Ident.find_name s env.modules
-      with Not_found ->
-        (Pident(Ident.new_persistent s), 
-         Tmty_signature(find_pers_struct s).ps_sig)
-      end
-    | Ldot(p, s) ->
-        let (path, descr) = lookup_module_descr p env in
-        let (data, pos) = Tbl.find s descr.comp_modules in
-        (Pdot(path, s, pos), data)
-
 (* Scrape a module type *)
 
 let rec scrape_modtype mty env =
@@ -253,13 +336,13 @@ let rec prefix_idents root pos sub = function
 (* Compute structure descriptions *)
 
 let rec components_of_module env path mty =
-  let c =
-    { comp_values = Tbl.empty; comp_constrs = Tbl.empty;
-      comp_labels = Tbl.empty; comp_types = Tbl.empty;
-      comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
-      comp_components = Tbl.empty } in
-  begin match scrape_modtype mty env with
+  match scrape_modtype mty env with
     Tmty_signature sg ->
+      let c =
+        { comp_values = Tbl.empty; comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty } in
       let (pl, sub) = prefix_idents path 0 Subst.identity sg in
       let env = ref env in
       let pos = ref 0 in
@@ -302,10 +385,20 @@ let rec components_of_module env path mty =
             c.comp_modtypes <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
             env := store_modtype id path decl' !env)
-        sg pl
-  | _ -> ()
-  end;
-  c
+        sg pl;
+	Structure_comps c
+  | Tmty_functor(param, ty_arg, ty_res) ->
+      	Functor_comps {
+	  fcomp_param = param;
+	  fcomp_arg = ty_arg;
+	  fcomp_res = ty_res;
+	  fcomp_env = env }
+  | Tmty_ident p ->
+      	Structure_comps {
+      	  comp_values = Tbl.empty; comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty }
 
 (* Insertion of bindings by identifier + path *)
 
@@ -374,6 +467,26 @@ and store_components id path comps env =
     modtypes = env.modtypes;
     components = Ident.add id (path, comps) env.components }
 
+(* Memoized function to compute the components of a functor application
+   in a path. *)
+
+let funappl_memo =
+  (Hashtbl.new 17 : (Path.t, module_components) Hashtbl.t)
+
+let _ =
+  components_of_functor_appl :=
+    (fun f p1 p2 ->
+      let p = Papply(p1, p2) in
+      try
+        Hashtbl.find funappl_memo p
+      with Not_found ->
+        let mty = 
+          Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
+                        f.fcomp_res in
+        let comps = components_of_module f.fcomp_env p mty in
+        Hashtbl.add funappl_memo p comps;
+        comps)
+
 (* Insertion of bindings by identifier *)
 
 let add_value id desc env =
diff --git a/typing/env.mli b/typing/env.mli
index 8d96f2cef..d2184b180 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -90,3 +90,6 @@ exception Error of error
 
 val report_error: error -> unit
 
+(* Forward declaration to break mutual recursion with Includemod. *)
+
+val check_modtype_inclusion: (t -> module_type -> module_type -> unit) ref
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 1447c5a3e..61c7597b4 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -211,6 +211,16 @@ and modtype_infos env id info1 info2 =
   with Error reasons ->
     raise(Error(Modtype_infos(id, info1, info2) :: reasons))
 
+(* Simplified inclusion check between module types *)
+
+let check_modtype_inclusion env mty1 mty2 =
+  try
+    modtypes env mty1 mty2; ()
+  with Error reasons ->
+    raise Not_found
+
+let _ = Env.check_modtype_inclusion := check_modtype_inclusion
+
 (* Error report *)
 
 open Format
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 07262472e..29d4a8bfc 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -30,6 +30,8 @@ let rec strengthen env mty p =
   match scrape env mty with
     Tmty_signature sg ->
       Tmty_signature(strengthen_sig env sg p)
+  | Tmty_functor(param, arg, res) ->
+      Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
   | mty ->
       mty
 
diff --git a/typing/path.ml b/typing/path.ml
index 8aa7a1fbf..19c617d3d 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -14,6 +14,7 @@
 type t =
     Pident of Ident.t
   | Pdot of t * string * int
+  | Papply of t * t
 
 let nopos = -1
 
@@ -21,10 +22,10 @@ let rec same p1 p2 =
   match (p1, p2) with
     (Pident id1, Pident id2) -> Ident.same id1 id2
   | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 & same p1 p2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) -> same fun1 fun2 & same arg1 arg2
   | (_, _) -> false
 
-let rec root = function
-    Pident id -> id
-  | Pdot(p, s, pos) -> root p
-
-let isfree id p = Ident.same id (root p)
+let rec isfree id = function
+    Pident id' -> Ident.same id id'
+  | Pdot(p, s, pos) -> isfree id p
+  | Papply(p1, p2) -> isfree id p1 or isfree id p2
diff --git a/typing/path.mli b/typing/path.mli
index 5807cd647..c813e4319 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -16,6 +16,7 @@
 type t =
     Pident of Ident.t
   | Pdot of t * string * int
+  | Papply of t * t
 
 val same: t -> t -> bool
 val isfree: Ident.t -> t -> bool
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index a71d9ae82..2fc842f35 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -25,6 +25,8 @@ open Typedtree
 let rec longident = function
     Lident s -> print_string s
   | Ldot(p, s) -> longident p; print_string "."; print_string s
+  | Lapply(p1, p2) ->
+      longident p1; print_string "("; longident p2; print_string ")"
 
 (* Print an identifier *)
 
@@ -42,6 +44,8 @@ let rec path = function
       print_string s
   | Pdot(p, s, pos) ->
       path p; print_string "."; print_string s
+  | Papply(p1, p2) ->
+      path p1; print_string "("; path p2; print_string ")"
 
 (* Print a type expression *)
 
diff --git a/typing/subst.ml b/typing/subst.ml
index 356822701..531670cee 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -13,6 +13,7 @@
 
 (* Substitutions *)
 
+open Misc
 open Path
 open Typedtree
 
@@ -45,12 +46,16 @@ let rec module_path s = function
       begin try Ident.find_same id s.modules with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
+  | Papply(p1, p2) ->
+      Papply(module_path s p1, module_path s p2)
 
 let type_path s = function
     Pident id as p ->
       begin try Ident.find_same id s.types with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
+  | Papply(p1, p2) ->
+      fatal_error "Subst.type_path"
 
 let rec type_expr s = function
     Tvar{tvar_link = None} as ty -> ty
@@ -89,6 +94,8 @@ let rec modtype s = function
           begin try Ident.find_same id s.modtypes with Not_found -> mty end
       | Pdot(p, n, pos) ->
           Tmty_ident(Pdot(module_path s p, n, pos))
+      | Papply(p1, p2) ->
+          fatal_error "Subst.modtype"
       end
   | Tmty_signature sg ->
       Tmty_signature(signature s sg)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 9959e31d2..2ecf50d77 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -150,6 +150,17 @@ and transl_modtype_info env sinfo =
   | Pmodtype_manifest smty ->
       Tmodtype_manifest(transl_modtype env smty)
 
+(* Try to convert a module expression to a module path. *)
+
+exception Not_a_path
+
+let rec path_of_module mexp =
+  match mexp.mod_desc with
+    Tmod_ident p -> p
+  | Tmod_apply(funct, arg, coercion) ->
+      Papply(path_of_module funct, path_of_module arg)
+  | _ -> raise Not_a_path
+
 (* Type a module value expression *)
 
 let rec type_module env smod =
@@ -182,11 +193,11 @@ let rec type_module env smod =
             with Includemod.Error msg ->
               raise(Error(sarg.pmod_loc, Not_included msg)) in
           let mty_appl =
-            match arg with
-              {mod_desc = Tmod_ident path} ->
-                Subst.modtype (Subst.add_module param path Subst.identity)
-                               mty_res
-            | _ ->
+	    try
+	      let path = path_of_module arg in
+              Subst.modtype (Subst.add_module param path Subst.identity)
+      	       	       	    mty_res
+	    with Not_a_path ->
               try
                 Mtype.nondep_supertype
                   (Env.add_module param arg.mod_type env) param mty_res