merge branches/implicit-unpack + update camlp4

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

30 files changed, 707 insertions, 166 deletions

diff --git a/Makefile b/Makefile
index 912259b7ba..e83e881fc6 100644
--- a/Makefile
+++ b/Makefile
@@ -686,7 +686,7 @@ alldepend::
 
 # Camlp4
 
-camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte
+camlp4out: ocamlc ocamlbuild.byte
 	./build/camlp4-byte-only.sh
 
 camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
@@ -694,19 +694,20 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
 
 # Ocamlbuild
 
-ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot
+ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot
 	./build/ocamlbuild-byte-only.sh
 
-ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
+ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot
 	./build/ocamlbuild-native-only.sh
-ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
+ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot
 	./build/ocamlbuildlib-native-only.sh
 
-ocamlbuild-mixed-boot: ocamlc otherlibraries
+ocamlbuild-mixed-boot: ocamlc
 	./build/mixed-boot.sh
+	touch ocamlbuild-mixed-boot
 
 partialclean::
-	rm -rf _build
+	rm -rf _build ocamlbuild-mixed-boot
 
 # Check that the stack limit is reasonable.
 
diff --git a/VERSION b/VERSION
index 8b31fa07b7..ffe078855e 100644
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-3.13.0+dev1 (2010-08-02)
+3.13.0+dev2 (2010-10-22)
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
diff --git a/boot/ocamlc b/boot/ocamlc
index edcc2bb8fc..e95cb3a90c 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index f9b29d6068..dd86388bf6 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index d94e54c099..3b4799a1e4 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml
index b6725989de..ce5ed3efc3 100644
--- a/camlp4/Camlp4/Camlp4Ast.partial.ml
+++ b/camlp4/Camlp4/Camlp4Ast.partial.ml
@@ -116,7 +116,8 @@
     | PaTyc of loc and patt and ctyp (* (p : t) *)
     | PaTyp of loc and ident (* #i *)
     | PaVrn of loc and string (* `s *)
-    | PaLaz of loc and patt (* lazy p *) ]
+    | PaLaz of loc and patt (* lazy p *)
+    | PaMod of loc and string (* (module M) *) ]
   and expr =
     [ ExNil of loc
     | ExId  of loc and ident (* i *)
diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml
index dc48882e49..345be1a182 100644
--- a/camlp4/Camlp4/Printers/OCaml.ml
+++ b/camlp4/Camlp4/Printers/OCaml.ml
@@ -653,6 +653,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:patt< $id:i$ >> -> o#var_ident f i
     | <:patt< $anti:s$ >> -> o#anti f s
     | <:patt< _ >> -> pp f "_"
+    | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m
     | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p
     | <:patt< { $p$ } >> -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
     | <:patt< $str:s$ >> -> pp f "\"%s\"" s
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast
index 6c4ea3bc8a..4c692a380e 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast
+++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast
@@ -123,6 +123,7 @@ module Make (Loc : Sig.Loc)
     | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
     | <:patt< lazy $p$ >> -> is_irrefut_patt p
     | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *)
+    | <:patt< (module $_$) >> -> True
     | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> |
       <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> |
       <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> |
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 020a7e0c2e..9146fa25d0 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -538,6 +538,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
     | PaVrn loc s -> mkpat loc (Ppat_variant s None)
     | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
+    | PaMod loc m -> mkpat loc (Ppat_unpack m)
     | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
         error (loc_of_patt p) "invalid pattern" ]
   and mklabpat =
@@ -776,9 +777,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:expr@loc< let open $i$ in $e$ >> ->
         mkexp loc (Pexp_open (long_uident i) (expr e))
     | <:expr@loc< (module $me$ : $pt$) >> ->
-        mkexp loc (Pexp_pack (module_expr me) (package_type pt))
-    | <:expr@loc< (module $_$) >> ->
-        error loc "(module_expr : package_type) expected here"
+        mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)),
+                    Some (mktyp loc (Ptyp_package (package_type pt))), None))
+    | <:expr@loc< (module $me$) >> ->
+        mkexp loc (Pexp_pack (module_expr me))
     | ExFUN loc i e ->
         mkexp loc (Pexp_newtype i (expr e))
     | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
@@ -918,9 +920,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:module_expr@loc< ($me$ : $mt$) >> ->
         mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
     | <:module_expr@loc< (value $e$ : $pt$) >> ->
-        mkmod loc (Pmod_unpack (expr e) (package_type pt))
-    | <:module_expr@loc< (value $_$) >> ->
-        error loc "(value expr) not supported yet"
+        mkmod loc (Pmod_unpack (
+                   mkexp loc (Pexp_constraint (expr e,
+                              Some (mktyp loc (Ptyp_package (package_type pt))),
+                              None))))
+    | <:module_expr@loc< (value $e$) >> ->
+        mkmod loc (Pmod_unpack (expr e))
     | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ]
   and str_item s l =
     match s with
diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
index c7a510a52a..32c5b15733 100644
--- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
@@ -341,6 +341,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
         | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
         | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = patt; ")" -> <:patt< $p$ >>
         | "_" -> <:patt< _ >>
diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
index 11fd025041..fb467d8369 100644
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
@@ -890,6 +890,9 @@ Very old (no more supported) syntax:\n\
         | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
         | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = SELF; ")" -> p
         | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
@@ -958,6 +961,9 @@ Very old (no more supported) syntax:\n\
             <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >>
         | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = SELF; ")" -> p
         | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 92daa282d8..8d65f34464 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -1023,7 +1023,9 @@ module Sig =
           PaVrn of loc * string
           | (* `s *)
           PaLaz of loc * patt
-          and (* lazy p *)
+          | (* lazy p *)
+          PaMod of loc * string
+          and (* (module M) *)
           expr =
           | ExNil of loc
           | ExId of loc * ident
@@ -1929,6 +1931,7 @@ module Sig =
           | PaTyp of loc * ident
           | PaVrn of loc * string
           | PaLaz of loc * patt
+          | PaMod of loc * string
           and expr =
           | ExNil of loc
           | ExId of loc * ident
@@ -7027,6 +7030,7 @@ module Struct =
               | Ast.PaLab (_, _, p) -> is_irrefut_patt p
               | Ast.PaLaz (_, p) -> is_irrefut_patt p
               | Ast.PaId (_, _) -> false
+              | Ast.PaMod (_, _) -> true
               | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) |
                   Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) |
                   Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _)
@@ -9081,6 +9085,15 @@ module Struct =
                                    (Ast.IdUid (_loc, "OvOverride")))))
                         and meta_patt _loc =
                           function
+                          | Ast.PaMod (x0, x1) ->
+                              Ast.ExApp (_loc,
+                                (Ast.ExApp (_loc,
+                                   (Ast.ExId (_loc,
+                                      (Ast.IdAcc (_loc,
+                                         (Ast.IdUid (_loc, "Ast")),
+                                         (Ast.IdUid (_loc, "PaMod")))))),
+                                   (meta_loc _loc x0))),
+                                (meta_string _loc x1))
                           | Ast.PaLaz (x0, x1) ->
                               Ast.ExApp (_loc,
                                 (Ast.ExApp (_loc,
@@ -11367,6 +11380,15 @@ module Struct =
                                    (Ast.IdUid (_loc, "OvOverride")))))
                         and meta_patt _loc =
                           function
+                          | Ast.PaMod (x0, x1) ->
+                              Ast.PaApp (_loc,
+                                (Ast.PaApp (_loc,
+                                   (Ast.PaId (_loc,
+                                      (Ast.IdAcc (_loc,
+                                         (Ast.IdUid (_loc, "Ast")),
+                                         (Ast.IdUid (_loc, "PaMod")))))),
+                                   (meta_loc _loc x0))),
+                                (meta_string _loc x1))
                           | Ast.PaLaz (x0, x1) ->
                               Ast.PaApp (_loc,
                                 (Ast.PaApp (_loc,
@@ -12370,6 +12392,9 @@ module Struct =
                   | PaLaz (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1)
+                  | PaMod (_x, _x_i1) ->
+                      let _x = o#loc _x in
+                      let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1)
                   
                 method override_flag : override_flag -> override_flag =
                   function
@@ -13274,6 +13299,8 @@ module Struct =
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | PaLaz (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#patt _x_i1 in o
+                  | PaMod (_x, _x_i1) ->
+                      let o = o#loc _x in let o = o#string _x_i1 in o
                   
                 method override_flag : override_flag -> 'self_type =
                   function
@@ -14795,6 +14822,7 @@ module Struct =
               | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))
               | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
               | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))
+              | PaMod (loc, m) -> mkpat loc (Ppat_unpack m)
               | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _
                  as p) -> error (loc_of_patt p) "invalid pattern"
             and mklabpat =
@@ -15096,9 +15124,12 @@ module Struct =
               | Ast.ExOpI (loc, i, e) ->
                   mkexp loc (Pexp_open ((long_uident i), (expr e)))
               | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) ->
-                  mkexp loc (Pexp_pack ((module_expr me), (package_type pt)))
-              | Ast.ExPkg (loc, _) ->
-                  error loc "(module_expr : package_type) expected here"
+                  mkexp loc
+                    (Pexp_constraint
+                       (((mkexp loc (Pexp_pack (module_expr me))),
+                         (Some (mktyp loc (Ptyp_package (package_type pt)))),
+                         None)))
+              | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me))
               | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e)))
               | Ast.ExCom (loc, _, _) ->
                   error loc "expr, expr: not allowed here"
@@ -15265,9 +15296,15 @@ module Struct =
                   mkmod loc
                     (Pmod_constraint ((module_expr me), (module_type mt)))
               | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) ->
-                  mkmod loc (Pmod_unpack ((expr e), (package_type pt)))
-              | Ast.MePkg (loc, _) ->
-                  error loc "(value expr) not supported yet"
+                  mkmod loc
+                    (Pmod_unpack
+                       (mkexp loc
+                          (Pexp_constraint
+                             (((expr e),
+                               (Some
+                                  (mktyp loc (Ptyp_package (package_type pt)))),
+                               None)))))
+              | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e))
               | Ast.MeAnt (loc, _) ->
                   error loc "antiquotation in module_expr"
             and str_item s l =
@@ -16333,6 +16370,12 @@ module Struct =
           
         module Tools =
           struct
+            type prev_locs =
+              { mutable pl_strm : Obj.t; mutable pl_locs : (int * Obj.t) list
+              }
+            
+            let prev_locs = ref ([] : prev_locs list)
+              
             module Make (Structure : Structure.S) =
               struct
                 open Structure
@@ -16354,25 +16397,42 @@ module Struct =
                   match Stream.peek strm with
                   | None -> Stream.sempty
                   | Some ((_, init_loc)) ->
+                      let myrecord =
+                        {
+                          pl_strm = Obj.repr Stream.sempty;
+                          pl_locs = [ (0, (Obj.repr init_loc)) ];
+                        } in
                       let rec go prev_loc (__strm : _ Stream.t) =
                         (match Stream.peek __strm with
                          | Some ((tok, cur_loc)) ->
                              (Stream.junk __strm;
                               let strm = __strm
                               in
-                                Stream.lcons
-                                  (fun _ ->
-                                     (tok,
-                                      {
-                                        prev_loc = prev_loc;
-                                        cur_loc = cur_loc;
-                                      }))
-                                  (Stream.slazy (fun _ -> go cur_loc strm)))
-                         | _ -> Stream.sempty)
-                      in go init_loc strm
+                                (myrecord.pl_locs <-
+                                   myrecord.pl_locs @
+                                     [ ((Stream.count strm),
+                                        (Obj.repr cur_loc)) ];
+                                 Stream.lcons
+                                   (fun _ ->
+                                      (tok,
+                                       {
+                                         prev_loc = prev_loc;
+                                         cur_loc = cur_loc;
+                                       }))
+                                   (Stream.slazy (fun _ -> go cur_loc strm))))
+                         | _ ->
+                             (prev_locs :=
+                                List.filter (( != ) myrecord) !prev_locs;
+                              Stream.
+                              sempty)) in
+                      let result = go init_loc strm
+                      in
+                        (prev_locs := myrecord :: !prev_locs;
+                         myrecord.pl_strm <- Obj.repr result;
+                         result)
                   
                 let drop_prev_loc strm =
-                  stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm
+                  stream_map (fun (tok, r) -> (tok, r)) strm
                   
                 let get_cur_loc strm =
                   match Stream.peek strm with
@@ -16380,9 +16440,29 @@ module Struct =
                   | None -> Loc.ghost
                   
                 let get_prev_loc strm =
-                  match Stream.peek strm with
-                  | Some ((_, r)) -> r.prev_loc
-                  | None -> Loc.ghost
+                  let c = Stream.count strm in
+                  let rec drop l =
+                    match l with
+                    | [] -> []
+                    | (i, _) :: ll -> if i < c then drop ll else l in
+                  let rec find l =
+                    match l with
+                    | [] -> None
+                    | h :: t ->
+                        if h.pl_strm == (Obj.repr strm)
+                        then Some h
+                        else find t
+                  in
+                    match find !prev_locs with
+                    | None -> Loc.ghost
+                    | Some r ->
+                        (r.pl_locs <- drop r.pl_locs;
+                         (match r.pl_locs with
+                          | [] -> Loc.ghost
+                          | (i, loc) :: _ ->
+                              if i = c
+                              then (Obj.obj loc : Loc.t)
+                              else Loc.ghost))
                   
                 let is_level_labelled n lev =
                   match lev.lname with | Some n1 -> n = n1 | None -> false
@@ -19616,6 +19696,7 @@ module Printers =
                       | Ast.PaId (_, i) -> o#var_ident f i
                       | Ast.PaAnt (_, s) -> o#anti f s
                       | Ast.PaAny _ -> pp f "_"
+                      | Ast.PaMod (_, m) -> pp f "(module %s)" m
                       | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p
                       | Ast.PaRec (_, p) -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
                       | Ast.PaStr (_, s) -> pp f "\"%s\"" s
diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml
index 67d865b5b3..e4c2b0192e 100644
--- a/camlp4/boot/Camlp4Ast.ml
+++ b/camlp4/boot/Camlp4Ast.ml
@@ -108,12 +108,12 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
       | Ast.PaLab _ _ p -> is_irrefut_patt p
       | Ast.PaLaz _ p -> is_irrefut_patt p
       | Ast.PaId _ _ -> False
-      | (* here one need to know the arity of constructors *)
-          Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
-            Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
-            Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
-            Ast.PaAnt _ _
-          -> False ];
+      | (* here one need to know the arity of constructors *) Ast.PaMod _ _
+          -> True
+      | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
+          Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
+          Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
+          Ast.PaAnt _ _ -> False ];
     value rec is_constructor =
       fun
       [ Ast.IdAcc _ _ i -> is_constructor i
@@ -1902,7 +1902,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                            (Ast.IdUid _loc "OvOverride")) ]
                 and meta_patt _loc =
                   fun
-                  [ Ast.PaLaz x0 x1 ->
+                  [ Ast.PaMod x0 x1 ->
+                      Ast.ExApp _loc
+                        (Ast.ExApp _loc
+                           (Ast.ExId _loc
+                              (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                 (Ast.IdUid _loc "PaMod")))
+                           (meta_loc _loc x0))
+                        (meta_string _loc x1)
+                  | Ast.PaLaz x0 x1 ->
                       Ast.ExApp _loc
                         (Ast.ExApp _loc
                            (Ast.ExId _loc
@@ -3970,7 +3978,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                            (Ast.IdUid _loc "OvOverride")) ]
                 and meta_patt _loc =
                   fun
-                  [ Ast.PaLaz x0 x1 ->
+                  [ Ast.PaMod x0 x1 ->
+                      Ast.PaApp _loc
+                        (Ast.PaApp _loc
+                           (Ast.PaId _loc
+                              (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                 (Ast.IdUid _loc "PaMod")))
+                           (meta_loc _loc x0))
+                        (meta_string _loc x1)
+                  | Ast.PaLaz x0 x1 ->
                       Ast.PaApp _loc
                         (Ast.PaApp _loc
                            (Ast.PaId _loc
@@ -4872,7 +4888,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1
           | PaLaz _x _x_i1 ->
-              let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ];
+              let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1
+          | PaMod _x _x_i1 ->
+              let _x = o#loc _x in
+              let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ];
         method override_flag : override_flag -> override_flag =
           fun
           [ OvOverride -> OvOverride
@@ -5653,7 +5672,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o
           | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o
           | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
-          | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ];
+          | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o
+          | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ];
         method override_flag : override_flag -> 'self_type =
           fun
           [ OvOverride -> o
diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
index 618693ed88..20482abcb5 100644
--- a/camlp4/boot/camlp4boot.ml
+++ b/camlp4/boot/camlp4boot.ml
@@ -3668,6 +3668,29 @@ Very old (no more supported) syntax:\n\
                           (Gram.Action.mk
                              (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
                                 (p : 'patt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (package_type : 'package_type Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
+                                _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+                                   (Ast.TyPkg (_loc, pt))) :
+                                  'patt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+                                -> (Ast.PaMod (_loc, m) : 'patt))));
                          ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
                           (Gram.Action.mk
                              (fun _ _ (_loc : Gram.Loc.t) ->
@@ -4116,6 +4139,29 @@ Very old (no more supported) syntax:\n\
                           (Gram.Action.mk
                              (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) ->
                                 (p : 'ipatt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (package_type : 'package_type Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
+                                _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+                                   (Ast.TyPkg (_loc, pt))) :
+                                  'ipatt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+                                -> (Ast.PaMod (_loc, m) : 'ipatt))));
                          ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
                           (Gram.Action.mk
                              (fun _ _ (_loc : Gram.Loc.t) ->
@@ -15204,8 +15250,7 @@ module B =
               load [ "Camlp4ExceptionTracer" ]
           | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) ->
               load [ "Camlp4Profiler" ]
-          | (* map is now an alias of fold since fold handles map too *)
-              (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
+          | (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
               load [ "Camlp4FoldGenerator" ]
           | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) ->
               load [ "Camlp4FoldGenerator" ]
@@ -15233,6 +15278,7 @@ module B =
               in real_load (try find_in_path y with | Not_found -> x));
          !rcall_callback ())
       
+    (* map is now an alias of fold since fold handles map too *)
     let print_warning = eprintf "%a:\n%s@." Loc.print
       
     let rec parse_file dyn_loader name pa getdir =
@@ -15308,17 +15354,17 @@ Options:\n\
 <file>.%s Load this module inside the Camlp4 core@."
          (if DynLoader.is_native then "cmxs     " else "(cmo|cma)");
        Options.print_usage_list ini_sl;
-       (* loop (ini_sl @ ext_sl) where rec loop =
-      fun
-      [ [(y, _, _) :: _] when y = "-help" -> ()
-      | [_ :: sl] -> loop sl
-      | [] -> eprintf "  -help         Display this list of options.@." ];    *)
        if ext_sl <> []
        then
          (eprintf "Options added by loaded object files:@.";
           Options.print_usage_list ext_sl)
        else ())
       
+    (* loop (ini_sl @ ext_sl) where rec loop =
+      fun
+      [ [(y, _, _) :: _] when y = "-help" -> ()
+      | [_ :: sl] -> loop sl
+      | [] -> eprintf "  -help         Display this list of options.@." ];    *)
     let warn_noassert () =
       eprintf
         "\
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index bbeba47a84..c497794184 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -1647,7 +1647,7 @@ module Analyser =
             m_kind = Module_struct elements2 ;
           }
 
-      | (Parsetree.Pmod_unpack (p_exp, pkg_type),
+      | (Parsetree.Pmod_unpack (p_exp),
          Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->
           print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);
           let code =
@@ -1658,7 +1658,13 @@ module Analyser =
             let s = get_string_of_file exp_loc_end loc_end in
             Printf.sprintf "(val ...%s" s
           in
-          let name = Odoc_env.full_module_type_name env (Name.from_longident (fst pkg_type)) in
+          (* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *)
+          let name =
+            match tt_modtype with
+            | Tmty_ident p ->
+                Odoc_env.full_module_type_name env (Name.from_path p)
+            | _ -> ""
+          in
           let alias = { mta_name = name ; mta_module = None } in
           { m_base with
             m_type = Odoc_env.subst_module_type env tt_modtype ;
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 2848143904..6742039c11 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -406,7 +406,7 @@ open Parsetree
 
 let rec bound_variables pat =
   match pat.ppat_desc with
-    Ppat_any | Ppat_constant _ | Ppat_type _ -> []
+    Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
   | Ppat_var s -> [s]
   | Ppat_alias (pat,s) -> s :: bound_variables pat
   | Ppat_tuple l -> List2.flat_map l ~f:bound_variables
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 4f9bcc58b5..b4fa1d41b1 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -453,10 +453,24 @@ module_expr:
       { $2 }
   | LPAREN module_expr error
       { unclosed "(" 1 ")" 3 }
+  | LPAREN VAL expr RPAREN
+      { mkmod(Pmod_unpack $3) }
   | LPAREN VAL expr COLON package_type RPAREN
-      { mkmod(Pmod_unpack($3, $5)) }
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), None)))) }
+  | LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)),
+                                    Some(ghtyp(Ptyp_package $7)))))) }
+  | LPAREN VAL expr COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, None, Some(ghtyp(Ptyp_package $5)))))) }
   | LPAREN VAL expr COLON error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr COLONGREATER error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr error
+      { unclosed "(" 1 ")" 4 }
 ;
 structure:
     structure_tail                              { $1 }
@@ -1021,8 +1035,11 @@ simple_expr:
       { mkexp(Pexp_override []) }
   | simple_expr SHARP label
       { mkexp(Pexp_send($1, $3)) }
+  | LPAREN MODULE module_expr RPAREN
+      { mkexp (Pexp_pack $3) }
   | LPAREN MODULE module_expr COLON package_type RPAREN
-      { mkexp (Pexp_pack ($3, $5)) }
+      { mkexp (Pexp_constraint (ghexp (Pexp_pack $3),
+                                Some (ghtyp (Ptyp_package $5)), None)) }
   | LPAREN MODULE module_expr COLON error
       { unclosed "(" 1 ")" 5 }
 ;
@@ -1191,6 +1208,12 @@ simple_pattern:
       { mkpat(Ppat_constraint($2, $4)) }
   | LPAREN pattern COLON core_type error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN MODULE UIDENT RPAREN
+      { mkpat(Ppat_unpack $3) }
+  | LPAREN MODULE UIDENT COLON package_type RPAREN
+      { mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) }
+  | LPAREN MODULE UIDENT COLON package_type error
+      { unclosed "(" 1 ")" 6 }
 ;
 
 pattern_comma_list:
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd037..976283ff19 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -79,6 +79,7 @@ and pattern_desc =
   | Ppat_constraint of pattern * core_type
   | Ppat_type of Longident.t
   | Ppat_lazy of pattern
+  | Ppat_unpack of string
 
 type expression =
   { pexp_desc: expression_desc;
@@ -116,7 +117,7 @@ and expression_desc =
   | Pexp_poly of expression * core_type option
   | Pexp_object of class_structure
   | Pexp_newtype of string * expression
-  | Pexp_pack of module_expr * package_type
+  | Pexp_pack of module_expr
   | Pexp_open of Longident.t * expression
 
 (* Value descriptions *)
@@ -249,7 +250,7 @@ and module_expr_desc =
   | Pmod_functor of string * module_type * module_expr
   | Pmod_apply of module_expr * module_expr
   | Pmod_constraint of module_expr * module_type
-  | Pmod_unpack of expression * package_type
+  | Pmod_unpack of expression
 
 and structure = structure_item list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b879..2b236ae827 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -209,6 +209,8 @@ and pattern i ppf x =
   | Ppat_type li ->
       line i ppf "Ppat_type";
       longident i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack \"%s\"\n" s;
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
@@ -321,9 +323,8 @@ and expression i ppf x =
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype \"%s\"\n" s;
       expression i ppf e
-  | Pexp_pack (me, (p,l)) ->
-      line i ppf "Pexp_pack %a" fmt_longident p;
-      list i package_with ppf l;
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack";
       module_expr i ppf me
   | Pexp_open (m, e) ->
       line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
@@ -593,9 +594,8 @@ and module_expr i ppf x =
       line i ppf "Pmod_constraint\n";
       module_expr i ppf me;
       module_type i ppf mt;
-  | Pmod_unpack (e, (p, l)) ->
-      line i ppf "Pmod_unpack %a\n" fmt_longident p;
-      list i package_with ppf l;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
       expression i ppf e;
 
 and structure i ppf x = list i structure_item ppf x
diff --git a/testlabl/implicit_unpack.ml b/testlabl/implicit_unpack.ml
new file mode 100644
index 0000000000..db65dae3da
--- /dev/null
+++ b/testlabl/implicit_unpack.ml
@@ -0,0 +1,116 @@
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index 15ad6f5a1f..6a297b9e86 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -64,7 +64,7 @@ let rec pattern_vars pat =
       pattern_vars pat1 @ pattern_vars pat2
   | Ppat_lazy pat -> pattern_vars pat
   | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
-  | Ppat_type _ ->
+  | Ppat_type _ | Ppat_unpack _ ->
       []
 
 let pattern_name pat =
diff --git a/tools/depend.ml b/tools/depend.ml
index 44e85702bd..4a0da760b2 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -118,6 +118,7 @@ let rec add_pattern bv pat =
   | Ppat_variant(_, op) -> add_opt add_pattern bv op
   | Ppat_type (li) -> add bv li
   | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack _ -> ()
 
 let rec add_expr bv exp =
   match exp.pexp_desc with
@@ -163,7 +164,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_pack (m, pt) -> add_package_type bv pt; add_module bv m
+  | Pexp_pack m -> add_module bv m
   | 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
@@ -228,8 +229,7 @@ and add_module bv modl =
       add_module bv mod1; add_module bv mod2
   | Pmod_constraint(modl, mty) ->
       add_module bv modl; add_modtype bv mty
-  | Pmod_unpack(e, pt) ->
-      add_package_type bv pt;
+  | Pmod_unpack(e) ->
       add_expr bv e
 
 and add_structure bv item_list =
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index e561f60e62..f58712ec51 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -287,7 +287,7 @@ and rw_exp iflag sexp =
 
   | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
   | Pexp_open (_, e) -> rewrite_exp iflag e
-  | Pexp_pack (smod, _) -> rewrite_mod iflag smod
+  | Pexp_pack (smod) -> rewrite_mod iflag smod
 
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
@@ -362,7 +362,7 @@ and rewrite_mod iflag smod =
   | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
   | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
   | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
-  | Pmod_unpack(sexp, _) -> rewrite_exp iflag sexp
+  | Pmod_unpack(sexp) -> rewrite_exp iflag sexp
 
 and rewrite_str_item iflag item =
   match item.pstr_desc with
diff --git a/typing/ctype.ml b/typing/ctype.ml
index a722522d3c..40c400b182 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1927,9 +1927,9 @@ let rec filter_arrow env t l =
   let t = expand_head_unif env t in
   match t.desc with
     Tvar ->
-      let t1 = newvar () and t2 = newvar () in
-      let t' = newty (Tarrow (l, t1, t2, Cok)) in
-      update_level env t.level t';
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
       link_type t t';
       (t1, t2)
   | Tarrow(l', t1, t2, _)
@@ -2763,16 +2763,16 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
-let rec lid_of_path sharp = function
+let rec lid_of_path ?(sharp="") = function
     Path.Pident id ->
       Longident.Lident (sharp ^ Ident.name id)
   | Path.Pdot (p1, s, _) ->
-      Longident.Ldot (lid_of_path "" p1, sharp ^ s)
+      Longident.Ldot (lid_of_path p1, sharp ^ s)
   | Path.Papply (p1, p2) ->
-      Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
+      Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
 
 let find_cltype_for_path env p =
-  let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
+  let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
   match cl_abbr.type_manifest with
     Some ty ->
       begin match (repr ty).desc with
@@ -2977,6 +2977,23 @@ let private_abbrev env path =
     decl.type_private = Private && decl.type_manifest <> None
   with Not_found -> false
 
+(* check list inclusion, assuming lists are ordered *)
+let rec included nl1 nl2 =
+  match nl1, nl2 with
+    (a::nl1', b::nl2') ->
+      if a = b then included nl1' nl2' else
+      a > b && included nl1 nl2'
+  | ([], _) -> true
+  | (_, []) -> false
+
+let rec extract_assoc nl1 nl2 tl2 =
+  match (nl1, nl2, tl2) with
+    (a::nl1', b::nl2, t::tl2) ->
+      if a = b then t :: extract_assoc nl1' nl2 tl2
+      else extract_assoc nl1 nl2 tl2
+  | ([], _, _) -> []
+  | _ -> assert false
+
 let rec subtype_rec env trace t1 t2 cstrs =
   let t1 = repr t1 in
   let t2 = repr t2 in
@@ -3047,6 +3064,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
         with Unify _ ->
           (trace, t1, t2, !univar_pairs)::cstrs
         end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2))
+      when Path.same p1 p2 && included nl2 nl1 ->
+        List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs))
+          (extract_assoc nl2 nl1 tl1) tl2
+        @ cstrs
     | (_, _) ->
         (trace, t1, t2, !univar_pairs)::cstrs
   end
diff --git a/typing/ctype.mli b/typing/ctype.mli
index af2c7fd0c2..5e0db4a99d 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -74,6 +74,7 @@ val set_object_name:
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+val lid_of_path: ?sharp:string -> Path.t -> Longident.t
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 486115488a..511bb5e36d 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -56,6 +56,9 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
 
 exception Error of Location.t * error
 
@@ -70,6 +73,10 @@ let type_module =
 let type_open =
   ref (fun _ -> assert false)
 
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
 
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
@@ -196,20 +203,29 @@ let has_variants p =
 let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
 let pattern_force = ref ([] : (unit -> unit) list)
 let pattern_scope = ref (None : Annot.ident option);;
-let reset_pattern scope =
+let allow_modules = ref false
+let module_variables = ref ([] : (string * Location.t) list)
+let reset_pattern scope allow =
   pattern_variables := [];
   pattern_force := [];
   pattern_scope := scope;
+  allow_modules := allow;
+  module_variables := [];
 ;;
 
-let enter_variable loc name ty =
+let enter_variable ?(is_module=false) loc name ty =
   if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
   then raise(Error(loc, Multiply_bound_variable name));
   let id = Ident.create name in
   pattern_variables := (id, ty, loc) :: !pattern_variables;
-  begin match !pattern_scope with
-  | None -> ()
-  | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then raise (Error (loc, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end else begin
+    match !pattern_scope with
+    | None -> ()
+    | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
   end;
   id
 
@@ -408,6 +424,14 @@ let rec type_pat env sp =
         pat_loc = loc;
         pat_type = ty;
         pat_env = env }
+  | Ppat_unpack name ->
+      let ty = newvar() in
+      let id = enter_variable loc name ty ~is_module:true in
+      rp {
+        pat_desc = Tpat_var id;
+        pat_loc = loc;
+        pat_type = ty;
+        pat_env = env }
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
@@ -569,27 +593,28 @@ let get_ref r =
 
 let add_pattern_variables env =
   let pv = get_ref pattern_variables in
-  List.fold_right
+  (List.fold_right
     (fun (id, ty, loc) env ->
        let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
-       Env.add_annot id (Annot.Iref_internal loc) e1;
+       Env.add_annot id (Annot.Iref_internal loc) e1
     )
-    pv env
+    pv env,
+   get_ref module_variables)
 
 let type_pattern env spat scope =
-  reset_pattern scope;
+  reset_pattern scope true;
   let pat = type_pat env spat in
-  let new_env = add_pattern_variables env in
-  (pat, new_env, get_ref pattern_force)
+  let new_env, unpacks = add_pattern_variables env in
+  (pat, new_env, get_ref pattern_force, unpacks)
 
-let type_pattern_list env spatl scope =
-  reset_pattern scope;
+let type_pattern_list env spatl scope allow =
+  reset_pattern scope allow;
   let patl = List.map (type_pat env) spatl in
-  let new_env = add_pattern_variables env in
-  (patl, new_env, get_ref pattern_force)
+  let new_env, unpacks = add_pattern_variables env in
+  (patl, new_env, get_ref pattern_force, unpacks)
 
 let type_class_arg_pattern cl_num val_env met_env l spat =
-  reset_pattern None;
+  reset_pattern None false;
   let pat = type_pat val_env spat in
   if has_variants pat then begin
     Parmatch.pressure_variants val_env [pat];
@@ -607,7 +632,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
             env))
       !pattern_variables ([], met_env)
   in
-  let val_env = add_pattern_variables val_env in
+  let val_env, _ = add_pattern_variables val_env in
   (pat, pv, val_env, met_env)
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
@@ -617,7 +642,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
   in
-  reset_pattern None;
+  reset_pattern None false;
   let pat = type_pat val_env spat in
   List.iter (fun f -> f()) (get_ref pattern_force);
   let meths = ref Meths.empty in
@@ -1009,6 +1034,16 @@ let create_package_type loc env (p, l) =
                    List.map fst l,
                    List.map (Typetexp.transl_simple_type env false) (List.map snd l)))
 
+let wrap_unpacks sexp unpacks =
+  List.fold_left
+    (fun sexp (name, loc) ->
+      {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
+       name,
+       {pmod_loc = loc; pmod_desc = Pmod_unpack
+          {pexp_desc=Pexp_ident(Longident.Lident name); pexp_loc=loc}},
+       sexp)})
+    sexp unpacks
+
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
@@ -1077,8 +1112,9 @@ let rec type_exp env sexp =
         | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
         | Default -> None
       in
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
-      let body = type_exp new_env sbody in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let env rec_flag spat_sexp_list scp true in
+      let body = type_exp new_env (wrap_unpacks sbody unpacks) in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = loc;
@@ -1116,7 +1152,12 @@ let rec type_exp env sexp =
         exp_type = ty_res;
         exp_env = env }
   | Pexp_match(sarg, caselist) ->
+      if !Clflags.principal then begin_def ();
       let arg = type_exp env sarg in
+      if !Clflags.principal then begin
+          end_def ();
+          generalize_structure arg.exp_type;
+      end;
       let ty_res = newvar() in
       let cases, partial =
         type_cases env arg.exp_type ty_res (Some loc) caselist
@@ -1129,8 +1170,7 @@ let rec type_exp env sexp =
   | Pexp_try(sbody, caselist) ->
       let body = type_exp env sbody in
       let cases, _ =
-        type_cases
-          env (instance Predef.type_exn) body.exp_type None caselist in
+        type_cases env Predef.type_exn body.exp_type None caselist in
       re {
         exp_desc = Texp_try(body, cases);
         exp_loc = loc;
@@ -1300,10 +1340,10 @@ let rec type_exp env sexp =
             if !Clflags.principal then begin
               end_def ();
               generalize_structure ty;
-              let ty1 = instance ty and ty2 = instance ty in
-              (type_expect env sarg ty1, ty2)
+              let ty2 = instance ty in
+              (type_argument env sarg ty, ty2)
             end else
-              (type_expect env sarg ty, ty)
+              (type_argument env sarg ty, ty)
         | (None, Some sty') ->
             let (ty', force) =
               Typetexp.transl_simple_type_delayed env sty'
@@ -1355,6 +1395,7 @@ let rec type_exp env sexp =
             end;
             (arg, ty')
         | (Some sty, Some sty') ->
+            if !Clflags.principal then begin_def ();
             let (ty, force) =
               Typetexp.transl_simple_type_delayed env sty
             and (ty', force') =
@@ -1366,7 +1407,13 @@ let rec type_exp env sexp =
             with Subtype (tr1, tr2) ->
               raise(Error(loc, Not_subtype(tr1, tr2)))
             end;
-            (type_expect env sarg ty, ty')
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty;
+              generalize_structure ty';
+              (type_argument env sarg ty, instance ty')
+            end else
+              (type_argument env sarg ty, ty')
       in
       re {
         exp_desc = arg.exp_desc;
@@ -1626,18 +1673,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_pack (m, (p, l)) ->
-      let loc = sexp.pexp_loc in
-      let l, mty = Typetexp.create_package_mty loc env (p, l) in
-      let m = {pmod_desc = Pmod_constraint (m, mty); pmod_loc = loc} in
-      let context = Typetexp.narrow () in
-      let modl = !type_module env m in
-      Typetexp.widen context;
-      re {
-        exp_desc = Texp_pack modl;
-        exp_loc = loc;
-        exp_type = create_package_type loc env (p, l);
-        exp_env = env }
+  | Pexp_pack m ->
+      raise (Error (loc, Cannot_infer_signature))
   | Pexp_open (lid, e) ->
       type_exp (!type_open env sexp.pexp_loc lid) e
 
@@ -1689,7 +1726,7 @@ and type_argument env sarg ty_expected' =
   let ty_expected = instance ty_expected' in
   match expand_head env ty_expected', sarg with
   | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
-      type_expect env sarg ty_expected
+      type_expect env sarg ty_expected'
   | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
       (* apply optional arguments when expected type is "" *)
       (* we must be very careful about not breaking the semantics *)
@@ -1746,7 +1783,7 @@ and type_argument env sarg ty_expected' =
            Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
       end
   | _ ->
-      type_expect env sarg ty_expected
+      type_expect env sarg ty_expected'
 
 and type_application env funct sargs =
   (* funct.exp_type may be generic *)
@@ -1932,30 +1969,36 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
   if List.length sargs <> constr.cstr_arity then
     raise(Error(loc, Constructor_arity_mismatch
                   (lid, constr.cstr_arity, List.length sargs)));
-  if !Clflags.principal then begin_def ();
+  if !Clflags.principal then (begin_def (); begin_def ());
   let (ty_args, ty_res) = instance_constructor constr in
-  if !Clflags.principal then begin
-    end_def ();
-    List.iter generalize_structure ty_args;
-    generalize_structure ty_res
-  end;
   let texp =
     re {
       exp_desc = Texp_construct(constr, []);
       exp_loc = loc;
-      exp_type = instance ty_res;
+      exp_type = ty_res;
       exp_env = env } in
-  unify_exp env texp ty_expected;
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure ty_res;
+    unify_exp env {texp with exp_type = instance ty_res}
+                  (instance ty_expected);
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let texp = {texp with exp_type = instance ty_res} in
+  if not !Clflags.principal then unify_exp env texp (instance ty_expected);
   let args = List.map2 (type_argument env) sargs ty_args in
   if constr.cstr_private = Private then
     raise(Error(loc, Private_type ty_res));
-  { texp with exp_desc = Texp_construct(constr, args) }
+  { texp with exp_desc = Texp_construct(constr, args)}
 
 (* Typing of an expression with an expected type.
    Some constructs are treated specially to provide better error messages. *)
 
-and type_expect ?in_function env sexp ty_expected =
+and type_expect ?in_function env sexp ty_expected' =
   let loc = sexp.pexp_loc in
+  let ty_expected = instance ty_expected' in
   match sexp.pexp_desc with
     Pexp_constant(Const_string s as cst) ->
       let exp =
@@ -1973,10 +2016,31 @@ and type_expect ?in_function env sexp ty_expected =
       unify_exp env exp ty_expected;
       exp
   | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env loc lid sarg explicit_arity ty_expected
+      type_construct env loc lid sarg explicit_arity ty_expected'
+  | Pexp_variant(l, Some sarg) ->
+      begin try match expand_head env ty_expected' with
+      | {desc = Tvariant row} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields) with
+            Rpresent (Some ty) ->
+              let arg = type_argument env sarg ty in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc;
+                   exp_type = ty_expected;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let exp = type_exp env sexp in
+        unify_exp env exp ty_expected;
+        exp
+      end
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
-      let body = type_expect new_env sbody ty_expected in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let env rec_flag spat_sexp_list None true in
+      let body =
+        type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = loc;
@@ -2011,8 +2075,7 @@ and type_expect ?in_function env sexp ty_expected =
         pexp_desc =
           Pexp_match ({
             pexp_loc = loc;
-            pexp_desc =
-              Pexp_ident(Longident.Lident "*opt*")
+            pexp_desc = Pexp_ident(Longident.Lident "*opt*")
             },
             scases
           )
@@ -2021,25 +2084,24 @@ and type_expect ?in_function env sexp ty_expected =
         pexp_loc = loc;
         pexp_desc =
          Pexp_function (
-           l,
-           None,
+           l, None,
            [ {ppat_loc = loc;
               ppat_desc = Ppat_var "*opt*"},
              {pexp_loc = loc;
-              pexp_desc =
-                Pexp_let(Default, [spat, smatch], sbody);
+              pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
              }
            ]
          )
       } in
-      type_expect ?in_function env sfun ty_expected
+      type_expect ?in_function env sfun ty_expected'
   | Pexp_function (l, _, caselist) ->
       let (loc_fun, ty_fun) =
         match in_function with Some p -> p
         | None -> (loc, ty_expected)
       in
+      if !Clflags.principal then begin_def ();
       let (ty_arg, ty_res) =
-        try filter_arrow env ty_expected l
+        try filter_arrow env (instance ty_expected') l
         with Unify _ ->
           match expand_head env ty_expected with
             {desc = Tarrow _} as ty ->
@@ -2052,12 +2114,17 @@ and type_expect ?in_function env sexp ty_expected =
         if is_optional l then
           let tv = newvar() in
           begin
-            try unify env ty_arg (type_option tv)
+            try unify env (instance ty_arg) (type_option tv)
             with Unify _ -> assert false
           end;
           type_option tv
         else ty_arg
       in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty_arg;
+        generalize_structure ty_res
+      end;
       let cases, partial =
         type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
           (Some loc) caselist in
@@ -2071,7 +2138,7 @@ and type_expect ?in_function env sexp ty_expected =
       re {
         exp_desc = Texp_function(cases, partial);
         exp_loc = loc;
-        exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
+        exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
         exp_env = env }
   | Pexp_when(scond, sbody) ->
       let cond = type_expect env scond (instance Predef.type_bool) in
@@ -2110,6 +2177,31 @@ and type_expect ?in_function env sexp ty_expected =
             re { exp with exp_type = ty }
         | _ -> assert false
       end
+  | Pexp_pack m ->
+      let (p, nl, tl) =
+        match Ctype.expand_head env ty_expected with
+          {desc = Tpackage (p, nl, tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected').level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl, tl)
+        | {desc = Tvar} ->
+            raise (Error (loc, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, Not_a_packed_module ty_expected))
+      in
+      let context = Typetexp.narrow () in
+      let (modl, tl') = !type_package env m p nl tl in
+      Typetexp.widen context;
+      let exp = {
+        exp_desc = Texp_pack modl;
+        exp_loc = loc;
+        exp_type = newty (Tpackage (p, nl, tl'));
+        exp_env = env } in
+      unify_exp env exp ty_expected;
+      re {exp with exp_type = ty_expected}
   | _ ->
       let exp = type_exp env sexp in
       unify_exp env exp ty_expected;
@@ -2144,15 +2236,16 @@ and type_statement env sexp =
 (* Typing of match cases *)
 
 and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
+  if !Clflags.principal then begin_def (); (* propagation of the argument *)
   let ty_arg' = newvar () in
   let pattern_force = ref [] in
   let pat_env_list =
     List.map
       (fun (spat, sexp) ->
         let loc = sexp.pexp_loc in
-        if !Clflags.principal then begin_def ();
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
         let scope = Some (Annot.Idef loc) in
-        let (pat, ext_env, force) = type_pattern env spat scope in
+        let (pat, ext_env, force, unpacks) = type_pattern env spat scope in
         pattern_force := force @ !pattern_force;
         let pat =
           if !Clflags.principal then begin
@@ -2162,7 +2255,7 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
           end else pat
         in
         unify_pat env pat ty_arg';
-        (pat, ext_env))
+        (pat, (ext_env, unpacks)))
       caselist in
   (* Check for polymorphic variants to close *)
   let patl = List.map fst pat_env_list in
@@ -2173,14 +2266,23 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
   (* `Contaminating' unifications start here *)
   List.iter (fun f -> f()) !pattern_force;
   begin match pat_env_list with [] -> ()
-  | (pat, _) :: _ -> unify_pat env pat ty_arg
+  | (pat, _) :: _ -> unify_pat env pat (instance ty_arg)
+  end;
+  if !Clflags.principal then begin
+    let patl = List.map fst pat_env_list in
+    List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
+      patl;
+    end_def ();
+    List.iter (iter_pattern (fun {pat_type=t} -> generalize_structure t)) patl
   end;
   let in_function = if List.length caselist = 1 then in_function else None in
+  let ty_arg' = instance ty_arg in
   let cases =
     List.map2
-      (fun (pat, ext_env) (spat, sexp) ->
+      (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
+        let sexp = wrap_unpacks sexp unpacks in
         let exp = type_expect ?in_function ext_env sexp ty_res in
-        (pat, exp))
+        ({pat with pat_type = ty_arg'}, exp))
       pat_env_list caselist
   in
   let partial =
@@ -2193,11 +2295,12 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
 
 (* Typing of let bindings *)
 
-and type_let env rec_flag spat_sexp_list scope =
+and type_let env rec_flag spat_sexp_list scope allow =
   begin_def();
   if !Clflags.principal then begin_def ();
   let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
-  let (pat_list, new_env, force) = type_pattern_list env spatl scope in
+  let (pat_list, new_env, force, unpacks) =
+    type_pattern_list env spatl scope allow in
   if rec_flag = Recursive then
     List.iter2
       (fun pat (_, sexp) ->
@@ -2232,6 +2335,8 @@ and type_let env rec_flag spat_sexp_list scope =
   let exp_list =
     List.map2
       (fun (spat, sexp) pat ->
+        let sexp =
+          if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
         match pat.pat_type.desc with
         | Tpoly (ty, tl) ->
             begin_def ();
@@ -2254,10 +2359,15 @@ and type_let env rec_flag spat_sexp_list scope =
   List.iter
     (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
     pat_list;
-  (List.combine pat_list exp_list, new_env)
+  (List.combine pat_list exp_list, new_env, unpacks)
 
 (* Typing of toplevel bindings *)
 
+let type_let env rec_flag spat_sexp_list scope =
+  let (pat_exp_list, new_env, unpacks) =
+    type_let env rec_flag spat_sexp_list scope false in
+  (pat_exp_list, new_env)
+
 let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
   type_let env rec_flag spat_sexp_list scope
@@ -2426,3 +2536,12 @@ let report_error ppf = function
       report_unification_error ppf trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      fprintf ppf "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      fprintf ppf
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is packed module, but the expected type is@ %a"
+        type_expr ty
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3fb90ff34e..1d3cda6dc2 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -57,6 +57,7 @@ val option_some: Typedtree.expression -> Typedtree.expression
 val option_none: type_expr -> Location.t -> Typedtree.expression
 val extract_option_type: Env.t -> type_expr -> type_expr
 val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
+val generalizable: int -> type_expr -> bool
 val reset_delayed_checks: unit -> unit
 val force_delayed_checks: unit -> unit
 
@@ -96,6 +97,9 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
 
 exception Error of Location.t * error
 
@@ -109,5 +113,8 @@ val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
 val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
    Typedtree.class_structure * class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> string list -> type_expr list ->
+   Typedtree.module_expr * type_expr list) ref
 
 val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 0dcd4aad01..2edf087e8b 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -39,6 +39,8 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
 
 exception Error of Location.t * error
 
@@ -631,6 +633,40 @@ let check_recmodule_inclusion env bindings =
     end
   in check_incl true (List.length bindings) env Subst.identity
 
+(* Helper for unpack *)
+
+let modtype_of_package env loc p nl tl =
+  try match Env.find_modtype p env with
+  | Tmodtype_manifest mty when nl <> [] ->
+      let sg = extract_sig env loc mty in
+      let ntl = List.combine nl tl in
+      let sg' =
+        List.map
+          (function
+              Tsig_type (id, ({type_params=[]} as td), rs) 
+              when List.mem (Ident.name id) nl ->
+                let ty = List.assoc (Ident.name id) ntl in
+                Tsig_type (id, {td with type_manifest = Some ty}, rs)
+            | item -> item)
+          sg in
+      Tmty_signature sg'
+  | _ ->
+      if nl = [] then Tmty_ident p
+      else raise(Error(loc, Signature_expected))
+  with Not_found ->
+    raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
+
+let wrap_constraint env arg mty =
+  let coercion =
+    try
+      Includemod.modtypes env arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_loc = arg.mod_loc }
+
 (* Type a module value expression *)
 
 let rec type_module sttn funct_body anchor env smod =
@@ -691,23 +727,35 @@ let rec type_module sttn funct_body anchor env smod =
   | Pmod_constraint(sarg, smty) ->
       let arg = type_module true funct_body anchor env sarg in
       let mty = transl_modtype env smty in
-      let coercion =
-        try
-          Includemod.modtypes env arg.mod_type mty
-        with Includemod.Error msg ->
-          raise(Error(sarg.pmod_loc, Not_included msg)) in
-      rm { mod_desc = Tmod_constraint(arg, mty, coercion);
-           mod_type = mty;
-           mod_env = env;
-           mod_loc = smod.pmod_loc }
+      rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc}
 
-  | Pmod_unpack (sexp, (p, l)) ->
+  | Pmod_unpack sexp ->
       if funct_body then
         raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
-      let l, mty = Typetexp.create_package_mty smod.pmod_loc env (p, l) in
-      let mty = transl_modtype env mty in
-      let exp = Typecore.type_expect env sexp
-          (Typecore.create_package_type smod.pmod_loc env (p, l)) in
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, nl, tl)} ->
+            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
+              raise (Error (smod.pmod_loc,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
+      in
       rm { mod_desc = Tmod_unpack(exp, mty);
            mod_type = mty;
            mod_env = env;
@@ -953,12 +1001,34 @@ let type_module_type_of env smod =
     raise(Error(smod.pmod_loc, Non_generalizable_module mty));
   mty
 
+(* For Typecore *)
+
+let rec get_manifest_types = function
+    [] -> []
+  | Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem ->
+      (Ident.name id, ty) :: get_manifest_types rem
+  | _ :: rem -> get_manifest_types rem
+
+let type_package env m p nl tl =
+  let modl = type_module env m in
+  if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
+  let msig = extract_sig env modl.mod_loc modl.mod_type in
+  let mtypes = get_manifest_types msig in
+  let tl' =
+    List.map2
+      (fun name ty -> try List.assoc name mtypes with Not_found -> ty)
+      nl tl
+  in
+  let mty = modtype_of_package env modl.mod_loc p nl tl' in
+  (wrap_constraint env modl mty, tl')
+
 (* Fill in the forward declarations *)
 let () =
   Typecore.type_module := type_module;
   Typetexp.transl_modtype_longident := transl_modtype_longident;
   Typetexp.transl_modtype := transl_modtype;
   Typecore.type_open := type_open;
+  Typecore.type_package := type_package;
   type_module_type_of_fwd := type_module_type_of
 
 (* Typecheck an implementation file *)
@@ -1106,3 +1176,11 @@ let report_error ppf = function
   | With_need_typeconstr ->
       fprintf ppf
         "Only type constructors with identical parameters can be substituted."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
diff --git a/typing/typemod.mli b/typing/typemod.mli
index d508a429c7..6272b56c08 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -51,6 +51,8 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
 
 exception Error of Location.t * error
 
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 4339d9b0d3..953ad9d157 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -76,6 +76,7 @@ let rec get_vars ((vacc, asacc) as acc) p =
   | Ppat_lazy p -> get_vars acc p
   | Ppat_constraint (pp, _) -> get_vars acc pp
   | Ppat_type _ -> acc
+  | Ppat_unpack _ -> acc
 
 and get_vars_option acc po =
   match po with
@@ -174,7 +175,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_pack (me, _) -> module_expr ppf tbl me
+  | Pexp_pack me -> module_expr ppf tbl me
   | Pexp_open (_, e) -> expression ppf tbl e
 
 and expression_option ppf tbl eo =
@@ -224,7 +225,7 @@ and module_expr ppf tbl me =
       module_expr ppf tbl me1;
       module_expr ppf tbl me2;
   | Pmod_constraint (me, _) -> module_expr ppf tbl me
-  | Pmod_unpack (e, _) -> expression ppf tbl e
+  | Pmod_unpack (e) -> expression ppf tbl e
 
 and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr