merge from HEADmultimatch

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

44 files changed, 1051 insertions, 553 deletions

diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index cf33545ad4..450321ac76 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -17,7 +17,6 @@
 
 open Misc
 open Instruct
-open Opcodes
 open Emitcode
 
 type error =
@@ -130,40 +129,21 @@ let rec rename_append_bytecode_list oc mapping defined ofs = function
         oc mapping (Ident.create_persistent compunit.cu_name :: defined)
         (ofs + size) rem
 
-(* Generate the code that builds the tuple representing the package
-   module:
-     GETGLOBAL M.An
-     PUSHGETGLOBAL M.An-1
-     ...
-     PUSHGETGLOBAL M.A1
-     MAKEBLOCK tag = 0 size = n
-     SETGLOBAL M
-*)
-
-let build_global_target oc target_name mapping ofs =
-  let out_word n =
-    output_byte oc n;
-    output_byte oc (n lsr 8);
-    output_byte oc (n lsr 16);
-    output_byte oc (n lsr 24) in
-  let rec build_global first pos = function
-    [] ->
-      out_word opMAKEBLOCK;             (* pos *)
-      out_word (List.length mapping);   (* pos + 4 *)
-      out_word 0;                       (* pos + 8 *)
-      out_word opSETGLOBAL;             (* pos + 12 *)
-      out_word 0;                       (* pos + 16 *)
-      relocs := (Reloc_setglobal target_name, pos + 16) :: !relocs
-  | (oldname, newname) :: rem ->
-      out_word (if first then opGETGLOBAL else opPUSHGETGLOBAL); (* pos *)
-      out_word 0;                       (* pos + 4 *)
-      relocs := (Reloc_getglobal newname, pos + 4) :: !relocs;
-      build_global false (pos + 8) rem in
-  build_global true ofs (List.rev mapping)
+(* Generate the code that builds the tuple representing the package module *)
+
+let build_global_target oc target_name mapping pos coercion =
+  let lam =
+    Translmod.transl_package (List.map snd mapping)
+                             (Ident.create_persistent target_name) coercion in
+  let instrs =
+    Bytegen.compile_implementation target_name lam in
+  let rel =
+    Emitcode.to_packed_file oc instrs in
+  relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
 
 (* Build the .cmo file obtained by packaging the given .cmo files. *)
 
-let package_object_files objfiles targetfile targetname =
+let package_object_files objfiles targetfile targetname coercion =
   let units =
     List.map (fun f -> (f, read_unit_info f)) objfiles in
   let unit_names =
@@ -181,9 +161,10 @@ let package_object_files objfiles targetfile targetname =
     output_binary_int oc 0;
     let pos_code = pos_out oc in
     let ofs = rename_append_bytecode_list oc mapping [] 0 units in
-    build_global_target oc (Ident.create_persistent targetname) mapping ofs;
+    build_global_target oc targetname mapping ofs coercion;
     let pos_debug = pos_out oc in
-    if !Clflags.debug && !events <> [] then output_value oc (List.rev !events);
+    if !Clflags.debug && !events <> [] then
+      output_value oc (List.rev !events);
     let pos_final = pos_out oc in
     let imports =
       List.filter
@@ -220,10 +201,10 @@ let package_files files targetfile =
   let targetcmi = prefix ^ ".cmi" in
   let targetname = String.capitalize(Filename.basename prefix) in
   try
-    Typemod.package_units objfiles targetcmi targetname;
-    package_object_files objfiles targetfile targetname
+    let coercion = Typemod.package_units objfiles targetcmi targetname in
+    package_object_files objfiles targetfile targetname coercion
   with x ->
-    remove_file targetcmi; remove_file targetfile; raise x
+    remove_file targetfile; raise x
 
 (* Error report *)
 
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 4613241fcf..a2ee15a820 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -425,3 +425,13 @@ let to_memory init_code fun_code =
   and code_size = !out_position in
   init();
   (code, code_size, reloc)
+
+(* Emission to a file for a packed library *)
+
+let to_packed_file outchan code =
+  init();
+  emit code;
+  output outchan !out_buffer 0 !out_position;
+  let reloc = !reloc_info in
+  init();
+  reloc
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 481ad506b1..226f869971 100644
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -42,6 +42,7 @@ type compilation_unit =
      magic number (Config.cmo_magic_number)
      absolute offset of compilation unit descriptor
      block of relocatable bytecode
+     debugging information if any
      compilation unit descriptor *)
 
 (* Descriptor for libraries *)
@@ -75,4 +76,10 @@ val to_memory: instruction list -> instruction list ->
              block of relocatable bytecode
              size of this block
              relocation information *)
-
+val to_packed_file:
+  out_channel -> instruction list -> (reloc_info * int) list
+        (* Arguments:
+             channel on output file
+             list of instructions to emit
+           Result:
+             relocation information (reversed) *)
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index ea492d30c4..c9b1d101a2 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -929,22 +929,23 @@ let make_default matcher (exit,l) =
   exit,make_rec l
 
 (* Then come various functions,
-   There is one set of functions per match style
-   (constants, constructors etc.
+   There is one set of functions per matching style
+   (constants, constructors etc.)
 
-  - matcher function are arguments to make_default (for defaukt handlers)
-    They may raise NoMatch or OrPat and perform the full
-    matching (selection + arguments).
+   - matcher function are arguments to make_default (for defaukt handlers)
+   They may raise NoMatch or OrPat and perform the full
+   matching (selection + arguments).
 
-  
-  - get_args and get_key are for the compiled matrices, note that
-    selection and geting arguments are separed.
+   
+   - get_args and get_key are for the compiled matrices, note that
+   selection and geting arguments are separed.
 
-  - make_*_matching combines the previous functions for produicing
-    new  ``pattern_matching'' records.
+   - make_ _matching combines the previous functions for produicing
+   new  ``pattern_matching'' records.
 *)
 
 
+
 let rec matcher_const cst p rem = match p.pat_desc with
 | Tpat_or (p1,p2,_) ->
     begin try
@@ -960,7 +961,6 @@ let get_key_constant caller = function
   | p ->
       prerr_endline ("BAD: "^caller) ;
       pretty_pat p ;
-      
       assert false
 
 let get_args_constant _ rem = rem
@@ -974,8 +974,8 @@ let make_constant_matching p def ctx = function
       and ctx = 
         filter_ctx p  ctx in
       {pm = {cases = []; args = argl ; default = def} ;
-       ctx = ctx ;
-      pat = normalize_pat p}
+        ctx = ctx ;
+        pat = normalize_pat p}
 
 
 
@@ -1001,8 +1001,8 @@ let get_key_constr = function
   | _ -> assert false
 
 let get_args_constr p rem = match p with
-  | {pat_desc=Tpat_construct (_,args)} -> args @ rem
-  | _ -> assert false
+| {pat_desc=Tpat_construct (_,args)} -> args @ rem
+| _ -> assert false
 
 let pat_as_constr = function
   | {pat_desc=Tpat_construct (cstr,_)} -> cstr
@@ -1035,8 +1035,8 @@ let matcher_constr cstr = match cstr.cstr_arity with
         | None, Some r2 -> r2
         | Some (a1::rem1), Some (a2::_) ->
             {a1 with
-              pat_loc = Location.none ;
-              pat_desc = Tpat_or (a1, a2, None)}::
+pat_loc = Location.none ;
+pat_desc = Tpat_or (a1, a2, None)}::
             rem
         | _, _ -> assert false
         end
@@ -1066,8 +1066,8 @@ let make_constr_matching p def ctx = function
       {pm=
         {cases = []; args = newargs;
           default = make_default (matcher_constr cstr) def} ;
-      ctx =  filter_ctx p ctx ;
-      pat=normalize_pat p}
+        ctx =  filter_ctx p ctx ;
+        pat=normalize_pat p}
 
 
 let divide_constructor ctx pm =
@@ -1090,15 +1090,15 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with
 | Tpat_any -> rem
 | _   -> raise NoMatch
 
-    
+      
 let make_variant_matching_constant p lab def ctx = function
     [] -> fatal_error "Matching.make_variant_matching_constant"
   | ((arg, mut) :: argl) ->
       let def = make_default (matcher_variant_const lab) def
       and ctx = filter_ctx p ctx in
       {pm={ cases = []; args = argl ; default=def} ;
-      ctx=ctx ;
-      pat = normalize_pat p}
+        ctx=ctx ;
+        pat = normalize_pat p}
 
 let matcher_variant_nonconst lab p rem = match p.pat_desc with
 | Tpat_or (_,_,_) -> raise OrPat
@@ -1129,7 +1129,7 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
       ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
         let variants = divide rem in
         if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
-           with Not_found -> true
+        with Not_found -> true
         then
           variants
         else begin
@@ -1137,10 +1137,10 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
           match pato with
             None ->
               add (make_variant_matching_constant p lab def ctx) variants
-                   (Cstr_constant tag) (patl, action) al               
+                (Cstr_constant tag) (patl, action) al               
           | Some pat ->
               add (make_variant_matching_nonconst p lab def ctx) variants
-                   (Cstr_block tag) (pat :: patl, action) al
+                (Cstr_block tag) (pat :: patl, action) al
         end
     | cl -> []
   in
@@ -1148,7 +1148,7 @@ let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
 
 (*
   Three ``no-test'' cases
-*)
+  *)
 
 (* Matching against a variable *)
 
@@ -1169,16 +1169,16 @@ let divide_var ctx pm =
 
 
 let get_args_tuple arity p rem = match p with
-  | {pat_desc = Tpat_any} -> omegas arity @ rem
-  | {pat_desc = Tpat_tuple args} ->
-      args @ rem
-  | _ ->  assert false
+| {pat_desc = Tpat_any} -> omegas arity @ rem
+| {pat_desc = Tpat_tuple args} ->
+    args @ rem
+| _ ->  assert false
 
 let matcher_tuple arity p rem = match p.pat_desc with
 | Tpat_or (_,_,_)     -> raise OrPat
 | Tpat_var _          -> get_args_tuple arity omega rem
 | _                   ->  get_args_tuple arity p rem
-  
+      
 let make_tuple_matching arity def = function
     [] -> fatal_error "Matching.make_tuple_matching"
   | (arg, mut) :: argl ->
@@ -1252,8 +1252,8 @@ let get_key_array = function
   | _ -> assert false
 
 let get_args_array p rem = match p with
-  | {pat_desc=Tpat_array patl} -> patl@rem
-  | _ -> assert false
+| {pat_desc=Tpat_array patl} -> patl@rem
+| _ -> assert false
 
 let matcher_array len p rem = match p.pat_desc with
 | Tpat_or (_,_,_) -> raise OrPat
@@ -1273,27 +1273,32 @@ let make_array_matching kind p def ctx = function
       let def = make_default (matcher_array len) def
       and ctx = filter_ctx p ctx in
       {pm={cases = []; args = make_args 0 ; default = def} ;
-      ctx=ctx ;
-      pat = normalize_pat p}
+        ctx=ctx ;
+        pat = normalize_pat p}
 
 let divide_array kind ctx pm =
   divide
     (make_array_matching kind)
     get_key_array get_args_array ctx pm
-  
+    
 (* To combine sub-matchings together *)
 
+let float_compare s1 s2 =
+  let f1 = float_of_string s1 and f2 = float_of_string s2 in
+  Pervasives.compare f1 f2
+
 let sort_lambda_list l =
   List.sort
-    (fun (x,_) (y,_) -> Pervasives.compare x y)
+    (fun (x,_) (y,_) -> match x,y with
+    | Const_float f1, Const_float f2 -> float_compare f1 f2
+    | _, _ -> Pervasives.compare x y)
     l
 
-
 let rec cut n l =
-    if n = 0 then [],l
-    else match l with
-      [] -> raise (Invalid_argument "cut")
-    | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
+  if n = 0 then [],l
+  else match l with
+    [] -> raise (Invalid_argument "cut")
+  | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
 
 let rec do_tests_fail fail tst arg = function
   | [] -> fail
@@ -1322,7 +1327,7 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
 
   and split_sequence const_lambda_list =
     let list1, list2 =
-          cut (List.length const_lambda_list / 2) const_lambda_list in
+      cut (List.length const_lambda_list / 2) const_lambda_list in
     Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
                 make_test_sequence list1, make_test_sequence list2)
   in make_test_sequence (sort_lambda_list const_lambda_list)
@@ -1334,8 +1339,8 @@ let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg])
 
 let prim_string_notequal =
   Pccall{prim_name = "string_notequal";
-         prim_arity = 2; prim_alloc = false;
-         prim_native_name = ""; prim_native_float = false}
+          prim_arity = 2; prim_alloc = false;
+          prim_native_name = ""; prim_native_float = false}
 
 let rec explode_inter offset i j act k =
   if i <= j then
@@ -1384,8 +1389,8 @@ let make_switch_offset arg min_key max_key int_lambda_list default  =
   let offsetarg = make_offset (-min_key) arg in
   Lswitch(offsetarg,
           {sw_numconsts = numcases; sw_consts = cases;
-          sw_numblocks = 0; sw_blocks = [];
-          sw_failaction = default})
+            sw_numblocks = 0; sw_blocks = [];
+            sw_failaction = default})
 
 let make_switch_switcher arg cases acts =
   let l = ref [] in
@@ -1394,20 +1399,20 @@ let make_switch_switcher arg cases acts =
   done ;    
   Lswitch(arg,
           {sw_numconsts = Array.length cases ; sw_consts = !l ;
-           sw_numblocks = 0 ; sw_blocks =  []  ;
-           sw_failaction = None})
-           
+            sw_numblocks = 0 ; sw_blocks =  []  ;
+            sw_failaction = None})
+    
 let full sw =
   List.length sw.sw_consts = sw.sw_numconsts &&
   List.length sw.sw_blocks = sw.sw_numblocks
-  
+    
 let make_switch (arg,sw) = match sw.sw_failaction with
 | None ->
     let t = Hashtbl.create 17 in
     let seen l = match l with
     | Lstaticraise (i,[]) ->
-      let old = try Hashtbl.find t i with Not_found -> 0 in
-      Hashtbl.replace t i (old+1)
+        let old = try Hashtbl.find t i with Not_found -> 0 in
+        Hashtbl.replace t i (old+1)
     | _ -> () in
     List.iter (fun (_,lam) -> seen lam) sw.sw_consts ;
     List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ;
@@ -1426,14 +1431,14 @@ let make_switch (arg,sw) = match sw.sw_failaction with
         | (_,Lstaticraise (j,[]))::rem when j=default ->
             remove rem
         | x::rem -> x::remove rem in
-       Lswitch
+      Lswitch
         (arg,
          {sw with
-         sw_consts = remove sw.sw_consts ;
-         sw_blocks = remove sw.sw_blocks ;
-         sw_failaction = Some (Lstaticraise (default,[]))})
+sw_consts = remove sw.sw_consts ;
+sw_blocks = remove sw.sw_blocks ;
+sw_failaction = Some (Lstaticraise (default,[]))})
     else
-       Lswitch (arg,sw)
+      Lswitch (arg,sw)
 | _ -> Lswitch (arg,sw)
       
 module SArg = struct
@@ -1472,15 +1477,15 @@ open Switch
 let lambda_of_int i =  Lconst (Const_base (Const_int i))
 
 let rec last def = function
-| [] -> def
-| [x,_] -> x
-| _::rem -> last def rem
+  | [] -> def
+  | [x,_] -> x
+  | _::rem -> last def rem
 
 let get_edges low high l = match l with
 | [] -> low, high
 | (x,_)::_ -> x, last high l
 
-  
+      
 let as_interval_canfail fail low high l =
   let store = mk_store equal_action in
   let rec nofail_rec cur_low cur_high cur_act = function
@@ -1548,8 +1553,17 @@ let as_interval_nofail l =
 
   Array.of_list inters, store.act_get ()
 
+
+let sort_int_lambda_list l =
+  List.sort
+    (fun (i1,_) (i2,_) ->
+      if i1 < i2 then -1
+      else if i2 < i1 then 1
+      else 0)
+    l
+
 let as_interval fail low high l =
-  let l = sort_lambda_list l in
+  let l = sort_int_lambda_list l in
   get_edges low high l,
   (match fail with
   | None -> as_interval_nofail l
@@ -1643,19 +1657,19 @@ let mk_res get_key env last_choice idef cant_fail ctx =
         klist,jumps_add i ctx jumps)
       env ([],jumps_fail) in
   fail, klist, jumps
-      
+    
 
 (* Aucune optimisation, reflechir apres la release *)
 let mk_failaction_neg partial ctx (_,def) = match partial with
 | Partial -> begin match def with
-   | (_,idef)::_ ->
+  | (_,idef)::_ ->
       Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx
-   | __ -> assert false
-   end
+  | __ -> assert false
+end
 | Total ->
     None, [], jumps_empty
-    
-  
+      
+      
 (* Conforme a l'article et plus simple qu'avant *)
 and mk_failaction_pos partial seen ctx (_,defs)  =
   let rec scan_def env to_test defs = match to_test,defs with
@@ -1682,11 +1696,11 @@ and mk_failaction_pos partial seen ctx (_,defs)  =
   scan_def
     []
     (List.map
-      (fun pat -> pat, ctx_lub pat ctx)
-      (complete_pats_constrs seen))
+       (fun pat -> pat, ctx_lub pat ctx)
+       (complete_pats_constrs seen))
     defs
 
-      
+    
 let combine_constant arg cst partial ctx def 
     (const_lambda_list, total, pats) =
   let fail, to_add, local_jumps =
@@ -1715,8 +1729,23 @@ let combine_constant arg cst partial ctx def
         make_test_sequence
           fail
           (Pfloatcomp Cneq) (Pfloatcomp Clt)
-          arg const_lambda_list in
-  lambda1,jumps_union local_jumps total
+          arg const_lambda_list
+    | Const_int32 _ ->
+        make_test_sequence
+          fail
+          (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt))
+          arg const_lambda_list
+    | Const_int64 _ ->
+        make_test_sequence
+          fail
+          (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt))
+          arg const_lambda_list
+    | Const_nativeint _ ->
+        make_test_sequence
+          fail
+          (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt))
+          arg const_lambda_list
+  in lambda1,jumps_union local_jumps total
 
 
 
@@ -1730,9 +1759,9 @@ let split_cases tag_lambda_list =
         | Cstr_block n    -> (consts, (n, act) :: nonconsts)
         | _ -> assert false in
   let const, nonconst = split_rec tag_lambda_list in
-  sort_lambda_list const,
-  sort_lambda_list nonconst
-  
+  sort_int_lambda_list const,
+  sort_int_lambda_list nonconst
+    
 
 let combine_constructor arg ex_pat cstr partial ctx def
     (tag_lambda_list, total1, pats) =
@@ -1791,11 +1820,11 @@ let combine_constructor arg ex_pat cstr partial ctx def
           | (n, _, _, _) ->
               match same_actions nonconsts with
               | None ->
-                 make_switch(arg, {sw_numconsts = cstr.cstr_consts;
-                                 sw_consts = consts;
-                                 sw_numblocks = cstr.cstr_nonconsts;
-                                 sw_blocks = nonconsts;
-                                 sw_failaction = None})
+                  make_switch(arg, {sw_numconsts = cstr.cstr_consts;
+                                     sw_consts = consts;
+                                     sw_numblocks = cstr.cstr_nonconsts;
+                                     sw_blocks = nonconsts;
+                                     sw_failaction = None})
               | Some act ->
                   Lifthenelse
                     (Lprim (Pisint, [arg]),
@@ -1859,7 +1888,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
           make_test_sequence_variant_constant fail arg consts
       | ([], _) ->
           let lam = call_switcher_variant_constr
-                       fail arg nonconsts in
+              fail arg nonconsts in
           (* One must not dereference integers *)
           begin match fail with
           | None -> lam
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 909ee46391..b8af27831c 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -21,12 +21,12 @@ open Lambda
 
 let rec struct_const ppf = function
   | Const_base(Const_int n) -> fprintf ppf "%i" n
-  | Const_base(Const_char c) ->
-      fprintf ppf "%C" c
-  | Const_base(Const_string s) ->
-      fprintf ppf "%S" s
-  | Const_base(Const_float s) ->
-      fprintf ppf "%s" s
+  | Const_base(Const_char c) -> fprintf ppf "%C" c
+  | Const_base(Const_string s) -> fprintf ppf "%S" s
+  | Const_base(Const_float f) -> fprintf ppf "%s" f
+  | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
+  | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
+  | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n
   | Const_pointer n -> fprintf ppf "%ia" n
   | Const_block(tag, []) ->
       fprintf ppf "[%i]" tag
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 74ec833b02..9ea585954d 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -201,7 +201,10 @@ let rec transl_const = function
     Const_base(Const_int i) -> Obj.repr i
   | Const_base(Const_char c) -> Obj.repr c
   | Const_base(Const_string s) -> Obj.repr s
-  | Const_base(Const_float f) -> Obj.repr(float_of_string f)
+  | Const_base(Const_float f) -> Obj.repr (float_of_string f)
+  | Const_base(Const_int32 i) -> Obj.repr i
+  | Const_base(Const_int64 i) -> Obj.repr i
+  | Const_base(Const_nativeint i) -> Obj.repr i
   | Const_pointer i -> Obj.repr i
   | Const_block(tag, fields) ->
       let block = Obj.new_block tag (List.length fields) in
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 392a9afe6d..bff8a5dcce 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -65,8 +65,9 @@ let comparisons_table = create_hashtable 11 [
               prim_native_name = ""; prim_native_float = false},
        Pintcomp Clt,
        Pfloatcomp Clt,
-       Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false;
-              prim_native_name = ""; prim_native_float = false},
+       Pccall{prim_name = "string_lessthan"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
        Pbintcomp(Pnativeint, Clt),
        Pbintcomp(Pint32, Clt),
        Pbintcomp(Pint64, Clt));
@@ -75,8 +76,9 @@ let comparisons_table = create_hashtable 11 [
               prim_native_name = ""; prim_native_float = false},
        Pintcomp Cgt,
        Pfloatcomp Cgt,
-       Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
-              prim_native_name = ""; prim_native_float = false},
+       Pccall{prim_name = "string_greaterthan"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
        Pbintcomp(Pnativeint, Cgt),
        Pbintcomp(Pint32, Cgt),
        Pbintcomp(Pint64, Cgt));
@@ -85,8 +87,9 @@ let comparisons_table = create_hashtable 11 [
               prim_native_name = ""; prim_native_float = false},
        Pintcomp Cle,
        Pfloatcomp Cle,
-       Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
-              prim_native_name = ""; prim_native_float = false},
+       Pccall{prim_name = "string_lessequal"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
        Pbintcomp(Pnativeint, Cle),
        Pbintcomp(Pint32, Cle),
        Pbintcomp(Pint64, Cle));
@@ -95,11 +98,33 @@ let comparisons_table = create_hashtable 11 [
               prim_native_name = ""; prim_native_float = false},
        Pintcomp Cge,
        Pfloatcomp Cge,
-       Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
-              prim_native_name = ""; prim_native_float = false},
+       Pccall{prim_name = "string_greaterequal"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
        Pbintcomp(Pnativeint, Cge),
        Pbintcomp(Pint32, Cge),
-       Pbintcomp(Pint64, Cge))
+       Pbintcomp(Pint64, Cge));
+  "%compare",
+      (Pccall{prim_name = "compare"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pccall{prim_name = "int_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pccall{prim_name = "float_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pccall{prim_name = "string_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pccall{prim_name = "nativeint_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pccall{prim_name = "int32_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pccall{prim_name = "int64_compare"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false})
 ]
 
 let primitives_table = create_hashtable 57 [
@@ -300,6 +325,8 @@ let transl_primitive p =
 let check_recursive_lambda idlist lam =
   let rec check_top idlist = function
     | Lvar v -> not (List.mem v idlist)
+    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+        true
     | Llet(str, id, arg, body) ->
         check idlist arg && check_top (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
@@ -313,6 +340,8 @@ let check_recursive_lambda idlist lam =
   and check idlist = function
     | Lvar _ -> true
     | Lfunction(kind, params, body) -> true
+    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+        true
     | Llet(str, id, arg, body) ->
         check idlist arg && check (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
@@ -339,6 +368,20 @@ let check_recursive_lambda idlist lam =
     List.fold_right (fun (id, arg) idl -> add_let id arg idl)
                     bindings idlist
 
+  (* reverse-engineering the code generated by transl_record case 2 *)
+  and check_recursive_recordwith idlist = function
+    | Llet (Strict, id1, Lprim (Pccall prim, [e1]), body) ->
+       prim = prim_obj_dup && check_top idlist e1
+       && check_recordwith_updates idlist id1 body
+    | _ -> false
+
+  and check_recordwith_updates idlist id1 = function
+    | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont)
+        -> id2 = id1 && check idlist e1
+           && check_recordwith_updates idlist id1 cont
+    | Lvar id2 -> id2 = id1
+    | _ -> false
+
   in check_top idlist lam
 
 (* To propagate structured constants *)
@@ -538,7 +581,8 @@ let rec transl_exp e =
       end
   | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
       transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
-  | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record"
+  | Texp_record ([], _) ->
+      fatal_error "Translcore.transl_exp: bad Texp_record"
   | Texp_field(arg, lbl) ->
       let access =
         match lbl.lbl_repres with
@@ -552,27 +596,7 @@ let rec transl_exp e =
         | Record_float -> Psetfloatfield lbl.lbl_pos in
       Lprim(access, [transl_exp arg; transl_exp newval])
   | Texp_array expr_list ->
-      let kind = array_kind e in
-      let len = List.length expr_list in
-      if len <= Config.max_young_wosize then
-        Lprim(Pmakearray kind, transl_list expr_list)
-      else begin
-        let v = Ident.create "makearray" in
-        let rec fill_fields pos = function
-          [] ->
-            Lvar v
-        | arg :: rem ->
-            Lsequence(Lprim(Parraysetu kind,
-                            [Lvar v;
-                             Lconst(Const_base(Const_int pos));
-                             transl_exp arg]),
-                      fill_fields (pos+1) rem) in
-        Llet(Strict, v,
-             Lprim(Pccall prim_makearray,
-                   [Lconst(Const_base(Const_int len));
-                    transl_exp (List.hd expr_list)]),
-             fill_fields 1 (List.tl expr_list))
-      end
+      Lprim(Pmakearray (array_kind e), transl_list expr_list)
   | Texp_ifthenelse(cond, ifso, Some ifnot) ->
       Lifthenelse(transl_exp cond,
                   event_before ifso (transl_exp ifso),
@@ -818,6 +842,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
   end else begin
     (* Take a shallow copy of the init record, then mutate the fields
        of the copy *)
+    (* If you change anything here, you will likely have to change
+       [check_recursive_recordwith] in this file. *)
     let copy_id = Ident.create "newrecord" in
     let rec update_field (lbl, expr) cont =
       let upd =
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 99e1e89aec..e49a049d1a 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -378,8 +378,9 @@ let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *)
 
 let aliased_idents = ref Ident.empty
 
-let set_toplevel_name id name =
-  aliased_idents := Ident.add id name !aliased_idents
+let set_toplevel_unique_name id =
+  aliased_idents :=
+    Ident.add id (Ident.unique_toplevel_name id) !aliased_idents
 
 let toplevel_name id =
   try Ident.find_same id !aliased_idents
@@ -417,6 +418,9 @@ let transl_toplevel_item = function
   | Tstr_exn_rebind(id, path) ->
       toploop_setvalue id (transl_path path)
   | Tstr_module(id, modl) ->
+      (* we need to use the unique name for the module because of issues
+         with "open" (PR#1672) *)
+      set_toplevel_unique_name id;
       toploop_setvalue id
                         (transl_module Tcoerce_none (Some(Pident id)) modl)
   | Tstr_modtype(id, decl) ->
@@ -424,10 +428,10 @@ let transl_toplevel_item = function
   | Tstr_open path ->
       lambda_unit
   | Tstr_class cl_list ->
+      (* we need to use unique names for the classes because there might
+         be a value named identically *)
       let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-      List.iter
-        (fun id -> set_toplevel_name id (Ident.name id ^ "(c)"))
-        ids;
+      List.iter set_toplevel_unique_name ids;
       Lletrec(List.map
                 (fun (id, arity, meths, cl) ->
                    (id, transl_class ids id arity meths cl))
@@ -453,3 +457,44 @@ let transl_toplevel_item_and_close itm =
 let transl_toplevel_definition str =
   reset_labels ();
   make_sequence transl_toplevel_item_and_close str
+
+(* Compile the initialization code for a packed library *)
+
+let transl_package component_names target_name coercion =
+  let components =
+    match coercion with
+      Tcoerce_none ->
+        List.map (fun id -> Lprim(Pgetglobal id, [])) component_names
+    | Tcoerce_structure pos_cc_list ->
+        let g = Array.of_list component_names in
+        List.map
+          (fun (pos, cc) -> apply_coercion cc (Lprim(Pgetglobal g.(pos), [])))
+          pos_cc_list
+    | _ ->
+        assert false in
+  Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+
+let transl_store_package component_names target_name coercion =
+  let rec make_sequence fn pos arg =
+    match arg with
+      [] -> lambda_unit
+    | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
+  match coercion with
+    Tcoerce_none ->
+      (List.length component_names,
+       make_sequence
+         (fun pos id ->
+           Lprim(Psetfield(pos, false),
+                 [Lprim(Pgetglobal target_name, []);
+                  Lprim(Pgetglobal id, [])]))
+         0 component_names)
+  | Tcoerce_structure pos_cc_list ->
+      let id = Array.of_list component_names in
+      (List.length pos_cc_list,
+       make_sequence
+         (fun dst (src, cc) ->
+           Lprim(Psetfield(dst, false),
+                 [Lprim(Pgetglobal target_name, []);
+                  apply_coercion cc (Lprim(Pgetglobal id.(src), []))]))
+         0 pos_cc_list)
+  | _ -> assert false
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index ffcb0a7ebe..bd9a5dfd96 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -22,6 +22,10 @@ val transl_implementation: string -> structure * module_coercion -> lambda
 val transl_store_implementation:
       string -> structure * module_coercion -> int * lambda
 val transl_toplevel_definition: structure -> lambda
+val transl_package: Ident.t list -> Ident.t -> module_coercion -> lambda
+val transl_store_package:
+      Ident.t list -> Ident.t -> module_coercion -> int * lambda
+
 val toplevel_name: Ident.t -> string
 
 val primitive_declarations: string list ref
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index 0dae07a44d..ed019747cf 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -38,7 +38,8 @@ let maybe_pointer exp =
       not (Path.same p Predef.path_char) &&
       begin try
         match Env.find_type p exp.exp_env with
-          {type_kind = Type_variant cstrs} ->
+          {type_kind = Type_variant []} -> true (* type exn *)
+        | {type_kind = Type_variant cstrs} ->
             List.exists (fun (name, args) -> args <> []) cstrs
         | _ -> true
       with Not_found -> true
diff --git a/driver/compile.ml b/driver/compile.ml
index 6be13ba40b..99bc318756 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -38,6 +38,8 @@ let init_path () =
 (* Return the initial environment in which compilation proceeds. *)
 
 let initial_env () =
+  init_path();
+  Ident.reinit();
   try
     if !Clflags.nopervasives
     then Env.initial
@@ -48,7 +50,6 @@ let initial_env () =
 (* Compile a .mli file *)
 
 let interface ppf sourcefile =
-  init_path();
   let prefixname = chop_extension_if_any sourcefile in
   let modulename = String.capitalize(Filename.basename prefixname) in
   let inputfile = Pparse.preprocess sourcefile in
@@ -76,7 +77,6 @@ let print_if ppf flag printer arg =
 let (++) x f = f x
 
 let implementation ppf sourcefile =
-  init_path();
   let prefixname = chop_extension_if_any sourcefile in
   let modulename = String.capitalize(Filename.basename prefixname) in
   let inputfile = Pparse.preprocess sourcefile in
diff --git a/driver/main.ml b/driver/main.ml
index 8e1f58fbe7..b1ac5b0390 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -80,6 +80,7 @@ module Options = Main_args.Make_options (struct
   let _custom = set custom_runtime
   let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
   let _dllpath s = dllpaths := !dllpaths @ [s]
+  let _dtypes = set save_types
   let _g = set debug
   let _i = set print_types
   let _I s = include_dirs := s :: !include_dirs
diff --git a/driver/main_args.ml b/driver/main_args.ml
index 617c73caeb..b112c60e1a 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -22,6 +22,7 @@ module Make_options (F :
      val _custom : unit -> unit
      val _dllib : string -> unit
      val _dllpath : string -> unit
+     val _dtypes : unit -> unit
      val _g : unit -> unit
      val _i : unit -> unit
      val _I : string -> unit
@@ -73,6 +74,7 @@ struct
            "<lib>  Use the dynamically-loaded library <lib>";
     "-dllpath", Arg.String F._dllpath,
            "<dir>  Add <dir> to the run-time search path for shared libraries";
+    "-dtypes", Arg.Unit F._dtypes, " Save type information in <filename>.types";
     "-g", Arg.Unit F._g, " Save debugging information";
     "-i", Arg.Unit F._i, " Print the types";
     "-I", Arg.String F._I,
@@ -122,6 +124,7 @@ struct
       \032    A/a enable/disable all warnings\n\
       \032    C/c enable/disable suspicious comment\n\
       \032    D/d enable/disable deprecated features\n\
+      \032    E/e enable/disable fragile match\n\
       \032    F/f enable/disable partially applied function\n\
       \032    L/l enable/disable labels omitted in application\n\
       \032    M/m enable/disable overriden method\n\
@@ -130,7 +133,8 @@ struct
       \032    U/u enable/disable unused match case\n\
       \032    V/v enable/disable hidden instance variable\n\
       \032    X/x enable/disable all other warnings\n\
-      \032    default setting is \"Al\" (all warnings but labels enabled)";
+      \032    default setting is \"Ale\"\n\
+      \032    (all warnings but labels and fragile match enabled)";
     "-warn-error" , Arg.String F._warn_error,
       "<flags>  Treat the warnings enabled by <flags> as errors.\n\
       \032    See option -w for the list of flags.\n\
diff --git a/driver/main_args.mli b/driver/main_args.mli
index aebe7e76b6..648daa15dc 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -22,6 +22,7 @@ module Make_options (F :
       val _custom : unit -> unit
       val _dllib : string -> unit
       val _dllpath : string -> unit
+      val _dtypes : unit -> unit
       val _g : unit -> unit
       val _i : unit -> unit
       val _I : string -> unit
diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index ff30fc8be2..1d912ef293 100644
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -38,6 +38,7 @@ let init_path () =
 
 let initial_env () =
   init_path();
+  Ident.reinit();
   try
     if !Clflags.nopervasives
     then Env.initial
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 7fa0b73493..a321fa2b7e 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -88,6 +88,8 @@ let main () =
              "<opt>  Pass option <opt> to the C compiler and linker";
        "-compact", Arg.Clear optimize_for_speed,
              " Optimize code size rather than speed";
+       "-dtypes", Arg.Set save_types,
+             " Save type information in <filename>.types";
        "-i", Arg.Set print_types, " Print the types";
        "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
              "<dir>  Add <dir> to the list of include directories";
@@ -139,6 +141,7 @@ let main () =
          \032    A/a enable/disable all warnings\n\
          \032    C/c enable/disable suspicious comment\n\
          \032    D/d enable/disable deprecated features\n\
+         \032    E/e enable/disable fragile match\n\
          \032    F/f enable/disable partially applied function\n\
          \032    L/l enable/disable labels omitted in application\n\
          \032    M/m enable/disable overriden methods\n\
@@ -147,7 +150,8 @@ let main () =
          \032    U/u enable/disable unused match case\n\
          \032    V/v enable/disable hidden instance variables\n\
          \032    X/x enable/disable all other warnings\n\
-         \032    default setting is \"Al\" (all warnings but labels enabled)";
+         \032    default setting is \"Ale\"\n\
+         \032    (all warnings but labels and fragile match enabled)";
        "-warn-error" , Arg.String (Warnings.parse_options true),
          "<flags>  Treat the warnings enabled by <flags> as errors.\n\
          \032    See option -w for the list of flags.\n\
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index 5aa9603a2f..f9824d0590 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -19,6 +19,9 @@ type constant =
   | Const_char of char
   | Const_string of string
   | Const_float of string
+  | Const_int32 of int32
+  | Const_int64 of int64
+  | Const_nativeint of nativeint
 
 type rec_flag = Nonrecursive | Recursive | Default
 
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index c112684a61..61bada1f79 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -70,6 +70,7 @@ let keyword_table =
     "of", OF;
     "open", OPEN;
     "or", OR;
+    "parser", PARSER;
     "private", PRIVATE;
     "rec", REC;
     "sig", SIG;
@@ -232,6 +233,8 @@ let oct_literal =
   '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
 let bin_literal =
   '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
+let int_literal =
+  decimal_literal | hex_literal | oct_literal | bin_literal
 let float_literal =
   ['0'-'9'] ['0'-'9' '_']* 
   ('.' ['0'-'9' '_']* )?
@@ -254,6 +257,7 @@ rule token = parse
           raise (Error(Keyword_as_label name, Location.curr lexbuf));
         LABEL name }
   | "?"  { QUESTION }
+  | "??" { QUESTIONQUESTION }
   | "?" lowercase identchar * ':'
       { let s = Lexing.lexeme lexbuf in
         let name = String.sub s 1 (String.length s - 2) in
@@ -268,10 +272,20 @@ rule token = parse
             LIDENT s }
   | uppercase identchar *
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
-  | decimal_literal | hex_literal | oct_literal | bin_literal
+  | int_literal
       { INT (int_of_string(Lexing.lexeme lexbuf)) }
   | float_literal
-      { FLOAT (remove_underscores (Lexing.lexeme lexbuf)) }
+      { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
+  | int_literal "l"
+      { let s = Lexing.lexeme lexbuf in
+        INT32 (Int32.of_string(String.sub s 0 (String.length s - 1))) }
+  | int_literal "L"
+      { let s = Lexing.lexeme lexbuf in
+        INT64 (Int64.of_string(String.sub s 0 (String.length s - 1))) }
+  | int_literal "n"
+      { let s = Lexing.lexeme lexbuf in
+        NATIVEINT 
+          (Nativeint.of_string(String.sub s 0 (String.length s - 1))) }
   | "\""
       { reset_string_buffer();
         let string_start = lexbuf.lex_start_p in
@@ -284,16 +298,16 @@ rule token = parse
         CHAR (Lexing.lexeme_char lexbuf 1) }
   | "'" [^ '\\' '\'' '\010' '\013'] "'"
       { CHAR(Lexing.lexeme_char lexbuf 1) }
-  | "'" '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r'] "'"
+  | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r'] "'"
       { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
-  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
       { CHAR(char_for_decimal_code lexbuf 2) }
-  | "'" '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
+  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
       { CHAR(char_for_hexadecimal_code lexbuf 3) }
-  | "'" '\\' _
+  | "'\\" _
       { let l = Lexing.lexeme lexbuf in
         let esc = String.sub l 1 (String.length l - 1) in
-        raise (Error(Illegal_escape esc, Location.curr lexbuf));
+        raise (Error(Illegal_escape esc, Location.curr lexbuf))
       }
   | "(*"
       { comment_start_loc := [Location.curr lexbuf];
@@ -417,6 +431,8 @@ and comment = parse
       { comment lexbuf }
   | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
       { comment lexbuf }
+  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
+      { comment lexbuf }
   | eof
       { match !comment_start_loc with
         | [] -> assert false
@@ -481,4 +497,4 @@ and skip_sharp_bang = parse
        { update_loc lexbuf None 3 false 0 }
   | "#!" [^ '\n']* '\n'
        { update_loc lexbuf None 1 false 0 }
-  | "" {}
+  | "" { () }
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 5830cfdf71..17dfde2ee9 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -41,16 +41,28 @@ let mkclass d =
 let mkcty d =
   { pcty_desc = d; pcty_loc = symbol_rloc() }
 
+let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
+let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
+
 let mkoperator name pos =
   { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
 
-(* Ghost expressions and patterns:
-    expressions and patterns added by the parser;
-    they have the loc_ghost flag set to true to tell the profiler
-    not to instrument them.
-
-    Every grammar rule that generates an element with a location must
-    make exactly one non-ghost element, the topmost one.
+(*
+  Ghost expressions and patterns:
+  expressions and patterns that do not appear explicitely in the
+  source file they have the loc_ghost flag set to true.
+  Then the profiler will not try to instrument them and the
+  -stypes option will not try to display their type.
+
+  Every grammar rule that generates an element with a location must
+  make at most one non-ghost element, the topmost one.
+
+  How to tell whether your location must be ghost:
+  A location corresponds to a range of characters in the source file.
+  If the location contains a piece of code that is syntactically
+  valid (according to the documentation), and corresponds to the
+  AST node, then the location must be real; in all other cases,
+  it must be ghost.
 *)
 let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
 let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
@@ -72,10 +84,16 @@ let neg_float_string f =
   else "-" ^ f
 
 let mkuminus name arg =
-  match arg.pexp_desc with
-    Pexp_constant(Const_int n) ->
+  match name, arg.pexp_desc with
+  | "-", Pexp_constant(Const_int n) ->
       mkexp(Pexp_constant(Const_int(-n)))
-  | Pexp_constant(Const_float f) ->
+  | "-", Pexp_constant(Const_int32 n) ->
+      mkexp(Pexp_constant(Const_int32(Int32.neg n)))
+  | "-", Pexp_constant(Const_int64 n) ->
+      mkexp(Pexp_constant(Const_int64(Int64.neg n)))
+  | "-", Pexp_constant(Const_nativeint n) ->
+      mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
+  | _, Pexp_constant(Const_float f) ->
       mkexp(Pexp_constant(Const_float(neg_float_string f)))
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
@@ -87,10 +105,9 @@ let rec mktailexp = function
       let exp_el = mktailexp el in
       let l = {loc_start = e1.pexp_loc.loc_start;
                loc_end = exp_el.pexp_loc.loc_end;
-               loc_ghost = false}
+               loc_ghost = true}
       in
-      let arg = {pexp_desc = Pexp_tuple [e1; exp_el];
-                 pexp_loc = {l with loc_ghost = true} } in
+      let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
       {pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l}
 
 let rec mktailpat = function
@@ -100,23 +117,26 @@ let rec mktailpat = function
       let pat_pl = mktailpat pl in
       let l = {loc_start = p1.ppat_loc.loc_start;
                loc_end = pat_pl.ppat_loc.loc_end;
-               loc_ghost = false}
+               loc_ghost = true}
       in
-      let arg = {ppat_desc = Ppat_tuple [p1; pat_pl];
-                 ppat_loc = {l with loc_ghost = true} } in
+      let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
       {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l}
 
-let mkstrexp e =
+let ghstrexp e =
   { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
 
 let array_function str name =
   Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))
 
-let rec mkrangepat c1 c2 =
-  if c1 > c2 then mkrangepat c2 c1 else
+let rec deep_mkrangepat c1 c2 =
   if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
   ghpat(Ppat_or(ghpat(Ppat_constant(Const_char c1)),
-                mkrangepat (Char.chr(Char.code c1 + 1)) c2))
+                deep_mkrangepat (Char.chr(Char.code c1 + 1)) c2))
+
+let rec mkrangepat c1 c2 =
+  if c1 > c2 then mkrangepat c2 c1 else
+  if c1 = c2 then mkpat(Ppat_constant(Const_char c1)) else
+  reloc_pat (deep_mkrangepat c1 c2)
 
 let syntax_error () =
   raise Syntaxerr.Escape_error
@@ -163,6 +183,10 @@ let bigarray_set arr arg newval =
                        ["", arr; 
                         "", ghexp(Pexp_array coords);
                         "", newval]))
+
+let mktype_kind pflag kind =
+  if pflag = Private && kind != Ptype_abstract then Ptype_private kind else kind
+
 %}
 
 /* Tokens */
@@ -216,6 +240,8 @@ let bigarray_set arr arg newval =
 %token INHERIT
 %token INITIALIZER
 %token <int> INT
+%token <int32> INT32
+%token <int64> INT64
 %token <string> LABEL
 %token LAZY
 %token LBRACE
@@ -237,16 +263,19 @@ let bigarray_set arr arg newval =
 %token MULTIFUN
 %token MULTIMATCH
 %token MUTABLE
+%token <nativeint> NATIVEINT
 %token NEW
 %token OBJECT
 %token OF
 %token OPEN
 %token <string> OPTLABEL
 %token OR
+%token PARSER
 %token PLUS
 %token <string> PREFIXOP
 %token PRIVATE
 %token QUESTION
+%token QUESTIONQUESTION
 %token QUOTE
 %token RBRACE
 %token RBRACKET
@@ -328,8 +357,9 @@ The precedences must be listed from low to high.
 %nonassoc below_DOT
 %nonassoc DOT
 /* Finally, the first tokens of simple_expr are above everything else. */
-%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT LBRACE LBRACELESS LBRACKET
-          LBRACKETBAR LIDENT LPAREN NEW PREFIXOP STRING TRUE UIDENT
+%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64
+          LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+          NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
 
 
 /* Entry points */
@@ -355,7 +385,7 @@ interface:
 ;
 toplevel_phrase:
     top_structure SEMISEMI               { Ptop_def $1 }
-  | seq_expr SEMISEMI                    { Ptop_def[mkstrexp $1] }
+  | seq_expr SEMISEMI                    { Ptop_def[ghstrexp $1] }
   | toplevel_directive SEMISEMI          { $1 }
   | EOF                                  { raise End_of_file }
 ;
@@ -365,12 +395,12 @@ top_structure:
 ;
 use_file:
     use_file_tail                        { $1 }
-  | seq_expr use_file_tail               { Ptop_def[mkstrexp $1] :: $2 }
+  | seq_expr use_file_tail               { Ptop_def[ghstrexp $1] :: $2 }
 ;
 use_file_tail:
     EOF                                         { [] }
   | SEMISEMI EOF                                { [] }
-  | SEMISEMI seq_expr use_file_tail             { Ptop_def[mkstrexp $2] :: $3 }
+  | SEMISEMI seq_expr use_file_tail             { Ptop_def[ghstrexp $2] :: $3 }
   | SEMISEMI structure_item use_file_tail       { Ptop_def[$2] :: $3 }
   | SEMISEMI toplevel_directive use_file_tail   { $2 :: $3 }
   | structure_item use_file_tail                { Ptop_def[$1] :: $2 }
@@ -403,12 +433,12 @@ module_expr:
 ;
 structure:
     structure_tail                              { $1 }
-  | seq_expr structure_tail                     { mkstrexp $1 :: $2 }
+  | seq_expr structure_tail                     { ghstrexp $1 :: $2 }
 ;
 structure_tail:
     /* empty */                                 { [] }
   | SEMISEMI                                    { [] }
-  | SEMISEMI seq_expr structure_tail            { mkstrexp $2 :: $3 }
+  | SEMISEMI seq_expr structure_tail            { ghstrexp $2 :: $3 }
   | SEMISEMI structure_item structure_tail      { $2 :: $3 }
   | structure_item structure_tail               { $1 :: $2 }
 ;
@@ -525,7 +555,7 @@ class_fun_binding:
       { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
 ;
 class_type_parameters:
-    /*empty*/                                   { [], symbol_rloc () }
+    /*empty*/                                   { [], symbol_gloc () }
   | LBRACKET type_parameter_list RBRACKET       { List.rev $2, symbol_rloc () }
 ;
 class_fun_def:
@@ -568,11 +598,11 @@ class_structure:
 ;
 class_self_pattern:
     LPAREN pattern RPAREN
-      { $2 }
+      { reloc_pat $2 }
   | LPAREN pattern COLON core_type RPAREN
       { mkpat(Ppat_constraint($2, $4)) }
   | /* empty */
-      { mkpat(Ppat_any) }
+      { ghpat(Ppat_any) }
 ;
 class_fields:
     /* empty */
@@ -719,7 +749,7 @@ class_type_declaration:
 
 seq_expr:
   | expr        %prec below_SEMI  { $1 }
-  | expr SEMI                     { $1 }
+  | expr SEMI                     { reloc_exp $1 }
   | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
 ;
 labeled_simple_pattern:
@@ -876,11 +906,11 @@ simple_expr:
   | name_tag %prec prec_constant_constructor
       { mkexp(Pexp_variant($1, None)) }
   | LPAREN seq_expr RPAREN
-      { $2 }
+      { reloc_exp $2 }
   | LPAREN seq_expr error
       { unclosed "(" 1 ")" 3 }
   | BEGIN seq_expr END
-      { $2 }
+      { reloc_exp $2 }
   | BEGIN END
       { mkexp (Pexp_construct (Lident "()", None, false)) }
   | BEGIN seq_expr error
@@ -914,7 +944,7 @@ simple_expr:
   | LBRACKETBAR BARRBRACKET
       { mkexp(Pexp_array []) }
   | LBRACKET expr_semi_list opt_semi RBRACKET
-      { mkexp (mktailexp (List.rev $2)).pexp_desc }
+      { reloc_exp (mktailexp (List.rev $2)) }
   | LBRACKET expr_semi_list opt_semi error
       { unclosed "[" 1 "]" 4 }
   | PREFIXOP simple_expr
@@ -983,13 +1013,13 @@ fun_binding:
     strict_binding
       { $1 }
   | type_constraint EQUAL seq_expr
-      { let (t, t') = $1 in mkexp(Pexp_constraint($3, t, t')) }
+      { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) }
 ;
 strict_binding:
     EQUAL seq_expr
       { $2 }
   | labeled_simple_pattern fun_binding
-      { let (l, o, p) = $1 in mkexp(Pexp_function(l, o, [p, $2])) }
+      { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
 ;
 match_cases:
     pattern match_action                        { [$1, $2] }
@@ -998,7 +1028,7 @@ match_cases:
 fun_def:
     match_action                                { $1 }
   | labeled_simple_pattern fun_def
-      { let (l,o,p) = $1 in mkexp(Pexp_function(l, o, [p, $2])) }
+      { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
 ;
 match_action:
     MINUSGREATER seq_expr                       { $2 }
@@ -1075,7 +1105,7 @@ simple_pattern:
   | LBRACE lbl_pattern_list opt_semi error
       { unclosed "{" 1 "}" 4 }
   | LBRACKET pattern_semi_list opt_semi RBRACKET
-      { mkpat (mktailpat (List.rev $2)).ppat_desc }
+      { reloc_pat (mktailpat (List.rev $2)) }
   | LBRACKET pattern_semi_list opt_semi error
       { unclosed "[" 1 "]" 4 }
   | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
@@ -1085,7 +1115,7 @@ simple_pattern:
   | LBRACKETBAR pattern_semi_list opt_semi error
       { unclosed "[|" 1 "|]" 4 }
   | LPAREN pattern RPAREN
-      { $2 }
+      { reloc_pat $2 }
   | LPAREN pattern error
       { unclosed "(" 1 ")" 3 }
   | LPAREN pattern COLON core_type RPAREN
@@ -1120,6 +1150,7 @@ type_declarations:
     type_declaration                            { [$1] }
   | type_declarations AND type_declaration      { $3 :: $1 }
 ;
+
 type_declaration:
     type_parameters LIDENT type_kind constraints
       { let (params, variance) = List.split $1 in
@@ -1138,18 +1169,18 @@ constraints:
 type_kind:
     /*empty*/
       { (Ptype_abstract, None) }
-  | EQUAL core_type
-      { (Ptype_abstract, Some $2) }
-  | EQUAL constructor_declarations
-      { (Ptype_variant(List.rev $2), None) }
-  | EQUAL BAR constructor_declarations
-      { (Ptype_variant(List.rev $3), None) }
-  | EQUAL LBRACE label_declarations opt_semi RBRACE
-      { (Ptype_record(List.rev $3), None) }
-  | EQUAL core_type EQUAL opt_bar constructor_declarations
-      { (Ptype_variant(List.rev $5), Some $2) }
-  | EQUAL core_type EQUAL LBRACE label_declarations opt_semi RBRACE
-      { (Ptype_record(List.rev $5), Some $2) }
+  | EQUAL private_flag core_type
+      { (mktype_kind $2 Ptype_abstract, Some $3) }
+  | EQUAL private_flag constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $3)), None) }
+  | EQUAL private_flag BAR constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $4)), None) }
+  | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
+      { (mktype_kind $2 (Ptype_record(List.rev $4)), None) }
+  | EQUAL private_flag core_type EQUAL opt_bar constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $6)), Some $3) }
+  | EQUAL private_flag core_type EQUAL LBRACE label_declarations opt_semi RBRACE
+      { (mktype_kind $2 (Ptype_record(List.rev $6)), Some $3) }
 ;
 type_parameters:
     /*empty*/                                   { [] }
@@ -1277,18 +1308,16 @@ simple_core_type2:
       { mktyp(Ptyp_variant([$2], true, None)) }
   | LBRACKET BAR row_field_list RBRACKET
       { mktyp(Ptyp_variant(List.rev $3, true, None)) }
-  | LBRACKETBAR row_field_list RBRACKET
-      { mktyp(Ptyp_variant(List.rev $2, true, None)) }
   | LBRACKET row_field BAR row_field_list RBRACKET
       { mktyp(Ptyp_variant($2 :: List.rev $4, true, None)) }
   | LBRACKET GREATER opt_bar row_field_list RBRACKET
       { mktyp(Ptyp_variant(List.rev $4, false, None)) }
+  | LBRACKET GREATER RBRACKET
+      { mktyp(Ptyp_variant([], false, None)) }
   | LBRACKETLESS opt_bar row_field_list RBRACKET
       { mktyp(Ptyp_variant(List.rev $3, true, Some [])) }
   | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET
       { mktyp(Ptyp_variant(List.rev $3, true, Some (List.rev $5))) }
-  | LBRACKET GREATER RBRACKET
-      { mktyp(Ptyp_variant([], false, None)) }
 ;
 row_field_list:
     row_field                                   { [$1] }
@@ -1357,11 +1386,17 @@ constant:
   | CHAR                                        { Const_char $1 }
   | STRING                                      { Const_string $1 }
   | FLOAT                                       { Const_float $1 }
+  | INT32                                       { Const_int32 $1 }
+  | INT64                                       { Const_int64 $1 }
+  | NATIVEINT                                   { Const_nativeint $1 }
 ;
 signed_constant:
     constant                                    { $1 }
   | MINUS INT                                   { Const_int(- $2) }
-  | subtractive FLOAT                           { Const_float("-" ^ $2) }
+  | MINUS FLOAT                                 { Const_float("-" ^ $2) }
+  | MINUS INT32                                 { Const_int32(Int32.neg $2) }
+  | MINUS INT64                                 { Const_int64(Int64.neg $2) }
+  | MINUS NATIVEINT                             { Const_nativeint(Nativeint.neg $2) }
 ;
 /* Identifiers and long identifiers */
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 541fd231a9..479a34836d 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -132,6 +132,7 @@ and type_kind =
     Ptype_abstract
   | Ptype_variant of (string * core_type list) list
   | Ptype_record of (string * mutable_flag * core_type) list
+  | Ptype_private of type_kind
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 3d334c3981..53688aa5ef 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -46,9 +46,11 @@ let fmt_constant f x =
   match x with
   | Const_int (i) -> fprintf f "Const_int %d" i;
   | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);
-  | Const_string (s) ->
-      fprintf f "Const_string %S" s;
+  | Const_string (s) -> fprintf f "Const_string %S" s;
   | Const_float (s) -> fprintf f "Const_float %s" s;
+  | Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
+  | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
+  | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
 ;;
 
 let fmt_mutable_flag f x =
@@ -322,6 +324,9 @@ and type_kind i ppf x =
   | Ptype_record (l) ->
       line i ppf "Ptype_record\n";
       list (i+1) string_x_mutable_flag_x_core_type ppf l;
+  | Ptype_private x ->
+      line i ppf "Ptype_private\n";
+      type_kind (i + 1) ppf x
 
 and exception_declaration i ppf x = list i core_type ppf x
 
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 98152421a6..9b760e63d3 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -102,14 +102,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
       Pident(Ident.create "print_string"), Predef.type_string,
         (fun x -> Oval_string (O.obj x : string));
       Pident(Ident.create "print_int32"), Predef.type_int32,
-        (fun x -> Oval_stuff ("<int32 " ^
-                              Int32.to_string (O.obj x : int32) ^ ">"));
+        (fun x -> Oval_int32 (O.obj x : int32));
       Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
-        (fun x -> Oval_stuff ("<nativeint " ^
-                             Nativeint.to_string (O.obj x : nativeint) ^ ">"));
+        (fun x -> Oval_nativeint (O.obj x : nativeint));
       Pident(Ident.create "print_int64"), Predef.type_int64,
-        (fun x -> Oval_stuff ("<int64 " ^
-                              Int64.to_string (O.obj x : int64) ^ ">"))
+        (fun x -> Oval_int64 (O.obj x : int64))
     ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
 
     let install_printer path ty fn =
@@ -236,7 +233,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           | Tconstr(path, ty_list, _) ->
               begin try
                 let decl = Env.find_type path env in
-                match decl with
+                let rec tree_decl = function
                 | {type_kind = Type_abstract; type_manifest = None} ->
                     Oval_stuff "<abstr>"
                 | {type_kind = Type_abstract; type_manifest = Some body} ->
@@ -259,7 +256,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                     tree_of_constr_with_args (tree_of_constr env path)
                                            constr_name 0 depth obj ty_args
                 | {type_kind = Type_record(lbl_list, rep)} ->
-                    match check_depth depth obj ty with
+                    begin match check_depth depth obj ty with
                       Some x -> x
                     | None ->
                         let rec tree_of_fields pos = function
@@ -279,6 +276,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                               (lid, v) :: tree_of_fields (pos + 1) remainder
                         in
                         Oval_record (tree_of_fields 0 lbl_list)
+                    end
+                | {type_kind = Type_private tkind} ->
+                    tree_decl {decl with type_kind = tkind} in
+                tree_decl decl
               with
                 Not_found ->                (* raised by Env.find_type *)
                   Oval_stuff "<abstr>"
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index ff3c10e9f3..28276d54d6 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -53,6 +53,7 @@ let main () =
        \032    A/a enable/disable all warnings\n\
        \032    C/c enable/disable suspicious comment\n\
        \032    D/d enable/disable deprecated features\n\
+       \032    E/e enable/disable fragile match\n\
        \032    F/f enable/disable partially applied function\n\
        \032    M/m enable/disable overriden method\n\
        \032    P/p enable/disable partial match\n\
@@ -60,7 +61,8 @@ let main () =
        \032    U/u enable/disable unused match case\n\
        \032    V/v enable/disable hidden instance variable\n\
        \032    X/x enable/disable all other warnings\n\
-       \032    default setting is \"Al\" (all warnings but labels enabled)";
+       \032    default setting is \"Ale\"\n\
+       \032    (all warnings but labels and fragile match enabled)";
      "-warn-error" , Arg.String (Warnings.parse_options true),
        "<flags>  Enable or disable fatal warnings according to <flags>\n\
          \032    (see option -w for the list of flags)\n\
diff --git a/typing/btype.ml b/typing/btype.ml
index df5242c7f3..263eec2c63 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -252,13 +252,14 @@ let rec unmark_type ty =
 
 let unmark_type_decl decl =
   List.iter unmark_type decl.type_params;
-  begin match decl.type_kind with
+  let rec unmark_tkind = function
     Type_abstract -> ()
   | Type_variant cstrs ->
       List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
   | Type_record(lbls, rep) ->
       List.iter (fun (c, mut, t) -> unmark_type t) lbls
-  end;
+  | Type_private tkind -> unmark_tkind tkind in
+  unmark_tkind decl.type_kind;
   begin match decl.type_manifest with
     None    -> ()
   | Some ty -> unmark_type ty
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 21e6571d19..02b4ce2196 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -422,14 +422,15 @@ let closed_parameterized_type params ty =
 let closed_type_decl decl =
   try
     List.iter mark_type decl.type_params;
-    begin match decl.type_kind with
+    let rec closed_tkind = function
       Type_abstract ->
         ()
     | Type_variant v ->
         List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
     | Type_record(r, rep) ->
         List.iter (fun (_, _, ty) -> closed_type ty) r
-    end;
+    | Type_private tkind -> closed_tkind tkind in
+    closed_tkind decl.type_kind;
     begin match decl.type_manifest with
       None    -> ()
     | Some ty -> closed_type ty
@@ -760,7 +761,7 @@ let rec copy ty =
           let more = repr row.row_more in
           (* We must substitute in a subtle way *)
           begin match more.desc with
-            Tsubst ({desc=Tvariant _} as ty2) ->
+            Tsubst ty2 when (repr ty2).desc <> Tunivar ->
               (* This variant type has been already copied *)
               ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
               Tlink ty2
@@ -928,7 +929,7 @@ let rec copy_sep fixed free bound visited ty =
           let bound = tl @ bound in
           let visited =
             List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
-          Tpoly (copy_rec t1, tl')
+          Tpoly (copy_sep fixed free bound visited t1, tl')
       | _ -> copy_type_desc copy_rec ty.desc
       end;
     t
@@ -1022,7 +1023,19 @@ let rec find_expans p1 =
   | Mlink {contents = rem} ->
       find_expans p1 rem
 
+
+(* 
+   If the environnement has changed, memorized expansions might not
+   be correct anymore, and so we flush the cache. This is safe but
+   quite pessimistic: it would be enough to flush the cache when a
+   type or module definition is overriden in the environnement.
+*)
 let previous_env = ref Env.empty
+let check_abbrev_env env =
+  if env != !previous_env then begin
+    cleanup_abbrev ();
+    previous_env := env
+  end
 
 (* Expand an abbreviation. The expansion is memorized. *)
 (* 
@@ -1043,16 +1056,7 @@ let previous_env = ref Env.empty
       and this other expansion fails.
 *)
 let expand_abbrev env ty =
-  (* 
-     If the environnement has changed, memorized expansions might not
-     be correct anymore, and so we flush the cache. This is safe but
-     quite pessimistic: it would be enough to flush the cache when a
-     type or module definition is overriden in the environnement.
-  *)
-  if env != !previous_env then begin
-    cleanup_abbrev ();
-    previous_env := env
-  end;
+  check_abbrev_env env;
   match ty with
     {desc = Tconstr (path, args, abbrev); level = level} ->
       let lookup_abbrev = proper_abbrevs path args abbrev in
@@ -1173,6 +1177,7 @@ let rec non_recursive_abbrev env ty0 ty =
   end
 
 let correct_abbrev env ident params ty =
+  check_abbrev_env env;
   let ty0 = newgenvar () in
   visited := [];
   let abbrev = Mcons (Path.Pident ident, ty0, ty0, Mnil) in
@@ -2342,6 +2347,11 @@ let moregeneral env inst_nongen pat_sch subj_sch =
                  (*  Equivalence between parameterized types  *)
                  (*********************************************)
 
+let normalize_subst subst =
+  if List.exists
+      (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+      !subst
+  then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
 
 let rec eqtype rename type_pairs subst env t1 t2 =
   if t1 == t2 then () else
@@ -2353,6 +2363,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
     match (t1.desc, t2.desc) with
       (Tvar, Tvar) when rename ->
         begin try
+          normalize_subst subst;
           if List.assq t1 !subst != t2 then raise (Unify [])
         with Not_found ->
           subst := (t1, t2) :: !subst
@@ -2372,6 +2383,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
           match (t1'.desc, t2'.desc) with
             (Tvar, Tvar) when rename ->
               begin try
+                normalize_subst subst;
                 if List.assq t1' !subst != t2' then raise (Unify [])
               with Not_found ->
                 subst := (t1', t2') :: !subst
@@ -2808,7 +2820,7 @@ let rec build_subtype env visited loops posi level t =
         try
           let t' = List.assq t loops in
           warn := true;
-          (List.assq t loops, Equiv)
+          (t', Equiv)
         with Not_found ->
           (t, Unchanged)
       else
@@ -2852,7 +2864,7 @@ let rec build_subtype env visited loops posi level t =
               end
             | None -> assert false in
           let ty =
-            subst env t'.level abbrev None cl_abbr.type_params tl body in
+            subst env !current_level abbrev None cl_abbr.type_params tl body in
           let ty = repr ty in
           let ty1, tl1 =
             match ty.desc with
@@ -3354,7 +3366,7 @@ let nondep_type_decl env mid id is_covariant decl =
         type_arity = decl.type_arity;
         type_kind =
           begin try
-            match decl.type_kind with
+            let rec kind_of_tkind = function
               Type_abstract ->
                 Type_abstract
             | Type_variant cstrs ->
@@ -3367,6 +3379,8 @@ let nondep_type_decl env mid id is_covariant decl =
                     (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t))
                     lbls,
                   rep)
+            | Type_private tkind -> Type_private (kind_of_tkind tkind) in
+            kind_of_tkind decl.type_kind
           with Not_found when is_covariant ->
             Type_abstract
           end;
@@ -3384,13 +3398,14 @@ let nondep_type_decl env mid id is_covariant decl =
     in
     cleanup_types ();
     List.iter unmark_type decl.type_params;
-    begin match decl.type_kind with
+    let rec unmark_tkind = function
       Type_abstract -> ()
     | Type_variant cstrs ->
         List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
     | Type_record(lbls, rep) ->
         List.iter (fun (c, mut, t) -> unmark_type t) lbls
-    end;
+    | Type_private tkind -> unmark_tkind tkind in
+    unmark_tkind decl.type_kind;
     begin match decl.type_manifest with
       None    -> ()
     | Some ty -> unmark_type ty
diff --git a/typing/env.ml b/typing/env.ml
index 1e93b40ff8..33788d4796 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -363,7 +363,7 @@ and lookup_class =
   lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
 and lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
-  
+
 (* Expand manifest module type names at the top of the given module type *)
 
 let rec scrape_modtype mty env =
@@ -379,22 +379,27 @@ let rec scrape_modtype mty env =
 (* Compute constructor descriptions *)
 
 let constructors_of_type ty_path decl =
-  match decl.type_kind with
-    Type_variant cstrs ->
+  let rec constructors_of_tkind = function
+  | Type_variant cstrs ->
       Datarepr.constructor_descrs
         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         cstrs
-  | _ -> []
+  | Type_private tkind -> constructors_of_tkind tkind
+  | Type_record _ | Type_abstract -> [] in
+  constructors_of_tkind decl.type_kind
+
 
 (* Compute label descriptions *)
 
 let labels_of_type ty_path decl =
-  match decl.type_kind with
-    Type_record(labels, rep) ->
+  let rec labels_of_tkind = function
+  | Type_record(labels, rep) ->
       Datarepr.label_descrs
         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         labels rep
-  | _ -> []
+  | Type_private tkind -> labels_of_tkind tkind
+  | Type_variant _ | Type_abstract -> [] in
+  labels_of_tkind decl.type_kind
 
 (* Given a signature and a root path, prefix all idents in the signature
    by the root path and build the corresponding substitution. *)
diff --git a/typing/ident.ml b/typing/ident.ml
index afa589bad6..8997600d51 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -35,6 +35,8 @@ let name i = i.name
 
 let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
 
+let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
+
 let persistent i = (i.stamp = 0)
 
 let equal i1 i2 = i1.name = i2.name
@@ -50,6 +52,13 @@ let binding_time i = i.stamp
 let current_time() = !currentstamp
 let set_current_time t = currentstamp := max !currentstamp t
 
+let reinit_level = ref (-1)
+
+let reinit () = 
+  if !reinit_level < 0
+  then reinit_level := !currentstamp
+  else currentstamp := !reinit_level
+
 let hide i =
   { i with stamp = -1 }
 
diff --git a/typing/ident.mli b/typing/ident.mli
index 1d8d0580c7..1bec7fb7a1 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -21,6 +21,7 @@ val create_persistent: string -> t
 val rename: t -> t
 val name: t -> string
 val unique_name: t -> string
+val unique_toplevel_name: t -> string
 val persistent: t -> bool
 val equal: t -> t -> bool
         (* Compare identifiers by name. *)      
@@ -32,7 +33,7 @@ val same: t -> t -> bool
            name. *)
 val hide: t -> t
         (* Return an identifier with same name as the given identifier,
-           but stamp different from any stamp returns by new.
+           but stamp different from any stamp returned by new.
            When put in a 'a tbl, this identifier can only be looked
            up by name. *)
 
@@ -42,6 +43,7 @@ val global: t -> bool
 val binding_time: t -> int
 val current_time: unit -> int
 val set_current_time: int -> unit
+val reinit: unit -> unit
 
 val print: Format.formatter -> t -> unit
 
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 9a8c941473..63050cf6d9 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -38,7 +38,7 @@ let value_descriptions env vd1 vd2 =
 
 let type_declarations env id decl1 decl2 =
   decl1.type_arity = decl2.type_arity &&
-  begin match (decl1.type_kind, decl2.type_kind) with
+  let rec incl_tkinds = function
       (_, Type_abstract) -> true
     | (Type_variant cstrs1, Type_variant cstrs2) ->
         Misc.for_all2
@@ -58,8 +58,11 @@ let type_declarations env id decl1 decl2 =
             Ctype.equal env true (ty1::decl1.type_params)
                                  (ty2::decl2.type_params))
           labels1 labels2
-    | (_, _) -> false
-  end &&
+    | (Type_private tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
+    | (tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
+    | (_, _) -> false in
+  incl_tkinds (decl1.type_kind, decl2.type_kind)
+  &&
   begin match (decl1.type_manifest, decl2.type_manifest) with
       (_, None) ->
         Ctype.equal env true decl1.type_params decl2.type_params
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 42f1331859..483230c324 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -40,6 +40,12 @@ let value_ident ppf name =
 
 (* Values *)
 
+let parenthesize_if_neg ppf fmt v zero =
+  let neg = (v < zero) in
+  if neg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if neg then pp_print_char ppf ')'
+
 let print_out_value ppf tree =
   let rec print_tree_1 ppf =
     function
@@ -52,14 +58,18 @@ let print_out_value ppf tree =
         fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param
     | tree -> print_simple_tree ppf tree
   and print_constr_param ppf = function
-    | Oval_int i ->
-       if i < 0 then fprintf ppf "(%i)" i else fprintf ppf "%i" i
-    | Oval_float f ->
-       if f < 0.0 then fprintf ppf "(%F)" f else fprintf ppf "%F" f
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i 0
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i 0l
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i 0L
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i 0n
+    | Oval_float f -> parenthesize_if_neg ppf "%F" f 0.0
     | tree -> print_simple_tree ppf tree
   and print_simple_tree ppf =
     function
       Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
     | Oval_float f -> fprintf ppf "%F" f
     | Oval_char c -> fprintf ppf "%C" c
     | Oval_string s ->
@@ -78,7 +88,7 @@ let print_out_value ppf tree =
     | Oval_ellipsis -> raise Ellipsis
     | Oval_printer f -> f ppf
     | Oval_tuple tree_list ->
-        fprintf ppf "@[(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
     | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
   and print_fields first ppf =
     function
@@ -125,7 +135,7 @@ let pr_vars =
 let rec print_out_type ppf =
   function
   | Otyp_alias (ty, s) ->
-      fprintf ppf "@[%a as '%s@]" print_out_type ty s
+      fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
   | Otyp_poly (sl, ty) ->
       fprintf ppf "@[<hov 2>%a.@ %a@]"
         pr_vars sl
@@ -169,14 +179,15 @@ and print_simple_out_type ppf =
         | Ovar_name (id, tyl) ->
             fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
       in
-      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a]@]" (if non_gen then "_" else "")
+      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
         (if closed then if tags = None then " " else "< "
          else if tags = None then "> " else "? ")
         print_fields row_fields
         print_present tags
   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
       fprintf ppf "@[<1>(%a)@]" print_out_type ty
-  | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
+  | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _
+  | Otyp_manifest (_, _) -> ()
 and print_fields rest ppf =
   function
     [] ->
@@ -359,21 +370,26 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
       Otyp_manifest (_, ty) -> ty
     | _ -> ty
   in
-  match ty with
-    Otyp_abstract ->
+  let print_private ppf v = if v then fprintf ppf "private " in
+  let rec print_out_tkind v = function
+  | Otyp_abstract ->
       fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
         constraints
   | Otyp_record lbls ->
-      fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args
+      fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
+        print_private v
         (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
         print_constraints constraints
   | Otyp_sum constrs ->
-      fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args
+      fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
+        print_private v
         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
         print_constraints constraints
+  | Otyp_private ty -> print_out_tkind true ty
   | ty ->
       fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args !out_type
-        ty print_constraints constraints
+        ty print_constraints constraints in
+  print_out_tkind false ty
 and print_out_constr ppf (name, tyl) =
   match tyl with
     [] -> fprintf ppf "%s" name
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 0b027dd6be..1b0a30a79f 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -33,6 +33,9 @@ type out_value =
   | Oval_ellipsis
   | Oval_float of float
   | Oval_int of int
+  | Oval_int32 of int32
+  | Oval_int64 of int64
+  | Oval_nativeint of nativeint
   | Oval_list of out_value list
   | Oval_printer of (Format.formatter -> unit)
   | Oval_record of (out_ident * out_value) list
@@ -52,6 +55,7 @@ type out_type =
   | Otyp_record of (string * bool * out_type) list
   | Otyp_stuff of string
   | Otyp_sum of (string * out_type list) list
+  | Otyp_private of out_type
   | Otyp_tuple of out_type list
   | Otyp_var of bool * string
   | Otyp_variant of
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 95151e6bb3..828e004945 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -114,6 +114,12 @@ let get_type_descr ty tenv =
   | Tconstr (path,_,_) -> Env.find_type path tenv
   | _ -> fatal_error "Parmatch.get_type_descr"
 
+let get_type_path ty tenv =
+  let ty = Ctype.repr (Ctype.expand_head tenv ty) in
+  match ty.desc with
+  | Tconstr (path,_,_) -> path
+  | _ -> fatal_error "Parmatch.get_type_path"
+
 let get_constr tag ty tenv =
   match get_type_descr ty tenv with
   | {type_kind=Type_variant constr_list} ->
@@ -156,12 +162,12 @@ let rec pretty_val ppf v = match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
   | Tpat_var x -> Ident.print ppf x
   | Tpat_constant (Const_int i) -> fprintf ppf "%d" i
-  | Tpat_constant (Const_char c) ->
-      fprintf ppf "%C" c
-  | Tpat_constant (Const_string s) ->
-      fprintf ppf "%S" s
-  | Tpat_constant (Const_float s) ->
-      fprintf ppf "%s" s
+  | Tpat_constant (Const_char c) -> fprintf ppf "%C" c
+  | Tpat_constant (Const_string s) -> fprintf ppf "%S" s
+  | Tpat_constant (Const_float f) -> fprintf ppf "%s" f
+  | Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
+  | Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
+  | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
   | Tpat_construct ({cstr_tag=tag},[]) ->
@@ -578,6 +584,17 @@ let full_match tdefs force env =  match env with
 | ({pat_desc = Tpat_array(_)},_) :: _ -> false
 | _ -> fatal_error "Parmatch.full_match"
 
+let extendable_match env = match env with
+| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false
+| ({pat_desc = Tpat_construct(c,_)} as p,_) :: _ ->
+    let path = get_type_path p.pat_type p.pat_env in
+    not
+      (Path.same path Predef.path_bool ||
+      Path.same path Predef.path_list ||
+      Path.same path Predef.path_option)
+| _ -> false
+
+
 (* complement constructor tags *)
 let complete_tags nconsts nconstrs tags =
   let seen_const = Array.create nconsts false
@@ -633,6 +650,16 @@ with
 | _ -> fatal_error "Parmatch.complete_constr"
 
 
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+  let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+  let rec try_const i =
+    if List.mem i all
+    then try_const (next i)
+    else make_pat (make i) p.pat_type p.pat_env
+  in try_const first
+
 (*
   Builds a pattern that is incompatible with all patterns in
   in the first column of env
@@ -709,47 +736,40 @@ let build_other env =  match env with
     try_chars
       [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
         ' ', '~' ; Char.chr 0 , Char.chr 255]
+
 | ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
-    let all_ints =
-      List.map
-        (fun (p,_) -> match p.pat_desc with
-        | Tpat_constant (Const_int i) -> i
-        | _ -> assert false)
-        env in
-    let rec try_ints i =
-      if List.mem i all_ints then try_ints (i+1)
-      else
-        make_pat
-          (Tpat_constant (Const_int i)) p.pat_type p.pat_env in
-    try_ints 0
+    build_other_constant
+      (function Tpat_constant(Const_int i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int i))
+      0 succ p env
+| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int32 i))
+      0l Int32.succ p env
+| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_int64 i))
+      0L Int64.succ p env
+| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
+    build_other_constant
+      (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
+      (function i -> Tpat_constant(Const_nativeint i))
+      0n Nativeint.succ p env
 | ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
-    let all_lengths =
-      List.map
-        (fun (p,_) -> match p.pat_desc with
-        | Tpat_constant (Const_string s) -> String.length s
-        | _ -> assert false)
-        env in
-    let rec try_strings i =
-      if List.mem i all_lengths then try_strings (i+1)
-      else
-        make_pat
-          (Tpat_constant (Const_string (String.make i '*')))
-          p.pat_type p.pat_env in
-    try_strings 0
+    build_other_constant
+      (function Tpat_constant(Const_string s) -> String.length s
+              | _ -> assert false)
+      (function i -> Tpat_constant(Const_string(String.make i '*')))
+      0 succ p env
 | ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
-    let all_floats =
-      List.map
-        (fun (p,_) -> match p.pat_desc with
-        | Tpat_constant (Const_float s) -> float_of_string s
-        | _ -> assert false)
-        env in
-    let rec try_floats f =
-      if List.mem f all_floats then try_floats (f +. 1.0)
-      else
-        make_pat
-          (Tpat_constant (Const_float (string_of_float f)))
-          p.pat_type p.pat_env in
-    try_floats 0.0
+    build_other_constant
+      (function Tpat_constant(Const_float f) -> float_of_string f
+              | _ -> assert false)
+      (function f -> Tpat_constant(Const_float (string_of_float f)))
+      0.0 (fun f -> f +. 1.0) p env
+
 | ({pat_desc = Tpat_array args} as p,_)::_ ->
     let all_lengths =
       List.map
@@ -796,28 +816,83 @@ and has_instances = function
 let rec satisfiable pss qs = match pss with
 | [] -> has_instances qs 
 | _  ->
-match qs with
-| [] -> false
-| {pat_desc = Tpat_or(q1,q2,_)}::qs -> 
-    satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+    match qs with
+    | [] -> false
+    | {pat_desc = Tpat_or(q1,q2,_)}::qs -> 
+        satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+    | {pat_desc = Tpat_alias(q,_)}::qs ->
+          satisfiable pss (q::qs)
+    | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+        let q0 = discr_pat omega pss in
+        begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+        | [] -> satisfiable (filter_extra pss) qs
+        | constrs  ->
+            (not (full_match Env.empty false constrs) &&
+             satisfiable (filter_extra pss) qs) ||
+             List.exists
+               (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
+               constrs
+        end
+    | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
+    | q::qs ->
+        let q0 = discr_pat q pss in
+        satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+
+(*
+  Like satisfiable, looking for a matching value with an extra constructor.
+  That is, look for the situation where adding one constructor
+  would NOT yield a non-exhaustive matching.
+  *)
+
+let relevant_location loc r = match r with
+  | None -> None
+  | Some rloc ->
+      if rloc = Location.none then
+        Some loc
+      else
+        r
+        
+let rec satisfiable_extra some pss qs = match qs with
+| [] -> if pss = [] then some else None
+| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+    let r1 = satisfiable_extra some pss (q1::qs) in
+    begin match r1 with
+    | Some _ -> r1
+    | None -> satisfiable_extra some pss (q2::qs)
+    end
 | {pat_desc = Tpat_alias(q,_)}::qs ->
-    satisfiable pss (q::qs)
-| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+    satisfiable_extra some pss (q::qs)
+| {pat_desc = (Tpat_any | Tpat_var(_))} as q::qs ->
     let q0 = discr_pat omega pss in
-    begin match filter_all q0 pss with
+    let r =
+      match filter_all q0 pss with
           (* first column of pss is made of variables only *)
-    | [] -> satisfiable (filter_extra pss) qs
-    | constrs  ->
-        (not (full_match Env.empty false constrs) &&
-        satisfiable (filter_extra pss) qs) ||
-        List.exists
-          (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
-          constrs
-    end
-| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
+      | [] -> satisfiable_extra some (filter_extra pss) qs
+      | constrs ->
+          if extendable_match constrs then
+            let rloc =
+              satisfiable_extra (Some q.pat_loc) (filter_extra pss) qs in
+            match rloc with
+            | Some loc -> rloc
+            | None -> try_many_extra some qs constrs
+          else
+            try_many_extra some qs constrs in
+    relevant_location q.pat_loc r
 | q::qs ->
     let q0 = discr_pat q pss in
-    satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+    relevant_location
+      q.pat_loc
+      (satisfiable_extra
+         some (filter_one q0 pss) (simple_match_args q0 q @ qs))
+
+and try_many_extra some qs = function
+  | [] -> None
+  | (p,pss)::rem ->
+      let rloc = satisfiable_extra some pss (simple_match_args p omega @ qs) in
+      match rloc with
+      | Some _ -> rloc
+      | None -> try_many_extra some qs rem
 
 
 (*
@@ -964,6 +1039,7 @@ let is_var_column rs =
     | []   -> assert false)
     rs
 
+(* Standard or-args for left-to-right matching *)
 let rec or_args p = match p.pat_desc with
 | Tpat_or (p1,p2,_) -> p1,p2
 | Tpat_alias (p,_)  -> or_args p
@@ -1095,7 +1171,10 @@ let rec every_satisfiables pss qs = match qs.active with
 (* otherwise this is direct food for satisfiable *)
           every_satisfiables (push_no_or_column pss) (push_no_or qs)
     | Tpat_or (q1,q2,_) ->
-        if uq.pat_loc.Location.loc_ghost then
+        if
+          q1.pat_loc.Location.loc_ghost &&
+          q2.pat_loc.Location.loc_ghost
+        then
 (* syntactically generated or-pats should not be expanded *)
           every_satisfiables (push_no_or_column pss) (push_no_or qs)
         else 
@@ -1427,6 +1506,24 @@ let location_of_clause = function
 
 let seen_pat q pss = [q]::pss
 
+(* Extra check
+    Will this clause match if someone adds a constructor somewhere
+*)
+
+let warn_fragile () = Warnings.is_active (Warnings.Fragile_pat "")
+
+let check_used_extra pss qs =
+  if warn_fragile () then begin
+    match satisfiable_extra None pss qs with
+    | Some location ->
+        Location.prerr_warning
+          location
+          (Warnings.Fragile_pat "")
+    | None -> ()
+  end
+
+  
+  
 let check_unused tdefs casel =
   if Warnings.is_active Warnings.Unused_match then
     let rec do_rec pref = function
@@ -1446,7 +1543,8 @@ let check_unused tdefs casel =
                       Location.prerr_warning
                         p.pat_loc Warnings.Unused_pat)
                     ps
-              | Used -> ()
+              | Used ->
+                  check_used_extra pss qs
             with e -> (* useless ? *)
               Location.prerr_warning (location_of_clause qs)
                 (Warnings.Other "Fatal Error in Parmatch.check_unused") ;
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index a189f9ac08..2e82271d22 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -413,14 +413,15 @@ let rec tree_of_type_decl id decl =
   | None -> ()
   | Some ty -> mark_loops ty
   end;
-  begin match decl.type_kind with
+  let rec mark = function
   | Type_abstract -> ()
   | Type_variant [] -> ()
   | Type_variant cstrs ->
       List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
   | Type_record(l, rep) ->
       List.iter (fun (_, _, ty) -> mark_loops ty) l
-  end;
+  | Type_private tkind -> mark tkind in
+  mark decl.type_kind;
 
   let type_param =
     function
@@ -451,8 +452,7 @@ let rec tree_of_type_decl id decl =
   in
   let (name, args) = type_defined decl in
   let constraints = tree_of_constraints params in
-  let ty =
-    match decl.type_kind with
+  let rec tree_of_tkind = function
     | Type_abstract ->
         begin match decl.type_manifest with
         | None -> Otyp_abstract
@@ -462,6 +462,8 @@ let rec tree_of_type_decl id decl =
         tree_of_manifest decl (Otyp_sum (List.map tree_of_constructor cstrs))
     | Type_record(lbls, rep) ->
         tree_of_manifest decl (Otyp_record (List.map tree_of_label lbls))
+    | Type_private tkind -> Otyp_private (tree_of_tkind tkind) in
+  let ty = tree_of_tkind decl.type_kind 
   in
   (name, args, ty, constraints)
 
@@ -539,7 +541,7 @@ let tree_of_metho sch concrete csil (lab, kind, ty) =
 let rec prepare_class_type params = function
   | Tcty_constr (p, tyl, cty) ->
       let sty = Ctype.self_type cty in
-      if List.memq sty !visited_objects
+      if List.memq (proxy sty) !visited_objects
       || List.exists (fun ty -> (repr ty).desc <> Tvar) params
       || List.exists (deep_occur sty) tyl
       then prepare_class_type params cty
@@ -547,8 +549,9 @@ let rec prepare_class_type params = function
   | Tcty_signature sign ->
       let sty = repr sign.cty_self in
       (* Self may have a name *)
-      if List.memq sty !visited_objects then add_alias sty
-      else visited_objects := proxy sty :: !visited_objects;
+      let px = proxy sty in
+      if List.memq px !visited_objects then add_alias sty
+      else visited_objects := px :: !visited_objects;
       let (fields, _) =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
@@ -562,7 +565,7 @@ let rec tree_of_class_type sch params =
   function
   | Tcty_constr (p', tyl, cty) ->
       let sty = Ctype.self_type cty in
-      if List.memq sty !visited_objects
+      if List.memq (proxy sty) !visited_objects
       || List.exists (fun ty -> (repr ty).desc <> Tvar) params
       then
         tree_of_class_type sch params cty
diff --git a/typing/subst.ml b/typing/subst.ml
index 32452902ba..8225877953 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -99,7 +99,7 @@ let rec typexp s ty =
           let more = repr row.row_more in
           (* We must substitute in a subtle way *)
           begin match more.desc with
-            Tsubst ({desc=Tvariant _} as ty2) ->
+            Tsubst ty2 when (repr ty2).desc <> Tunivar ->
               (* This variant type has been already copied *)
               ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
               Tlink ty2
@@ -154,8 +154,9 @@ let type_declaration s decl =
     { type_params = List.map (typexp s) decl.type_params;
       type_arity = decl.type_arity;
       type_kind =
-        begin match decl.type_kind with
-          Type_abstract -> Type_abstract
+        begin
+        let rec kind_of_tkind = function
+        | Type_abstract -> Type_abstract
         | Type_variant cstrs ->
             Type_variant(
               List.map (fun (n, args) -> (n, List.map (typexp s) args))
@@ -165,6 +166,8 @@ let type_declaration s decl =
               List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
                        lbls,
               rep)
+        | Type_private tkind -> Type_private (kind_of_tkind tkind) in
+        kind_of_tkind decl.type_kind
         end;
       type_manifest =
         begin match decl.type_manifest with
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 0296055fb1..74b863ef9b 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -176,6 +176,12 @@ let rec limited_generalize rv =
       Ctype.limited_generalize rv ty;
       limited_generalize rv cty
 
+(* Record a class type *)
+let rc node =
+  Stypes.record (Stypes.Ti_class node);
+  node
+
+
                 (***********************************)
                 (*  Primitives for typing classes  *)
                 (***********************************)
@@ -597,19 +603,19 @@ and class_expr cl_num val_env met_env scl =
              raise(Error(loc, Parameter_mismatch trace)))
         tyl params;
       let cl =        
-        {cl_desc = Tclass_ident path;
-         cl_loc = scl.pcl_loc;
-         cl_type = clty'}
+        rc {cl_desc = Tclass_ident path;
+            cl_loc = scl.pcl_loc;
+            cl_type = clty'}
       in
       let (vals, meths, concrs) = extract_constraints clty in
-      {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
-       cl_loc = scl.pcl_loc;
-       cl_type = clty'}
+      rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = clty'}
   | Pcl_structure cl_str ->
       let (desc, ty) = class_structure cl_num val_env met_env cl_str in
-      {cl_desc = Tclass_structure desc;
-       cl_loc = scl.pcl_loc;
-       cl_type = Tcty_signature ty}
+      rc {cl_desc = Tclass_structure desc;
+          cl_loc = scl.pcl_loc;
+          cl_type = Tcty_signature ty}
   | Pcl_fun (l, Some default, spat, sbody) ->
       let loc = default.pexp_loc in
       let scases =
@@ -669,9 +675,9 @@ and class_expr cl_num val_env met_env scl =
       if Btype.is_optional l && all_labeled cl.cl_type then
         Location.prerr_warning pat.pat_loc
           (Warnings.Other "This optional argument cannot be erased");
-      {cl_desc = Tclass_fun (pat, pv, cl, partial);
-       cl_loc = scl.pcl_loc;
-       cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
+      rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
+          cl_loc = scl.pcl_loc;
+          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
   | Pcl_apply (scl', sargs) ->
       let cl = class_expr cl_num val_env met_env scl' in
       let rec nonopt_labels ls ty_fun =
@@ -756,9 +762,9 @@ and class_expr cl_num val_env met_env scl =
         else
           type_args [] [] cl.cl_type sargs []
       in
-      {cl_desc = Tclass_apply (cl, args);
-       cl_loc = scl.pcl_loc;
-       cl_type = cty}
+      rc {cl_desc = Tclass_apply (cl, args);
+          cl_loc = scl.pcl_loc;
+          cl_type = cty}
   | Pcl_let (rec_flag, sdefs, scl') ->
       let (defs, val_env) =
         try
@@ -789,9 +795,9 @@ and class_expr cl_num val_env met_env scl =
           ([], met_env)
       in
       let cl = class_expr cl_num val_env met_env scl' in
-      {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
-       cl_loc = scl.pcl_loc;
-       cl_type = cl.cl_type}
+      rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type}
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
       let context = Typetexp.narrow () in
@@ -811,9 +817,9 @@ and class_expr cl_num val_env met_env scl =
       | error -> raise(Error(cl.cl_loc, Class_match_failure error))
       end;
       let (vals, meths, concrs) = extract_constraints clty in
-      {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
-       cl_loc = scl.pcl_loc;
-       cl_type = snd (Ctype.instance_class [] clty)}
+      rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
+          cl_loc = scl.pcl_loc;
+          cl_type = snd (Ctype.instance_class [] clty)}
 
 (*******************************)
 
@@ -917,7 +923,8 @@ let class_infos define_class kind
   (* Introduce class parameters *)
   let params =
     try
-      List.map (enter_type_variable true) (fst cl.pci_params)
+      let params, loc = cl.pci_params in
+      List.map (enter_type_variable true loc) params
     with Already_bound ->
       raise(Error(snd cl.pci_params, Repeated_parameter))
   in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 57588d2712..8bebbef1ad 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -42,6 +42,8 @@ type error =
   | Undefined_inherited_method of string
   | Unbound_class of Longident.t
   | Virtual_class of Longident.t
+  | Private_type of string
+  | Private_type_setfield of Longident.t * string
   | Unbound_instance_variable of string
   | Instance_variable_not_mutable of string
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
@@ -65,6 +67,23 @@ let type_module =
   ref ((fun env md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
+
+(*
+  Saving and outputting type information.
+  We keep these function names short, because they have to be
+  called each time we create a record of type [Typedtree.expression]
+  or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+  Stypes.record (Stypes.Ti_expr node);
+  node
+;;
+let rp node =
+  Stypes.record (Stypes.Ti_pat node);
+  node
+;;
+
+
 (* Typing of constants *)
 
 let type_constant = function
@@ -72,7 +91,10 @@ let type_constant = function
   | Const_char _ -> instance Predef.type_char
   | Const_string _ -> instance Predef.type_string
   | Const_float _ -> instance Predef.type_float
-
+  | Const_int32 _ -> instance Predef.type_int32
+  | Const_int64 _ -> instance Predef.type_int64
+  | Const_nativeint _ -> instance Predef.type_nativeint
+  
 (* Specific version of type_option, using newty rather than newgenty *)
 
 let type_option ty =
@@ -93,20 +115,38 @@ let extract_option_type env ty =
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
-let rec extract_label_names env ty =
+let rec extract_label_names sexp env ty =
   let ty = repr ty in
   match ty.desc with
   | Tconstr (path, _, _) ->
       let td = Env.find_type path env in
-      begin match td.type_kind with
+      let rec extract = function
       | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields
       | Type_abstract when td.type_manifest <> None ->
-          extract_label_names env (expand_head env ty)
-      | _ -> assert false
-      end
+          extract_label_names sexp env (expand_head env ty)
+      | Type_private tkind ->
+          raise (Error(sexp.pexp_loc, Private_type (Path.name path)))
+      | _ -> assert false in
+      extract td.type_kind
   | _ ->
       assert false
 
+let check_private get_exc loc env ty =
+  let ty = repr ty in
+  match ty.desc with
+  | Tconstr (path, _, _) ->
+      let td = Env.find_type path env in
+      begin match td.type_kind with
+      | Type_private tkind ->
+          raise (Error(loc, get_exc (Path.name path)))
+      | _ -> () end
+  | _ ->
+      assert false
+
+let check_private_type = check_private (fun s -> Private_type s)
+let check_private_type_setfield lid =
+  check_private (fun s -> Private_type_setfield (lid, s))
+
 (* Typing of patterns *)
 
 (* Creating new conjunctive types is not allowed when typing patterns *)
@@ -240,8 +280,8 @@ let build_or_pat env loc lid =
             (l, Reither(true,[], true, [], ref None)) :: fields
         | Rpresent (Some ty) ->
             bound := ty :: !bound;
-            (l, Some{pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
-                     pat_type=ty})
+            (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                      pat_type=ty})
             :: pats,
             (l, Reither(false, [ty], true, [], ref None)) :: fields
         | _ -> pats, fields)
@@ -260,10 +300,12 @@ let build_or_pat env loc lid =
   match pats with
     [] -> raise(Error(loc, Not_a_variant_type lid))
   | pat :: pats ->
-      List.fold_left
-        (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path); pat_loc=gloc;
-                          pat_env=env; pat_type=ty})
-        pat pats
+      let r =
+        List.fold_left
+          (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path);
+                            pat_loc=gloc; pat_env=env; pat_type=ty})
+          pat pats in
+      rp { r with pat_loc = loc }
 
 let rec flatten_or_pat pat =
   match pat.pat_desc with
@@ -280,14 +322,16 @@ let all_variants pat =
 let rec type_pat env sp =
   match sp.ppat_desc with
     Ppat_any ->
-      { pat_desc = Tpat_any;
+      rp {
+        pat_desc = Tpat_any;
         pat_loc = sp.ppat_loc;
         pat_type = newvar();
         pat_env = env }
   | Ppat_var name ->
       let ty = newvar() in
       let id = enter_variable sp.ppat_loc name ty in
-      { pat_desc = Tpat_var id;
+      rp {
+        pat_desc = Tpat_var id;
         pat_loc = sp.ppat_loc;
         pat_type = ty;
         pat_env = env }
@@ -298,18 +342,21 @@ let rec type_pat env sp =
       end_def ();
       generalize ty_var;
       let id = enter_variable sp.ppat_loc name ty_var in
-      { pat_desc = Tpat_alias(q, id);
+      rp {
+        pat_desc = Tpat_alias(q, id);
         pat_loc = sp.ppat_loc;
         pat_type = q.pat_type;
         pat_env = env }
   | Ppat_constant cst ->
-      { pat_desc = Tpat_constant cst;
+      rp {
+        pat_desc = Tpat_constant cst;
         pat_loc = sp.ppat_loc;
         pat_type = type_constant cst;
         pat_env = env }
   | Ppat_tuple spl ->
       let pl = List.map (type_pat env) spl in
-      { pat_desc = Tpat_tuple pl;
+      rp {
+        pat_desc = Tpat_tuple pl;
         pat_loc = sp.ppat_loc;
         pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
         pat_env = env }
@@ -333,7 +380,8 @@ let rec type_pat env sp =
       let args = List.map (type_pat env) sargs in
       let (ty_args, ty_res) = instance_constructor constr in
       List.iter2 (unify_pat env) args ty_args;
-      { pat_desc = Tpat_construct(constr, args);
+      rp {
+        pat_desc = Tpat_construct(constr, args);
         pat_loc = sp.ppat_loc;
         pat_type = ty_res;
         pat_env = env }
@@ -347,7 +395,8 @@ let rec type_pat env sp =
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
-      { pat_desc = Tpat_variant(l, arg, row);
+      rp {
+        pat_desc = Tpat_variant(l, arg, row);
         pat_loc = sp.ppat_loc;
         pat_type = newty (Tvariant row);
         pat_env = env }
@@ -376,7 +425,8 @@ let rec type_pat env sp =
         unify_pat env arg ty_arg;
         (label, arg)
       in
-      { pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
+      rp {
+        pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
         pat_loc = sp.ppat_loc;
         pat_type = ty;
         pat_env = env }
@@ -384,7 +434,8 @@ let rec type_pat env sp =
       let pl = List.map (type_pat env) spl in
       let ty_elt = newvar() in
       List.iter (fun p -> unify_pat env p ty_elt) pl;
-      { pat_desc = Tpat_array pl;
+      rp {
+        pat_desc = Tpat_array pl;
         pat_loc = sp.ppat_loc;
         pat_type = instance (Predef.type_array ty_elt);
         pat_env = env }
@@ -399,7 +450,8 @@ let rec type_pat env sp =
       let alpha_env =
         enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
       pattern_variables := p1_variables ;
-      { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
+      rp {
+        pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
         pat_loc = sp.ppat_loc;
         pat_type = p1.pat_type;
         pat_env = env }
@@ -648,7 +700,7 @@ let type_format loc fmt =
     and scan_conversion i j =
       if j >= len then incomplete i else
       match fmt.[j] with
-      | '%' -> scan_format (j + 1)
+      | '%' | '!' -> scan_format (j + 1)
       | 's' | 'S' | '[' -> conversion j Predef.type_string
       | 'c' | 'C' -> conversion j Predef.type_char
       | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
@@ -656,10 +708,15 @@ let type_format loc fmt =
       | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
       | 'B' -> conversion j Predef.type_bool
       | 'a' ->
-          let ty_arg = newvar() in
+          let ty_arg = newvar () in
           let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in 
           let ty_aresult, ty_result = conversion j ty_arg in
           ty_aresult, ty_arrow ty_a ty_result
+      | '$' ->
+          let ty_arg = Predef.type_string in
+          let ty_f = ty_arrow Predef.type_string Predef.type_string in 
+          let ty_aresult, ty_result = conversion j ty_arg in
+          ty_aresult, ty_arrow ty_f ty_result
       | 'r' ->
           let ty_res = newvar() in
           let ty_r = ty_arrow ty_input ty_res in
@@ -780,7 +837,8 @@ let rec type_exp env sexp =
     Pexp_ident lid ->
       begin try
         let (path, desc) = Env.lookup_value lid env in
-        { exp_desc =
+        re {
+          exp_desc =
             begin match desc.val_kind with
               Val_ivar (_, cl_num) ->
                 let (self_path, _) =
@@ -804,14 +862,16 @@ let rec type_exp env sexp =
         raise(Error(sexp.pexp_loc, Unbound_value lid))
       end
   | Pexp_constant cst ->
-      { exp_desc = Texp_constant cst;
+      re {
+        exp_desc = Texp_constant cst;
         exp_loc = sexp.pexp_loc;
         exp_type = type_constant cst;
         exp_env = env }
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
       let body = type_exp new_env sbody in
-      { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
         exp_env = env }
@@ -826,7 +886,8 @@ let rec type_exp env sexp =
       end;
       let (args, ty_res) = type_application env funct sargs in
       let funct = {funct with exp_type = instance funct.exp_type} in
-      { exp_desc = Texp_apply(funct, args);
+      re {
+        exp_desc = Texp_apply(funct, args);
         exp_loc = sexp.pexp_loc;
         exp_type = ty_res;
         exp_env = env }
@@ -836,7 +897,8 @@ let rec type_exp env sexp =
       let cases, partial =
         type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
       in
-      { exp_desc = Texp_match(arg, cases, partial);
+      re {
+        exp_desc = Texp_match(arg, cases, partial);
         exp_loc = sexp.pexp_loc;
         exp_type = ty_res;
         exp_env = env }
@@ -854,13 +916,15 @@ let rec type_exp env sexp =
       let cases, _ =
         type_cases env (instance Predef.type_exn) body.exp_type None
           caselist in
-      { exp_desc = Texp_try(body, cases);
+      re {
+        exp_desc = Texp_try(body, cases);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_tuple sexpl ->
       let expl = List.map (type_exp env) sexpl in
-      { exp_desc = Texp_tuple expl;
+      re {
+        exp_desc = Texp_tuple expl;
         exp_loc = sexp.pexp_loc;
         exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
         exp_env = env }
@@ -869,7 +933,8 @@ let rec type_exp env sexp =
   | Pexp_variant(l, sarg) ->
       let arg = may_map (type_exp env) sarg in
       let arg_type = may_map (fun arg -> arg.exp_type) arg in
-      { exp_desc = Texp_variant(l, arg);
+      re {
+        exp_desc = Texp_variant(l, arg);
         exp_loc = sexp.pexp_loc;
         exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
                                   row_more = newvar ();
@@ -938,7 +1003,7 @@ let rec type_exp env sexp =
       if opt_sexp = None && List.length lid_sexp_list <> !num_fields then begin
         let present_indices =
           List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
-        let label_names = extract_label_names env ty in
+        let label_names = extract_label_names sexp env ty in
         let rec missing_labels n = function
             [] -> []
           | lbl :: rem ->
@@ -948,7 +1013,9 @@ let rec type_exp env sexp =
         let missing = missing_labels 0 label_names in
         raise(Error(sexp.pexp_loc, Label_missing missing))
       end;
-      { exp_desc = Texp_record(lbl_exp_list, opt_exp);
+      check_private_type sexp.pexp_loc env ty;
+      re {
+        exp_desc = Texp_record(lbl_exp_list, opt_exp);
         exp_loc = sexp.pexp_loc;
         exp_type = ty;
         exp_env = env }
@@ -961,7 +1028,8 @@ let rec type_exp env sexp =
           raise(Error(sexp.pexp_loc, Unbound_label lid)) in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env arg ty_res;
-      { exp_desc = Texp_field(arg, label);
+      re {
+        exp_desc = Texp_field(arg, label);
         exp_loc = sexp.pexp_loc;
         exp_type = ty_arg;
         exp_env = env }
@@ -982,14 +1050,17 @@ let rec type_exp env sexp =
       if vars <> [] && not (is_nonexpansive newval) then
         generalize_expansive env newval.exp_type;
       check_univars env "field value" newval label.lbl_arg vars;
-      { exp_desc = Texp_setfield(record, label, newval);
+      check_private_type_setfield lid sexp.pexp_loc env ty_res;
+      re {
+        exp_desc = Texp_setfield(record, label, newval);
         exp_loc = sexp.pexp_loc;
         exp_type = instance Predef.type_unit;
         exp_env = env }
   | Pexp_array(sargl) ->
       let ty = newvar() in
       let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
-      { exp_desc = Texp_array argl;
+      re {
+        exp_desc = Texp_array argl;
         exp_loc = sexp.pexp_loc;
         exp_type = instance (Predef.type_array ty);
         exp_env = env }
@@ -998,14 +1069,16 @@ let rec type_exp env sexp =
       begin match sifnot with
         None ->
           let ifso = type_expect env sifso (instance Predef.type_unit) in
-          { exp_desc = Texp_ifthenelse(cond, ifso, None);
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, None);
             exp_loc = sexp.pexp_loc;
             exp_type = instance Predef.type_unit;
             exp_env = env }
       | Some sifnot ->
           let ifso = type_exp env sifso in
           let ifnot = type_expect env sifnot ifso.exp_type in
-          { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+          re {
+            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
             exp_loc = sexp.pexp_loc;
             exp_type = ifso.exp_type;
             exp_env = env }
@@ -1013,14 +1086,16 @@ let rec type_exp env sexp =
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
       let exp2 = type_exp env sexp2 in
-      { exp_desc = Texp_sequence(exp1, exp2);
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = sexp.pexp_loc;
         exp_type = exp2.exp_type;
         exp_env = env }
   | Pexp_while(scond, sbody) ->
       let cond = type_expect env scond (instance Predef.type_bool) in
       let body = type_statement env sbody in
-      { exp_desc = Texp_while(cond, body);
+      re {
+        exp_desc = Texp_while(cond, body);
         exp_loc = sexp.pexp_loc;
         exp_type = instance Predef.type_unit;
         exp_env = env }
@@ -1031,7 +1106,8 @@ let rec type_exp env sexp =
         Env.enter_value param {val_type = instance Predef.type_int;
                                 val_kind = Val_reg} env in
       let body = type_statement new_env sbody in
-      { exp_desc = Texp_for(id, low, high, dir, body);
+      re {
+        exp_desc = Texp_for(id, low, high, dir, body);
         exp_loc = sexp.pexp_loc;
         exp_type = instance Predef.type_unit;
         exp_env = env }
@@ -1084,14 +1160,16 @@ let rec type_exp env sexp =
             end;
             (type_expect env sarg ty, ty')
       in
-      { exp_desc = arg.exp_desc;
+      re {
+        exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
         exp_type = ty';
         exp_env = env }
   | Pexp_when(scond, sbody) ->
       let cond = type_expect env scond (instance Predef.type_bool) in
       let body = type_exp env sbody in
-      { exp_desc = Texp_when(cond, body);
+      re {
+        exp_desc = Texp_when(cond, body);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
         exp_env = env }
@@ -1125,7 +1203,7 @@ let rec type_exp env sexp =
                   let (obj_ty, res_ty) = filter_arrow env method_type "" in
                   unify env obj_ty desc.val_type;
                   unify env res_ty (instance typ);
-                  (Texp_apply({exp_desc = Texp_ident(Path.Pident method_id,
+                  (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
                                                      {val_type = method_type;
                                                        val_kind = Val_reg});
                                 exp_loc = sexp.pexp_loc;
@@ -1167,7 +1245,8 @@ let rec type_exp env sexp =
           | _ ->
               assert false
         in
-          { exp_desc = exp;
+          re {
+            exp_desc = exp;
             exp_loc = sexp.pexp_loc;
             exp_type = typ;
             exp_env = env }
@@ -1183,7 +1262,8 @@ let rec type_exp env sexp =
           None ->
             raise(Error(sexp.pexp_loc, Virtual_class cl))
         | Some ty ->
-            { exp_desc = Texp_new (cl_path, cl_decl);
+            re {
+              exp_desc = Texp_new (cl_path, cl_decl);
               exp_loc = sexp.pexp_loc;
               exp_type = instance ty;
               exp_env = env }
@@ -1197,7 +1277,8 @@ let rec type_exp env sexp =
             let (path_self, _) =
               Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
             in
-            { exp_desc = Texp_setinstvar(path_self, path, newval);
+            re {
+              exp_desc = Texp_setinstvar(path_self, path, newval);
               exp_loc = sexp.pexp_loc;
               exp_type = instance Predef.type_unit;
               exp_env = env }
@@ -1238,7 +1319,8 @@ let rec type_exp env sexp =
             end
           in
           let modifs = List.map type_override lst in
-          { exp_desc = Texp_override(path_self, modifs);
+          re {
+            exp_desc = Texp_override(path_self, modifs);
             exp_loc = sexp.pexp_loc;
             exp_type = self_ty;
             exp_env = env }
@@ -1264,20 +1346,21 @@ let rec type_exp env sexp =
       with Unify _ ->
         raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
       end;
-      { exp_desc = Texp_letmodule(id, modl, body);
+      re {
+        exp_desc = Texp_letmodule(id, modl, body);
         exp_loc = sexp.pexp_loc;
         exp_type = ty;
         exp_env = env }
   | Pexp_assert (e) ->
        let cond = type_expect env e (instance Predef.type_bool) in
-       {
+       re {
          exp_desc = Texp_assert (cond);
          exp_loc = sexp.pexp_loc;
          exp_type = instance Predef.type_unit;
          exp_env = env;
        }
   | Pexp_assertfalse ->
-       {
+       re {
          exp_desc = Texp_assertfalse;
          exp_loc = sexp.pexp_loc;
          exp_type = newvar ();
@@ -1285,7 +1368,7 @@ let rec type_exp env sexp =
        }
   | Pexp_lazy (e) ->
        let arg = type_exp env e in
-       {
+       re {
          exp_desc = Texp_lazy arg;
          exp_loc = sexp.pexp_loc;
          exp_type = instance (Predef.type_lazy_t arg.exp_type);
@@ -1356,8 +1439,8 @@ and type_argument env sarg ty_expected' =
       if is_nonexpansive texp then func texp else
       (* let-expand to have side effects *)
       let let_pat, let_var = var_pair "let" texp.exp_type in
-      { texp with exp_type = ty_fun; exp_desc =
-        Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
+      re { texp with exp_type = ty_fun; exp_desc =
+           Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
       end
   | _ ->
       type_expect env sarg ty_expected
@@ -1500,7 +1583,7 @@ and type_application env funct sargs =
     | _ ->
         match sargs with
           (l, sarg0) :: _ when ignore_labels ->
-            raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)));
+            raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
         | _ ->
             type_unknown_args args omitted (instance ty_fun)
               (sargs @ more_sargs)
@@ -1549,12 +1632,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
     generalize_structure ty_res
   end;
   let texp =
-    { exp_desc = Texp_construct(constr, []);
+    re {
+      exp_desc = Texp_construct(constr, []);
       exp_loc = loc;
       exp_type = instance ty_res;
       exp_env = env } in
   unify_exp env texp ty_expected;
   let args = List.map2 (type_argument env) sargs ty_args in
+  check_private_type loc env ty_res;
   { texp with exp_desc = Texp_construct(constr, args) }
 
 (* Typing of an expression with an expected type.
@@ -1564,7 +1649,8 @@ and type_expect ?in_function env sexp ty_expected =
   match sexp.pexp_desc with
     Pexp_constant(Const_string s as cst) ->
       let exp =
-        { exp_desc = Texp_constant cst;
+        re {
+          exp_desc = Texp_constant cst;
           exp_loc = sexp.pexp_loc;
           exp_type =
             (* Terrible hack for format strings *)
@@ -1581,14 +1667,16 @@ and type_expect ?in_function env sexp ty_expected =
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
       let body = type_expect new_env sbody ty_expected in
-      { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+      re {
+        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
       let exp2 = type_expect env sexp2 ty_expected in
-      { exp_desc = Texp_sequence(exp1, exp2);
+      re {
+        exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = sexp.pexp_loc;
         exp_type = exp2.exp_type;
         exp_env = env }
@@ -1644,7 +1732,8 @@ and type_expect ?in_function env sexp ty_expected =
       if is_optional l && all_labeled ty_res then
         Location.prerr_warning (fst (List.hd cases)).pat_loc
           (Warnings.Other "This optional argument cannot be erased");
-      { exp_desc = Texp_function(cases, partial);
+      re {
+        exp_desc = Texp_function(cases, partial);
         exp_loc = sexp.pexp_loc;
         exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
         exp_env = env }
@@ -1664,7 +1753,7 @@ and type_expect ?in_function env sexp ty_expected =
           Tpoly (ty', []) ->
             if sty <> None then set_type ty;
             let exp = type_expect env sbody ty' in
-            { exp with exp_type = ty }
+            re { exp with exp_type = ty }
         | Tpoly (ty', tl) ->
             if sty <> None then set_type ty;
             (* One more level to generalize locally *)
@@ -1673,7 +1762,7 @@ and type_expect ?in_function env sexp ty_expected =
             let exp = type_expect env sbody ty'' in
             end_def ();
             check_univars env "method" exp ty_expected vars;
-            { exp with exp_type = ty }
+            re { exp with exp_type = ty }
         | _ -> assert false
       end
   | _ ->
@@ -1909,7 +1998,8 @@ let report_error ppf = function
   | Apply_non_function typ ->
       begin match (repr typ).desc with
         Tarrow _ ->
-          fprintf ppf "This function is applied to too many arguments"
+          fprintf ppf "This function is applied to too many arguments,@ ";
+          fprintf ppf "maybe you forgot a `;'"
       | _ ->
           fprintf ppf
             "This expression is not a function, it cannot be applied"
@@ -1947,7 +2037,7 @@ let report_error ppf = function
       fprintf ppf "Unbound class %a" longident cl
   | Virtual_class cl ->
       fprintf ppf "One cannot create instances of the virtual class %a"
-      longident cl
+        longident cl
   | Unbound_instance_variable v ->
       fprintf ppf "Unbound instance variable %s" v
   | Instance_variable_not_mutable v ->
@@ -2000,6 +2090,11 @@ let report_error ppf = function
         "The instance variable %a@ \
          cannot be accessed from the definition of another instance variable"
         longident lid
+  | Private_type ty ->
+      fprintf ppf "One cannot create values of the private type %s" ty
+  | Private_type_setfield (lid, ty) ->
+      fprintf ppf "Cannot assign field %a of the private type %s"
+        longident lid ty
   | Not_a_variant_type lid ->
       fprintf ppf "The type %a@ is not a variant type" longident lid
   | Incoherent_label_order ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index c4112183af..4bd6f19456 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -79,6 +79,8 @@ type error =
   | Undefined_inherited_method of string
   | Unbound_class of Longident.t
   | Virtual_class of Longident.t
+  | Private_type of string
+  | Private_type_setfield of Longident.t * string
   | Unbound_instance_variable of string
   | Instance_variable_not_mutable of string
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index f00c18f3a6..6c6fa2dc99 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -89,7 +89,7 @@ let transl_declaration env (name, sdecl) id =
   reset_type_variables();
   Ctype.begin_def ();
   let params =
-    try List.map (enter_type_variable true) sdecl.ptype_params
+    try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
     with Already_bound ->
       raise(Error(sdecl.ptype_loc, Repeated_parameter))
   in
@@ -103,7 +103,7 @@ let transl_declaration env (name, sdecl) id =
     { type_params = params;
       type_arity = List.length params;
       type_kind =
-        begin match sdecl.ptype_kind with
+        begin let rec get_tkind = function
           Ptype_abstract ->
             Type_abstract
         | Ptype_variant cstrs ->
@@ -140,7 +140,9 @@ let transl_declaration env (name, sdecl) id =
               then Record_float
               else Record_regular in
             Type_record(lbls', rep)
-        end;
+        | Ptype_private kind -> Type_private (get_tkind kind) in
+        get_tkind sdecl.ptype_kind
+      end;
       type_manifest =
         begin match sdecl.ptype_manifest with
           None -> None
@@ -167,16 +169,18 @@ let transl_declaration env (name, sdecl) id =
 
 let generalize_decl decl =
   List.iter Ctype.generalize decl.type_params;
-  begin match decl.type_kind with
-    Type_abstract ->
+  let rec gen = function
+  | Type_abstract ->
       ()
   | Type_variant v ->
       List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
   | Type_record(r, rep) ->
       List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
-  end;
+  | Type_private tkind ->
+      gen tkind in
+  gen decl.type_kind;
   begin match decl.type_manifest with
-    None    -> ()
+  | None    -> ()
   | Some ty -> Ctype.generalize ty
   end
 
@@ -189,7 +193,7 @@ module TypeSet =
       let compare t1 t2 = t1.id - t2.id
     end)
 
-let rec check_constraints_rec env loc visited ty =
+let rec check_constraints_rec env newenv loc visited ty =
   let ty = Ctype.repr ty in
   if TypeSet.mem ty !visited then () else begin
   visited := TypeSet.add ty !visited;
@@ -198,7 +202,7 @@ let rec check_constraints_rec env loc visited ty =
       Ctype.begin_def ();
       let args' = List.map (fun _ -> Ctype.newvar ()) args in
       let ty' = Ctype.newconstr path args' in
-      begin try Ctype.enforce_constraints env ty'
+      begin try Ctype.enforce_constraints newenv ty'
       with Ctype.Unify _ -> assert false
       | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
       end;
@@ -206,33 +210,40 @@ let rec check_constraints_rec env loc visited ty =
       Ctype.generalize ty';
       if not (List.for_all2 (Ctype.moregeneral env false) args' args) then
         raise (Error(loc, Constraint_failed (ty, ty')));
-      List.iter (check_constraints_rec env loc visited) args
+      List.iter (check_constraints_rec env newenv loc visited) args
   | Tpoly (ty, tl) ->
       let _, ty = Ctype.instance_poly false tl ty in
-      check_constraints_rec env loc visited ty
+      check_constraints_rec env newenv loc visited ty
   | _ ->
-      Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+      Btype.iter_type_expr (check_constraints_rec env newenv loc visited) ty
   end
 
-let check_constraints env (_, sdecl) (_, decl) =
+let check_constraints env newenv (_, sdecl) (_, decl) =
   let visited = ref TypeSet.empty in
-  begin match decl.type_kind with
+  let rec check = function
   | Type_abstract -> ()
   | Type_variant l ->
-      let pl =
-        match sdecl.ptype_kind with Ptype_variant pl -> pl | _ -> assert false
+      let rec find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_private tkind -> find_pl tkind
+        | Ptype_record _ | Ptype_abstract -> assert false
       in
+      let pl = find_pl sdecl.ptype_kind in
       List.iter
         (fun (name, tyl) ->
           let styl = try List.assoc name pl with Not_found -> assert false in
           List.iter2
-            (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty)
+            (fun sty ty ->
+              check_constraints_rec env newenv sty.ptyp_loc visited ty)
             styl tyl)
         l
   | Type_record (l, _) ->
-      let pl =
-        match sdecl.ptype_kind with Ptype_record pl -> pl | _ -> assert false
+      let rec find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_private tkind -> find_pl tkind
+        | Ptype_variant _ | Ptype_abstract -> assert false
       in
+      let pl = find_pl sdecl.ptype_kind in
       let rec get_loc name = function
           [] -> assert false
         | (name', _, sty) :: tl ->
@@ -240,16 +251,17 @@ let check_constraints env (_, sdecl) (_, decl) =
       in
       List.iter
         (fun (name, _, ty) ->
-          check_constraints_rec env (get_loc name pl) visited ty)
+          check_constraints_rec env newenv (get_loc name pl) visited ty)
         l
-  end;
+  | Type_private tkind -> check tkind in
+  check decl.type_kind;
   begin match decl.type_manifest with
   | None -> ()
   | Some ty ->
       let sty =
         match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
       in
-      check_constraints_rec env sty.ptyp_loc visited ty
+      check_constraints_rec env newenv sty.ptyp_loc visited ty
   end
 
 (*
@@ -297,8 +309,9 @@ let check_recursive_abbrev env (name, sdecl) (id, decl) =
 let rec check_expansion_rec env id args loc id_check_list visited ty =
   let ty = Ctype.repr ty in
   if List.memq ty visited then () else
-  let visited = ty :: visited in
-  begin match ty.desc with
+  let check_rec =
+    check_expansion_rec env id args loc id_check_list (ty :: visited) in
+  match ty.desc with
   | Tconstr(Path.Pident id' as path, args', _) ->
       if Ident.same id id' then begin
         if not (Ctype.equal env false args args') then
@@ -315,14 +328,16 @@ let rec check_expansion_rec env id args loc id_check_list visited ty =
             try List.iter2 (Ctype.unify env) params args'
             with Ctype.Unify _ -> assert false
           end;
-          check_expansion_rec env id args loc id_check_list visited body
+          check_rec body
         end
       with Not_found -> ()
-      end
-  | _ -> ()
-  end;
-  Btype.iter_type_expr
-    (check_expansion_rec env id args loc id_check_list visited) ty
+      end;
+      List.iter check_rec args'
+  | Tpoly (ty, tl) ->
+      let _, ty = Ctype.instance_poly false tl ty in
+      check_rec ty
+  | _ ->
+      Btype.iter_type_expr check_rec ty
 
 let check_expansion env id_loc_list (id, decl) =
   if decl.type_params = [] then () else
@@ -405,7 +420,7 @@ let compute_variance_decl env decl (required, loc) =
   else
   let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false))
       decl.type_params in
-  begin match decl.type_kind with
+  let rec variance_tkind = function
     Type_abstract ->
       begin match decl.type_manifest with
         None -> assert false
@@ -419,7 +434,8 @@ let compute_variance_decl env decl (required, loc) =
       List.iter
         (fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
         ftl
-  end;
+  | Type_private tkind -> variance_tkind tkind in
+  variance_tkind decl.type_kind;
   List.map2
     (fun (_, co, cn) (c, n) ->
       if c && !cn || n && !co then raise (Error(loc, Bad_variance));
@@ -499,7 +515,7 @@ let transl_type_decl env name_sdecl_list =
   (* Check re-exportation *)
   List.iter2 (check_abbrev newenv) name_sdecl_list decls;
   (* Check that constraints are enforced *)
-  List.iter2 (check_constraints newenv) name_sdecl_list decls;
+  List.iter2 (check_constraints temp_env newenv) name_sdecl_list decls;
   (* Check that abbreviations have same parameters *)
   let id_loc_list =
     List.map2
@@ -566,7 +582,7 @@ let transl_with_constraint env sdecl =
   Ctype.begin_def();
   let params =
     try
-      List.map (enter_type_variable true) sdecl.ptype_params
+      List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
     with Already_bound ->
       raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
   List.iter
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 89963b0d74..503b497853 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -59,6 +59,11 @@ let type_module_path env loc lid =
   with Not_found ->
     raise(Error(loc, Unbound_module lid))
 
+(* Record a module type *)
+let rm node =
+  Stypes.record (Stypes.Ti_mod node);
+  node
+
 (* Merge one "with" constraint in a signature *)
 
 let merge_constraint initial_env loc sg lid constr =
@@ -281,24 +286,24 @@ let rec type_module env smod =
   match smod.pmod_desc with
     Pmod_ident lid ->
       let (path, mty) = type_module_path env smod.pmod_loc lid in
-      { mod_desc = Tmod_ident path;
-        mod_type = Mtype.strengthen env mty path;
-        mod_env = env;
-        mod_loc = smod.pmod_loc }
+      rm { mod_desc = Tmod_ident path;
+           mod_type = Mtype.strengthen env mty path;
+           mod_env = env;
+           mod_loc = smod.pmod_loc }
   | Pmod_structure sstr ->
       let (str, sg, finalenv) = type_structure env sstr in
-      { mod_desc = Tmod_structure str;
-        mod_type = Tmty_signature sg;
-        mod_env = env;
-        mod_loc = smod.pmod_loc }
+      rm { mod_desc = Tmod_structure str;
+           mod_type = Tmty_signature sg;
+           mod_env = env;
+           mod_loc = smod.pmod_loc }
   | Pmod_functor(name, smty, sbody) ->
       let mty = transl_modtype env smty in
       let (id, newenv) = Env.enter_module name mty env in
       let body = type_module newenv sbody in
-      { mod_desc = Tmod_functor(id, mty, body);
-        mod_type = Tmty_functor(id, mty, body.mod_type);
-        mod_env = env;
-        mod_loc = smod.pmod_loc }
+      rm { mod_desc = Tmod_functor(id, mty, body);
+           mod_type = Tmty_functor(id, mty, body.mod_type);
+           mod_env = env;
+           mod_loc = smod.pmod_loc }
   | Pmod_apply(sfunct, sarg) ->
       let funct = type_module env sfunct in
       let arg = type_module env sarg in
@@ -321,10 +326,10 @@ let rec type_module env smod =
               with Not_found ->
                 raise(Error(smod.pmod_loc,
                             Cannot_eliminate_dependency mty_functor)) in
-          { mod_desc = Tmod_apply(funct, arg, coercion);
-            mod_type = mty_appl;
-            mod_env = env;
-            mod_loc = smod.pmod_loc }
+          rm { mod_desc = Tmod_apply(funct, arg, coercion);
+               mod_type = mty_appl;
+               mod_env = env;
+               mod_loc = smod.pmod_loc }
       | _ ->
           raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
       end        
@@ -336,10 +341,10 @@ let rec type_module env smod =
           Includemod.modtypes env arg.mod_type mty
         with Includemod.Error msg ->
           raise(Error(sarg.pmod_loc, Not_included msg)) in
-      { mod_desc = Tmod_constraint(arg, mty, coercion);
-        mod_type = mty;
-        mod_env = env;
-        mod_loc = smod.pmod_loc }
+      rm { mod_desc = Tmod_constraint(arg, mty, coercion);
+           mod_type = mty;
+           mod_env = env;
+           mod_loc = smod.pmod_loc }
 
 and type_structure env sstr =
   let type_names = ref StringSet.empty
@@ -488,30 +493,6 @@ and normalize_signature_item env = function
   | Tsig_module(id, mty) -> normalize_modtype env mty
   | _ -> ()
 
-(* Typecheck an implementation file *)
-
-let type_implementation sourcefile prefixname modulename initial_env ast =
-  Typecore.reset_delayed_checks ();
-  let (str, sg, finalenv) = type_structure initial_env ast in
-  Typecore.force_delayed_checks ();
-  if !Clflags.print_types then
-    fprintf std_formatter "%a@." Printtyp.signature sg;
-  let coercion =
-    if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
-      let intf_file =
-        try find_in_path !Config.load_path (prefixname ^ ".cmi")
-        with Not_found -> prefixname ^ ".cmi" in
-      let dclsig = Env.read_signature modulename intf_file in
-      Includemod.compunit sourcefile sg intf_file dclsig
-    end else begin
-      check_nongen_schemes finalenv str;
-      normalize_signature finalenv sg;
-      if not !Clflags.dont_write_files then
-        Env.save_signature sg modulename (prefixname ^ ".cmi");
-      Tcoerce_none
-    end in
-  (str, coercion)
-
 (* Simplify multiple specifications of a value or an exception in a signature.
    (Other signature components, e.g. types, modules, etc, are checked for
    name uniqueness.)  If multiple specifications with the same name,
@@ -536,11 +517,41 @@ and simplify_signature sg =
       simplif val_names (StringSet.add name exn_names)
               (if StringSet.mem name exn_names then res else component :: res)
               sg
+  | Tsig_module(id, mty) :: sg ->
+      simplif val_names exn_names
+              (Tsig_module(id, simplify_modtype mty) :: res) sg
   | component :: sg ->
       simplif val_names exn_names (component :: res) sg
   in
     simplif StringSet.empty StringSet.empty [] (List.rev sg)
 
+(* Typecheck an implementation file *)
+
+let type_implementation sourcefile prefixname modulename initial_env ast =
+  Typecore.reset_delayed_checks ();
+  let (str, sg, finalenv) =
+    Misc.try_finally (fun () -> type_structure initial_env ast)
+                     (fun () -> Stypes.dump (prefixname ^ ".types"))
+  in
+  Typecore.force_delayed_checks ();
+  if !Clflags.print_types then
+    fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg);
+  let coercion =
+    if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
+      let intf_file =
+        try find_in_path !Config.load_path (prefixname ^ ".cmi")
+        with Not_found -> prefixname ^ ".cmi" in
+      let dclsig = Env.read_signature modulename intf_file in
+      Includemod.compunit sourcefile sg intf_file dclsig
+    end else begin
+      check_nongen_schemes finalenv str;
+      normalize_signature finalenv sg;
+      if not !Clflags.dont_write_files then
+        Env.save_signature sg modulename (prefixname ^ ".cmi");
+      Tcoerce_none
+    end in
+  (str, coercion)
+
 (* "Packaging" of several compilation units into one unit
    having them as sub-modules.  *)
 
@@ -564,14 +575,23 @@ let package_units objfiles cmifile modulename =
       objfiles in
   (* Compute signature of packaged unit *)
   let sg = package_signatures Subst.identity units in
-  (* Determine imports *)
-  let unit_names = List.map fst units in
-  let imports =
-    List.filter
-      (fun (name, crc) -> not (List.mem name unit_names))
-      (Env.imported_units()) in
-  (* Write packaged signature *)
-  Env.save_signature_with_imports sg modulename cmifile imports
+  (* See if explicit interface is provided *)
+  let mlifile =
+    chop_extension_if_any cmifile ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    let dclsig = Env.read_signature modulename cmifile in
+    Includemod.compunit "(obtained by packing)" sg mlifile dclsig 
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, crc) -> not (List.mem name unit_names))
+        (Env.imported_units()) in
+    (* Write packaged signature *)
+    Env.save_signature_with_imports sg modulename cmifile imports;
+    Tcoerce_none
+  end
 
 (* Error report *)
 
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 7017dcf0de..63f1f6614c 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -32,7 +32,7 @@ val check_nongen_schemes:
 val simplify_signature: signature -> signature
 
 val package_units:
-        string list -> string -> string -> unit
+        string list -> string -> string -> Typedtree.module_coercion
 
 type error =
     Unbound_module of Longident.t
diff --git a/typing/types.ml b/typing/types.ml
index 2c3b5b6ebb..ed6e5bc02d 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -142,6 +142,7 @@ and type_kind =
   | Type_variant of (string * type_expr list) list
   | Type_record of (string * mutable_flag * type_expr) list
                  * record_representation
+  | Type_private of type_kind
 
 type exception_declaration = type_expr list
 
diff --git a/typing/types.mli b/typing/types.mli
index 8ed6e6a844..3a26fd3791 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -143,6 +143,7 @@ and type_kind =
   | Type_variant of (string * type_expr list) list
   | Type_record of (string * mutable_flag * type_expr) list
                  * record_representation
+  | Type_private of type_kind
 
 type exception_declaration = type_expr list
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 5da55d93eb..7b57260f75 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -39,6 +39,7 @@ type error =
   | Variant_tags of string * string
   | No_row_variable of string
   | Bad_alias of string
+  | Invalid_variable_name of string
 
 exception Error of Location.t * error
 
@@ -49,11 +50,16 @@ type variable_context = int * (string, type_expr) Tbl.t
 let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
 let univars        = ref ([] : (string * (type_expr * type_expr ref)) list)
 let pre_univars    = ref ([] : type_expr list)
+let local_aliases  = ref ([] : string list)
 
 let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
 let bindings       = ref ([] : (Location.t * type_expr * type_expr) list)
         (* These two variables are used for the "delayed" policy. *)
 
+let reset_pre_univars () =
+  pre_univars := [];
+  local_aliases := []
+
 let reset_type_variables () =
   reset_global_level ();
   type_variables := Tbl.empty
@@ -65,8 +71,10 @@ let widen (gl, tv) =
   restore_global_level gl;
   type_variables := tv
 
-let enter_type_variable strict name =
+let enter_type_variable strict loc name =
   try
+    if name <> "" && name.[0] = '_' then
+      raise (Error (loc, Invalid_variable_name ("'" ^ name)));
     let v = Tbl.find name !type_variables in
     if strict then raise Already_bound;
     v
@@ -105,6 +113,8 @@ let rec transl_type env policy rowvar styp =
     Ptyp_any ->
       if policy = Univars then new_pre_univar () else newvar ()
   | Ptyp_var name ->
+      if name <> "" && name.[0] = '_' then
+        raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
       begin try
         instance (fst (List.assoc name !univars))
       with Not_found ->
@@ -129,6 +139,7 @@ let rec transl_type env policy rowvar styp =
             with Not_found ->
               let v = new_pre_univar () in
               type_variables := Tbl.add name v !type_variables;
+              local_aliases := name :: !local_aliases;
               v
             end
         | Delayed ->
@@ -163,16 +174,22 @@ let rec transl_type env policy rowvar styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy None) stl in
-      let params = List.map (fun _ -> Ctype.newvar ()) args in
+      let params = Ctype.instance_list decl.type_params in
       let cstr = newty (Tconstr(path, params, ref Mnil)) in
       begin try
         Ctype.enforce_constraints env cstr
       with Unify trace ->
         raise (Error(styp.ptyp_loc, Type_mismatch trace))
       end;
+      let unify_param =
+        match decl.type_manifest with
+          None -> unify_var
+        | Some ty ->
+            if (repr ty).level = Btype.generic_level then unify_var else unify
+      in
       List.iter2
         (fun (sty, ty) ty' ->
-           try unify_var env ty' ty with Unify trace ->
+           try unify_param env ty' ty with Unify trace ->
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       cstr
@@ -225,8 +242,8 @@ let rec transl_type env policy rowvar styp =
       in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
-        (fun (sty, ty') ty ->
-           try unify_var env ty ty' with Unify trace ->
+        (fun (sty, ty) ty' ->
+           try unify_var env ty' ty with Unify trace ->
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       begin match ty.desc with
@@ -315,6 +332,7 @@ let rec transl_type env policy rowvar styp =
           begin_def ();
           let t = newvar () in
           type_variables := Tbl.add alias t !type_variables;
+          if policy = Univars then local_aliases := alias :: !local_aliases;
           if policy = Delayed then
             used_variables := Tbl.add alias t !used_variables;
           let ty = transl_type env policy None st in
@@ -323,7 +341,8 @@ let rec transl_type env policy rowvar styp =
             raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
           end;
           end_def ();
-          generalize_global t;
+          if policy = Univars then generalize_structure t
+          else generalize_global t;
           instance t
       end
   | Ptyp_variant(fields, closed, present) ->
@@ -472,7 +491,7 @@ let transl_simple_type env fixed styp =
 
 let transl_simple_type_univars env styp =
   univars := [];
-  pre_univars := [];
+  reset_pre_univars ();
   begin_def ();
   let typ = transl_type env Univars None styp in
   end_def ();
@@ -481,17 +500,12 @@ let transl_simple_type_univars env styp =
     List.fold_left
       (fun acc v ->
         let v = repr v in
-        if v.desc <> Tvar || v.level <> Btype.generic_level || List.memq v acc
-        then acc
+        if v.level <> Btype.generic_level || v.desc <> Tvar then acc
         else (v.desc <- Tunivar ; v :: acc))
       [] !pre_univars
   in
-  pre_univars := [];
-  Tbl.iter
-    (fun name ty ->
-      if List.exists (fun tu -> repr ty == repr tu) univs
-      then type_variables := Tbl.remove name !type_variables)
-    !type_variables;
+  type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
+  reset_pre_univars ();
   instance (Btype.newgenty (Tpoly (typ, univs)))
 
 let transl_simple_type_delayed env styp =
@@ -583,3 +597,5 @@ let report_error ppf = function
       fprintf ppf
         "The alias %s cannot be used here. It captures universal variables."
         name
+  | Invalid_variable_name name ->
+      fprintf ppf "The type variable name %s is not allowed in programs" name
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index bc36515228..300ebe5ace 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -27,7 +27,7 @@ val transl_simple_type_delayed:
 val transl_type_scheme:
         Env.t -> Parsetree.core_type -> Types.type_expr
 val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> string -> Types.type_expr
+val enter_type_variable: bool -> Location.t -> string -> Types.type_expr
 val type_variable: Location.t -> string -> Types.type_expr
 
 type variable_context
@@ -54,6 +54,7 @@ type error =
   | Variant_tags of string * string
   | No_row_variable of string
   | Bad_alias of string
+  | Invalid_variable_name of string
 
 exception Error of Location.t * error