3.09.1 updategcaml3090

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

12 files changed, 230 insertions, 174 deletions

diff --git a/typing/btype.ml b/typing/btype.ml
index 782b8121ba..a7c04d51fc 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -259,10 +259,9 @@ let rec copy_type_desc f = function
   | Tobject(ty, {contents = Some (p, tl)})
                         -> Tobject (f ty, ref (Some(p, List.map f tl)))
   | Tobject (ty, _)     -> Tobject (f ty, ref None)
-  | Tvariant row        ->
-      let row = row_repr row in
-      Tvariant (copy_row f true row false (f row.row_more))
-  | Tfield (p, k, ty1, ty2) -> Tfield (p, copy_kind k, f ty1, f ty2)
+  | Tvariant row        -> assert false (* too ambiguous *)
+  | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
+      Tfield (p, field_kind_repr k, f ty1, f ty2)
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
   | Tsubst ty           -> assert false
@@ -288,11 +287,22 @@ let saved_desc = ref []
 let save_desc ty desc = 
   saved_desc := (ty, desc)::!saved_desc
 
+let saved_kinds = ref [] (* duplicated kind variables *)
+let new_kinds = ref []   (* new kind variables *)
+let dup_kind r =
+  (match !r with None -> () | Some _ -> assert false);
+  if not (List.memq r !new_kinds) then begin
+    saved_kinds := r :: !saved_kinds;
+    let r' = ref None in
+    new_kinds := r' :: !new_kinds;
+    r := Some (Fvar r')
+  end
+
 (* Restored type descriptions. *)
 let cleanup_types () =
-  List.iter (fun (ty, desc) -> 
-    ty.desc <- desc) !saved_desc;
-  saved_desc := []
+  List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc;
+  List.iter (fun r -> r := None) !saved_kinds;
+  saved_desc := []; saved_kinds := []; new_kinds := []
 
 (* Mark a type. *)
 let rec mark_type ty =
diff --git a/typing/btype.mli b/typing/btype.mli
index 251bc1ef5a..6e1f2f215b 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -81,6 +81,8 @@ val copy_kind: field_kind -> field_kind
 
 val save_desc: type_expr -> type_desc -> unit
         (* Save a type description *)
+val dup_kind: field_kind option ref -> unit
+        (* Save a None field_kind, and make it point to a fresh Fvar *)
 val cleanup_types: unit -> unit
         (* Restore type descriptions *)
 
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 0615a6aea9..7a9fd76ac5 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -702,7 +702,9 @@ let limited_generalize ty0 ty =
       match ty.desc with
         Tvariant row ->
           let more = row_more row in
-          if more.level <> generic_level then generalize_parents more
+          let lv = more.level in
+          if (lv < lowest_level || lv > !current_level)
+          && lv <> generic_level then set_level more generic_level
       | _ -> ()
     end
   in
@@ -811,6 +813,14 @@ let rec copy ty =
               (* Return a new copy *)
               Tvariant (copy_row copy true row keep more')
           end
+      | Tfield (p, k, ty1, ty2) ->
+          begin match field_kind_repr k with
+            Fabsent  -> Tlink (copy ty2)
+          | Fpresent -> copy_type_desc copy desc
+          | Fvar r ->
+              dup_kind r;
+              copy_type_desc copy desc
+          end
       | _ -> copy_type_desc copy desc
       end;
     t
@@ -1211,8 +1221,9 @@ let expand_abbrev env ty =
   | _ ->
       assert false
 
-(* Fully expand the head of a type. Raise an exception if the type
-   cannot be expanded. *)
+(* Fully expand the head of a type.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Unify, if a recursion was hidden in the type. *)
 let rec try_expand_head env ty =
   let ty = repr ty in
   match ty.desc with
@@ -1234,7 +1245,11 @@ let expand_head_once env ty =
 
 (* Fully expand the head of a type. *)
 let rec expand_head env ty =
-  try try_expand_head env ty with Cannot_expand -> repr ty
+  let snap = Btype.snapshot () in
+  try try_expand_head env ty
+  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
+    Btype.backtrack snap;
+    repr ty
 
 (* Make sure that the type parameters of the type constructor [ty]
    respect the type constraints *)
@@ -1707,7 +1722,7 @@ and unify3 env t1 t1' t2 t2' =
           if not (closed_parameterized_type tl t2'') then
             link_type (repr t2) (repr t2')
       | _ ->
-          assert false
+          () (* t2 has already been expanded by update_level *)
     end
 
 (*
diff --git a/typing/kset.ml b/typing/kset.ml
index 7d093bcbc4..d3abdfe642 100644
--- a/typing/kset.ml
+++ b/typing/kset.ml
@@ -19,11 +19,13 @@ open Typedtree
 
 let debug = try ignore (Sys.getenv "GCAML_DEBUG_KSET"); true with _ -> false
 
-type elem = type_expr * value_description * instance_info ref 
+type elem = { kelem_type : type_expr;
+	      kelem_vdesc : value_description;
+	      kelem_instinfo : instance_info ref } 
 type t = elem list ref
 
 let empty () = ref []
-let add kset k = kset := k @ !kset
+let add kset k = kset := k :: !kset
 let get kset = !kset
 let create kset = ref kset
 
@@ -34,7 +36,7 @@ let print ppf kset =
       | [a] -> pr ppf a
       | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
   in
-  let print_kelem ppf (kt,kvdesc,_) = 
+  let print_kelem ppf { kelem_type= kt; kelem_vdesc= kvdesc } = 
     Format.fprintf ppf "@[<2>%a <@ %a@]" 
       Printtyp.type_scheme kt
       Printtyp.type_scheme kvdesc.val_type
@@ -42,79 +44,59 @@ let print ppf kset =
   Format.fprintf ppf "{ @[%a@] }" 
     (print_list print_kelem (fun ppf -> Format.fprintf ppf ",@ ")) !kset
 
+(* New type instantiation of [vdesc]
+   When an overloaded type is instantiated, we add its konstraint part
+   to the konstraint set [kset]. The gathered constraints in [kset] 
+   must be solved later. 
+*)
 let instance kset vdesc =
-  let t = Ctype.repr (vdesc.val_type) in
+  let t = Ctype.repr vdesc.val_type in
   (* Instantiations of Toverload and Tkonst are special! *)
   match t.desc with
   | Toverload {over_aunif= aunif; over_cases= cases} ->
       let t' = Ctype.instance aunif in 
       let inst_info = ref FA_none in
-      add kset [t', vdesc, inst_info];
+      add kset { kelem_type= t'; 
+		 kelem_vdesc= vdesc; 
+		 kelem_instinfo= inst_info };
       t', inst_info
   | Tkonst (konst, t') -> 
       let t'' = Ctype.instance t' in
       let inst_info = ref FA_none in
-      add kset [t'', vdesc, inst_info];
+      add kset { kelem_type= t'';
+		 kelem_vdesc= vdesc;
+		 kelem_instinfo= inst_info };
       t'', inst_info
-(* TOO ADVANCED
-      begin match 
-	Ctype.instance_list (t::(List.map (fun ke -> ke.ktype) konst)) 
-      with
-      | t'::ktypes' ->
-	  let konst' = 
-	    List.map2 (fun ke ktype' -> { ke with ktype= ktype' }) 
-	      konst ktypes'
-	  in
-Format.eprintf "kinst=%a@." Printtyp.type_scheme t;
-	  add kset konst'; 
-	  t'
-      | _ -> assert false
-      end
-*)
   | _ -> 
-	(* Even for non overloaded types, inst_info must be kept its track,
-	   for a derived generic defined by let rec; when the definition is
-	   type-checked, the derived generic is not yet polymorphic! *)
-	let t' = Ctype.instance t in
-	let inst_info = ref FA_none in
-	add kset [t', vdesc, inst_info];
-	t', inst_info
-(*
-	Ctype.instance t, ref FA_none
-*)
-
-(*
-let make_tkonst konsts typ =
-  let typ = Ctype.repr typ in
-  let konsts = List.filter filter_konst konsts in
-  if konsts <> [] then begin 
-    (* Type variable leaves inside genk are generalized, 
-       but parent nodes are not. Here, we fix them. *)
-(* WE CANNOT DO THIS HERE, SINCE GENERIC RECURSIVE LOOPS MAY BE LOST.
-    let t = Ctype.correct_levels t in
-*)
-    let t = Btype.newgenty (Tkonst (konsts, typ)) in
-Format.eprintf "make_tkonst=> %a@." Printtyp.type_scheme t;
-    Etype.normalize_type t;
-    t
-  end else typ
-*)
+      (* Even for non overloaded types, inst_info must be kept its track,
+	 for a derived generic defined by let rec; when the definition is
+	 type-checked, the derived generic is not yet polymorphic! *)
+      let t' = Ctype.instance t in
+      let inst_info = ref FA_none in
+      add kset { kelem_type= t';
+		 kelem_vdesc= vdesc;
+		 kelem_instinfo= inst_info };
+      t', inst_info
 
-let filter_konst (_,kvdesc,_) =
+let filter_konst { kelem_vdesc= kvdesc } =
   match (Ctype.repr kvdesc.val_type).desc with
   | Tkonst _ | Toverload _ -> true
   | _ -> false
 
 let resolve_kset env kset =
+  let size0 = List.length !kset in
   kset := List.filter filter_konst !kset;
+  let size1 = List.length !kset in
+  Format.eprintf "kset length= %d => %d@." size0 size1;
   if debug && !kset <> [] then Format.eprintf "@[<2>resolve:@, %a@]@." print kset;
   let flow_record = 
-    Gtype.resolve_konstraint env (List.map (fun (kt,kvdesc,_) ->
-      {ktype= kt; kdepend= Some kvdesc.val_type}) !kset)
+    Gtype.resolve_konstraint env (List.map (fun kelem ->
+      { ktype= kelem.kelem_type; 
+	kdepend= Some kelem.kelem_vdesc.val_type }) !kset)
   in
-  List.iter2 (fun (kt,kvdesc,instinforef) (kelem2,flow) ->
-    if kt != kelem2.ktype then assert false;
-    instinforef := FA_flow flow) !kset flow_record;
-if debug then if flow_record <> [] then 
-  Format.eprintf "FLOW: %a@." Gtype.print_flow_record flow_record
+  List.iter2 (fun kelem (kelem2,flow) ->
+    if kelem.kelem_type != kelem2.ktype then assert false;
+    kelem.kelem_instinfo := FA_flow flow) !kset flow_record;
+  if debug then if flow_record <> [] then 
+    Format.eprintf "FLOW: %a@." Gtype.print_flow_record flow_record
 
diff --git a/typing/kset.mli b/typing/kset.mli
index 004c207c37..c7b0ab47bd 100644
--- a/typing/kset.mli
+++ b/typing/kset.mli
@@ -16,17 +16,16 @@ open Types
 open Typedtree
 
 val debug : bool
-type elem = type_expr * value_description * instance_info ref 
+type elem = { kelem_type : type_expr;
+	      kelem_vdesc : value_description;
+	      kelem_instinfo : instance_info ref } 
 type t = elem list ref
 val empty : unit -> t
-val add : t -> elem list -> unit
+val add : t -> elem -> unit
 val get : t -> elem list
 val create : elem list -> t
 val print :
   Format.formatter -> t -> unit
 val instance :
-  t -> value_description -> type_expr * instance_info ref
-(*
-val make_tkonst : konstraint -> type_expr -> type_expr
-*)
+    t -> value_description -> type_expr * instance_info ref
 val resolve_kset : Env.t -> t ->  unit
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 54636de814..8fc48b397e 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -96,7 +96,7 @@ let rec safe_repr v = function
 
 let rec list_of_memo = function
     Mnil -> []
-  | Mcons (p, t1, t2, rem) -> (p,t1,t2) :: list_of_memo rem
+  | Mcons (p, t1, t2, rem) -> p :: list_of_memo rem
   | Mlink rem -> list_of_memo !rem
 
 let visited = ref []
@@ -119,9 +119,7 @@ and raw_type_desc ppf = function
   | Tconstr (p, tl, abbrev) ->
       fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
         raw_type_list tl
-        (raw_list (fun ppf (p,t1,t2) ->
-          fprintf ppf "@[%a,@ %a,@ %a@]" path p raw_type t1 raw_type t2))
-        (list_of_memo !abbrev)
+        (raw_list path) (list_of_memo !abbrev)
   | Tobject (t, nm) ->
       fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
         (fun ppf ->
@@ -653,6 +651,7 @@ let type_declaration id ppf decl =
 (* Print an exception declaration *)
 
 let tree_of_exception_declaration id decl =
+  reset_and_mark_loops_list decl; 
   let tyl = tree_of_typlist false decl in
   Osig_exception (Ident.name id, tyl)
 
@@ -858,8 +857,7 @@ and tree_of_signature = function
       Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
       tree_of_signature rem
   | Tsig_exception(id, decl) :: rem ->
-      Osig_exception (Ident.name id, tree_of_typlist false decl) ::
-      tree_of_signature rem
+      tree_of_exception_declaration id decl :: tree_of_signature rem
   | Tsig_module(id, mty, rs) :: rem ->
       Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
       tree_of_signature rem
diff --git a/typing/subst.ml b/typing/subst.ml
index f989fb523c..10cd15084c 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -132,16 +132,8 @@ let rec typexp s ty =
               | None ->
                   Tvariant row
           end
-      | Tfield(label, kind, t1, t2) ->
-          begin match field_kind_repr kind with
-            Fpresent ->
-              Tfield(label, Fpresent, typexp s t1, typexp s t2)
-          | Fabsent ->
-              Tlink (typexp s t2)
-          | Fvar _ (* {contents = None} *) as k ->
-              let k = if s.for_saving then Fvar(ref None) else k in
-              Tfield(label, k, typexp s t1, typexp s t2)
-          end
+      | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
+          Tlink (typexp s t2)
       | _ -> copy_type_desc (typexp s) desc
       end;
     ty'
diff --git a/typing/typecore.ml b/typing/typecore.ml
index dcf63530c8..7e1b1515db 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -894,7 +894,8 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
 let filter_generalized_konstraints env typ kset =
   let genk, monok = 
     let vars_of_typ = Etype.type_variables [typ] in
-    List.fold_left (fun (genk,monok) ((kt, kvdesc, _) as kselem) ->
+    List.fold_left (fun (genk,monok) ({Kset.kelem_type=kt; 
+				       Kset.kelem_vdesc= kvdesc} as kselem) ->
       let kelem = {ktype= kt; kdepend= Some kvdesc.val_type} in
       if List.exists (fun t -> 
 	t.level = generic_level && List.memq t vars_of_typ)
@@ -912,7 +913,26 @@ let fix_konstraints rec_flag env pat_exp_kset_list =
       filter_generalized_konstraints env pat.pat_type kset) pat_exp_kset_list
   in
 
-  let pat_vdescs_tbl, recursively_defined_vdescs, vdesc_genk_tbl =
+  let pat_vdescs_tbl, defined_vdescs, vdesc_genk_tbl =
+    List.fold_left2 (fun 
+        (pat_vdescs_tbl, defined_vdescs, vdesc_genk_tbl) 
+	(pat,(exp,kset)) (genk,monok) ->
+	  
+	  let vdescs =
+	    let idents = pat_bound_idents pat in
+	    List.map (fun ident -> 
+	      Env.find_value (Path.Pident ident) env) idents
+	  in
+	  (pat, vdescs) :: pat_vdescs_tbl,
+	  vdescs @ defined_vdescs,
+	  List.map (fun vdesc -> vdesc, genk) vdescs @ vdesc_genk_tbl)
+      ([], [], []) pat_exp_kset_list genk_monok_list
+  in
+  let recursively_defined_vdescs = 
+    if rec_flag = Recursive then defined_vdescs else []
+  in
+
+(* old code by iter2
     let pat_vdescs_tbl = ref [] in
     let recursively_defined_vdescs = ref [] in
     let vdesc_genk_tbl = ref [] in
@@ -928,10 +948,11 @@ let fix_konstraints rec_flag env pat_exp_kset_list =
       vdesc_genk_tbl := 
 	List.map (fun vdesc -> vdesc, genk) vdescs @ !vdesc_genk_tbl)
       pat_exp_kset_list genk_monok_list;
+
     !pat_vdescs_tbl,
     (if rec_flag = Recursive then !recursively_defined_vdescs else []),
     !vdesc_genk_tbl
-  in
+*)
   
   let generic_genk genk =
     let rec is_generic touched vdesc =
@@ -954,7 +975,8 @@ let fix_konstraints rec_flag env pat_exp_kset_list =
         else false
       end
     and generic_genk touched genk =
-      List.filter (fun (_,kvdesc,_) -> is_generic touched kvdesc) genk
+      List.filter (fun {Kset.kelem_vdesc= kvdesc} -> 
+	is_generic touched kvdesc) genk
     in
     generic_genk [] genk
   in
@@ -975,7 +997,9 @@ let fix_konstraints rec_flag env pat_exp_kset_list =
 	| Not_found -> assert false
       in
       let konsts =
-	List.map (fun (ktype, kvdesc, instoptref) ->
+	List.map (fun { Kset.kelem_type= ktype;
+			Kset.kelem_vdesc= kvdesc;
+			Kset.kelem_instinfo= instoptref } ->
 	  let ktype = Ctype.correct_levels ktype in 
 	  try
 	    let genk = List.assq kvdesc vdesc_genk_tbl in
@@ -1010,18 +1034,19 @@ Format.eprintf "SCM=%a@." Printtyp.type_scheme scm;
       (* reject let x,y = generic ... *)
       let rec check_simple_pattern p =
 	match p.pat_desc with
-	| Tpat_any -> []
-	| Tpat_var id -> [id]
-	| Tpat_alias (p, id) -> id :: check_simple_pattern p
+	| Tpat_any -> ()
+	| Tpat_var id -> ()
+	| Tpat_alias (p, id) -> check_simple_pattern p
 	| _ -> 
 	    raise (Error (exp.exp_loc, 
 			  Should_not_be_generic (scm,pat.pat_type)))
       in
-      ignore (check_simple_pattern pat);
+      check_simple_pattern pat;
 
-      List.iter (fun vdesc -> vdesc.val_type <- scm) (List.assq pat pat_vdescs_tbl);
+      List.iter (fun vdesc -> vdesc.val_type <- scm) 
+	(List.assq pat pat_vdescs_tbl);
       pat.pat_type <- scm;
-      List.iter2 (fun (_,_,instinforef) kelem ->
+      List.iter2 (fun { Kset.kelem_instinfo= instinforef } kelem ->
 	instinforef := FA_konst (pat, kelem, scm)) genk konsts;
 
     end) pat_exp_kset_list genk_monok_list;
@@ -1029,69 +1054,6 @@ Format.eprintf "SCM=%a@." Printtyp.type_scheme scm;
   (* return accumulated mono konstraints *)
   List.flatten (List.map snd genk_monok_list)
 
-(****
-  List.flatten (List.map (fun (pat, (exp, kset)) ->
-    let genk, monok = filter_generalized_konstraints env pat.pat_type kset in
-    let is_generic_def =
-      List.exists (fun (_,kvdesc,_) -> 
-	match (Ctype.repr kvdesc.val_type).desc with
-	| Tkonst _ | Toverload _ -> true | _ -> false) genk
-    in
-    if is_generic_def then begin
-      (* pattern must be enough simple, 
-	 since the definition is actually a function *)
-      (* reject let x,y = generic ... *)
-      let rec check_simple_pattern p =
-	match p.pat_desc with
-	| Tpat_any -> []
-	| Tpat_var id -> [id]
-	| Tpat_alias (p, id) -> id :: check_simple_pattern p
-	| _ -> 
-	    raise (Error (exp.exp_loc, 
-			  Should_not_be_generic (pat.pat_type)))
-      in
-      let defined_idents = check_simple_pattern pat in
-      let defined_vdescs = 
-	List.map (fun ident -> Env.find_value (Path.Pident ident) env)
-	  defined_idents
-      in
-      let genk = 
-	List.filter (fun (_,kvdesc,_) ->
-	  List.memq kvdesc defined_vdescs || 
-	  match (Ctype.repr kvdesc.val_type).desc with
-	  | Tkonst _ | Toverload _ -> true | _ -> false) genk
-      in
-      let dummy_var = Btype.newgenty Tvar in
-      (* making the scheme *)
-      let konsts =
-	List.map (fun (ktype, kvdesc, instoptref) ->
-	  if List.memq kvdesc defined_vdescs then
-	    {ktype= ktype; kdepend= Some dummy_var}
-	  else
-	    {ktype= ktype; kdepend= Some kvdesc.val_type}) genk
-      in
-      let scm = 
-	let scm = Btype.newgenty (Tkonst (konsts, pat.pat_type)) in
-	(* make a loop *)
-	let scm = Ctype.correct_levels scm in
-	dummy_var.desc <- Tlink scm;
-	scm
-      in
-      (* Type variable leaves inside genk are generalized, 
-	 but parent nodes are not. Here, we fix them. *)
-      (* FIXME: Is it really required? *)
-      Etype.normalize_type scm;
-(*
-Format.eprintf "SCM=%a@." Printtyp.type_scheme scm;
-*)
-      List.iter (fun vdesc -> vdesc.val_type <- scm) defined_vdescs;
-      pat.pat_type <- scm;
-      List.iter2 (fun (_,_,instinforef) kelem ->
-	instinforef := FA_konst (pat, kelem, scm)) genk konsts
-    end else ();
-    monok) pat_exp_kset_list )
-****)
-
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
@@ -1760,7 +1722,91 @@ let rec type_exp env kset sexp =
 
   | Pexp_poly _ ->
       assert false
+
+  | Pexp_regexp r -> 
+      let regexp = Regexp.from_string r in
+      let t = Regexp.type_regexp regexp in
+
+      let result_creation_code =
+	let pexp desc = { pexp_desc= desc; pexp_loc= Location.none }
+	and ppat desc = { ppat_desc= desc; ppat_loc= Location.none }
+	in
+	let ptyp = ppat (Ppat_var "_typ")
+	and pgroups = ppat (Ppat_var "_groups")
+	and etyp = pexp (Pexp_ident (Longident.Lident "_typ"))
+	and egroups = pexp (Pexp_ident (Longident.Lident "_groups"))
+	in
+        let self = "_self" in
+        let pself = ppat (Ppat_var self) in
+        let eself = pexp (Pexp_ident (Longident.Lident self)) in
+        let class_fields =
+  	let inher =
+  	  let super_id = 
+  	    Longident.Ldot (Longident.Lident "Regexp", "result")
+  	  in
+	  let super = { pcl_desc= Pcl_constr (super_id, []);
+			pcl_loc= Location.none } 
+	  in
+  	  Pcf_inher ( { pcl_desc= Pcl_apply (super, ["", etyp;
+						     "", egroups]);
+  			pcl_loc= Location.none }, None ) 
+  	in
+  	let methods =
+	  let polyexp e = pexp (Pexp_poly (e, None)) in
+	  let name_codes =
+	    let rec numbered = function
+	      | n when n > t.Regexp.num_of_groups -> []
+	      | n -> 
+		  ("_" ^ string_of_int n,
+  		   pexp (Pexp_apply (pexp (Pexp_send (eself, "_unsafe_group")),
+  				    ["", pexp (Pexp_constant (Const_int n))])))
+		  :: numbered (n+1)
+	    in
+	    let rec named = function
+	      | (s,p) :: ss -> 
+  		  (s,
+		   pexp (Pexp_apply (pexp (Pexp_send (eself, "_unsafe_group")),
+  				    ["", pexp (Pexp_constant (Const_int p))])))
+		  :: named ss
+	      | [] -> []
+	    in
+	    (* 0 always exists *)
+	    numbered 0 @ named t.Regexp.named_groups
+	  in
+  	  List.map (fun (n,code) -> 
+  	    Pcf_meth (n, Public, polyexp code, Location.none)) name_codes
+  	in
+  	inher :: methods
+        in
+	let o = pexp (Pexp_object (pself, class_fields)) in
+	pexp (Pexp_function ("", None, [ptyp, 
+          pexp(Pexp_function ("", None, [pgroups, o]))])) 
+      in
+      let code = type_exp env kset result_creation_code in
       
+      let ty_regexp, param =
+	let path, tdesc = 
+	  Env.lookup_type 
+	    (Longident.Ldot (Longident.Lident "Regexp", "t")) env in
+	let param =
+	  match Ctype.instance_list tdesc.type_params with
+	  | [p] -> p
+	  | _ -> assert false
+	in
+	Ctype.newty (Tconstr (path, [param], ref Mnil)), param
+      in
+
+      let ty = Ctype.newty (Tarrow ("", Ctype.newvar (),
+                 Ctype.newty (Tarrow ("", Ctype.newvar (), 				           param, Cunknown)), Cunknown))
+      in
+
+      unify env ty code.exp_type;
+
+      re {
+        exp_desc = Texp_regexp (r, regexp, t, code); 
+        exp_loc = sexp.pexp_loc;
+        exp_type = ty_regexp;
+        exp_env = env }
 
 and type_argument env kset sarg ty_expected' =
   (* ty_expected' may be generic *)
@@ -2325,6 +2371,8 @@ and type_let env kset rec_flag spat_sexp_list =
     (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
     pat_list exp_list;
   end_def();
+  (* JPF: konstraint resolution possibility here *)
+  (* generalization *)
   List.iter2
     (fun pat (exp, kset') ->
        if not (is_nonexpansive exp) then
@@ -2347,7 +2395,8 @@ if rec_flag = Recursive then
 
   (* fix konstraint info *)
   (* FIXME: for let generic, this is meaningless (really?) *)
-  Kset.add kset (fix_konstraints rec_flag new_env pat_exp_kset_list);
+  List.iter (Kset.add kset)
+    (fix_konstraints rec_flag new_env pat_exp_kset_list);
 
 (*
 if rec_flag = Recursive then
@@ -2420,11 +2469,13 @@ and type_generic_case env kset patopt styopt e =
 if Kset.get kset' <> [] then Format.eprintf "KSET: %a@." Kset.print kset';
 *)
   let genk, monok = filter_generalized_konstraints env exp.exp_type kset' in
-  let genk = List.filter (fun (_,kvdesc,_) ->
+  let genk = List.filter (fun { Kset.kelem_vdesc= kvdesc } ->
     match (Ctype.repr kvdesc.val_type).desc with
     | Tkonst _ | Toverload _ -> true | _ -> false) genk
   in
-  let konst = List.map (fun (ktype, kvdesc, instoptref) ->
+  let konst = List.map (fun { Kset.kelem_type= ktype;
+			      Kset.kelem_vdesc= kvdesc;
+			      Kset.kelem_instinfo= instoptref } ->
     {ktype=ktype; kdepend= Some kvdesc.val_type}) genk in
   let typ = 
     if konst <> [] then Btype.newgenty (Tkonst(konst, exp.exp_type)) 
@@ -2432,14 +2483,14 @@ if Kset.get kset' <> [] then Format.eprintf "KSET: %a@." Kset.print kset';
   in
   begin match patopt with
   | Some pat -> (* pat must be enough simple (by parser) *)
-      List.iter2 (fun (_,_,instinforef) kelem ->
+      List.iter2 (fun { Kset.kelem_instinfo= instinforef } kelem ->
 	instinforef := FA_overload (pat, kelem, typ)) genk konst
   | None -> ()
   end;
 (*
 if Kset.get kset' <> [] then Format.eprintf "ATTACH: %a@." Gdebug.print_type_scheme typ;
 *)
-  Kset.add kset monok;
+  List.iter (Kset.add kset) monok;
   typ, exp
 
 and type_approx env sexp =
@@ -2509,7 +2560,8 @@ let type_expression env kset sexp =
 		    pat_env= env } 
   in
   (* dummy_pat.pat_type will carry the konstraint-attached type. *)
-  Kset.add kset (fix_konstraints Default env [dummy_pat, (exp, kset')]);
+  List.iter (Kset.add kset)
+    (fix_konstraints Default env [dummy_pat, (exp, kset')]);
   exp.exp_type <- dummy_pat.pat_type;
 (*
 Format.eprintf "type_expression %a@." Gdebug.print_type_scheme exp.exp_type;
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index e5ca727dcb..9060ac0807 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -98,6 +98,7 @@ and expression_desc =
   | Texp_rtype of type_expr
   | Texp_typedecl of Path.t
   | Texp_generic of (type_expr * expression) list
+  | Texp_regexp of string * Regexp.token list * Regexp.typ * expression
 
 and meth =
     Tmeth_name of string
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 8f4e5b30f5..d2b5a5448c 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -97,6 +97,7 @@ and expression_desc =
   | Texp_rtype of type_expr
   | Texp_typedecl of Path.t
   | Texp_generic of (type_expr * expression) list
+  | Texp_regexp of string * Regexp.token list * Regexp.typ * expression
 
 and meth =
     Tmeth_name of string
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 29e4f686d8..45a94069ad 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -160,7 +160,7 @@ and expression ppf tbl e =
   | Pexp_for (id, e1, e2, _, e3) ->
       expression ppf tbl e1;
       expression ppf tbl e2;
-      let defined = ([ (id, e.pexp_loc, ref false) ], []) in
+      let defined = ([ (id, e.pexp_loc, ref true) ], []) in
       add_vars tbl defined;
       expression ppf tbl e3;
       check_rm_vars ppf tbl defined;
@@ -187,6 +187,7 @@ and expression ppf tbl e =
       (* FIXME *)
       Location.prerr_warning e.pexp_loc
 	(Warnings.Gcaml_related "Unused_var.expression: not yet implemented")
+  | Pexp_regexp _ -> ()
 
 and rtype ppf tbl t =
   match t.ptyp_desc with
@@ -276,9 +277,11 @@ and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
 and class_expr ppf tbl ce =
   match ce.pcl_desc with
   | Pcl_constr _ -> ()
-  | Pcl_structure cs -> class_structure ppf tbl cs
-  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce
-  | Pcl_apply (ce, _) -> class_expr ppf tbl ce
+  | Pcl_structure cs -> class_structure ppf tbl cs;
+  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
+  | Pcl_apply (ce, lel) ->
+      class_expr ppf tbl ce;
+      List.iter (fun (_, e) -> expression ppf tbl e) lel;
   | Pcl_let (recflag, pel, ce) ->
       let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
   | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
diff --git a/typing/unused_var.mli b/typing/unused_var.mli
index 14edcfddb5..be36fccadd 100644
--- a/typing/unused_var.mli
+++ b/typing/unused_var.mli
@@ -13,3 +13,4 @@
 (* $Id$ *)
 
 val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
+(* Warn on unused variables; return the second argument. *)