(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id: typecore.ml,v 1.49 2005/11/25 17:53:59 pasalic Exp $ *)

(* Typechecking for the core language *)

open Misc
open Asttypes
open Parsetree
open Types
open Typedtree
open Btype
open Ctype
open Format
open Printtyp
open Types  
let type_expr_to_string te =
  Printtyp.type_expr Format.str_formatter te;
  "<" ^ (flush_str_formatter ()) ^ ">"
let is_int_basic_type te = 
 let te_str = type_expr_to_string te in
  match te_str with
    "<int>" -> true
 | _ -> false
let is_basic_type te =
  let te_str = type_expr_to_string te in
  match te_str with
    "<int>" -> true
  | "<float>" -> true
  | "<bool>" -> true
  | "<char>" -> true
  | _ -> false
let is_array_type te =
  let te_str = type_expr_to_string te in
  match te_str with
    "<int array>" -> true
  | "<float array>" -> true
  | "<bool array>" -> true
  | "<char array>" -> true
  | "<int array array>" -> true
  | "<float array array>" -> true
  | "<bool array array>" -> true
  | "<char array array>" -> true
  | _ -> false
(* check function argument types *)
let rec isInFunSubsetTypeCheck_arg_type_top_helper te = 
 match te.desc with
 | Tlink t_e -> isInFunSubsetTypeCheck_arg_type_top_helper t_e
 (* one arg *)
 | Tconstr(path,_,_) -> 
     let b = (is_basic_type te || is_array_type te)  in 
       if b then b 
       else let errmes = "Argument not basic, " ^ 
			 "basic array or basic array array type" in
       Printf.printf "%s %s\n" errmes (type_expr_to_string te) ; b
	   (* several arg *)
 | Ttuple t_e ->
     let tr = ((List.exists is_basic_type t_e) || (List.exists is_array_type t_e)) in
       if tr then tr
       else let errmes = 
	 "Argument not basic, basic array or basic array array type" 
       in 
	 Printf.printf "%s \n" errmes; tr
 | _ -> Printf.printf "%s %s  \n" "Can't translate argument type " 
     (type_expr_to_string te);  false
(* check function return type *)
let rec isInFunSubsetTypeCheck_return_type_top_helper te =
  match te.desc with
    | Tlink t_e -> isInFunSubsetTypeCheck_return_type_top_helper t_e
    | Tconstr(path,_,_) ->  let b = is_basic_type te in 
        if b then b 
        else let _ = 0 in Printf.printf "%s %s\n" 
                            "Return not basic type" 
                            (type_expr_to_string te) ; b
    | _ -> Printf.printf "%s %s\n" "Can't translate function return type in " 
	(type_expr_to_string te) ; false
let rec isInFunSubsetTypeCheck_type_top_helper te =
  match te.desc with
 | Tlink t_e -> isInFunSubsetTypeCheck_type_top_helper t_e
 | Tarrow(l, arg_type, return_type, _) -> 
                           (isInFunSubsetTypeCheck_arg_type_top_helper arg_type &&
                           isInFunSubsetTypeCheck_return_type_top_helper return_type)
 | _ -> false
let rec isInFunSubsetTypeCheck_type te =
  match te.desc with 
 | Tlink t_e -> isInFunSubsetTypeCheck_type t_e
 | Tconstr(path,[t_e],_) -> isInFunSubsetTypeCheck_type_top_helper t_e
 | Tconstr(path,[_;t_e],_) ->  isInFunSubsetTypeCheck_type_top_helper t_e
 | _ -> Printf.printf "%s %s\n" "Internal: Could not proceed to check function " 
     (type_expr_to_string te) ; false
let rec isInSubsetTypeCheck_fun_or_base te v = 
  match te.desc with 
  | Tlink t -> isInSubsetTypeCheck_fun_or_base t v
  | Tarrow(_,_,_,_) -> isInFunSubsetTypeCheck_type v.val_type
  | _ -> 
      if (is_int_basic_type te) then true
      else 
        fatal_error ("Trx: Case: Identifier is not a function." ^ 
                     "In that case only (base) type <int code> is accepted, " ^ 
                     "but here it wasn't provided")
(* translation: types translation checker *)
let rec isInSubsetTypeCheck e = 
  match e.exp_desc with
      Texp_bracket d -> 
	if (isInFunSubsetTypeCheck_type e.exp_type || is_int_basic_type d.exp_type) 
        then true 
        else let t = false in Printf.printf 
				"Can't run sth that is not a function 
			          or is not of int type; you passed %s" 
				(type_expr_to_string d.exp_type); t
    | Texp_ident(_,v) -> 
	 let rec callApprTypeCheck te =  
	   (match te.desc with 
		Tlink te  -> callApprTypeCheck te
	      | Tconstr(_,[t],_) -> isInSubsetTypeCheck_fun_or_base t v
	      | Tconstr(_,[_;t],_) -> isInSubsetTypeCheck_fun_or_base t v 
	      | _ ->
		  fatal_error ("Trx: Non-code or bad identifier given to offshore")
	   )
	 in
	   callApprTypeCheck v.val_type

    | _ -> 
        Printf.printf "%s \n" (type_expr_to_string e.exp_type); 
	Printf.printf "%s \n" 
          "Attempt to translate non-code "; false

type error =
    Unbound_value of Longident.t
  | Unbound_constructor of Longident.t
  | Unbound_label of Longident.t
  | Constructor_arity_mismatch of Longident.t * int * int
  | Label_mismatch of Longident.t * (type_expr * type_expr) list
  | Pattern_type_clash of (type_expr * type_expr) list
  | Multiply_bound_variable
  | Orpat_vars of Ident.t
  | Expr_type_clash of (type_expr * type_expr) list
  | Apply_non_function of type_expr
  | Apply_wrong_label of label * type_expr
  | Label_multiply_defined of Longident.t
  | Label_missing of string list
  | Label_not_mutable of Longident.t
  | Incomplete_format of string
  | Bad_conversion of string * int * char
  | Undefined_method of type_expr * string
  | Undefined_inherited_method of string
  | Unbound_class of Longident.t
  | Virtual_class of Longident.t
  | Private_type of type_expr
  | Private_label of Longident.t * type_expr
  | Unbound_instance_variable of string
  | Instance_variable_not_mutable of string
  | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
  | Outside_class
  | Value_multiply_overridden of string
  | Coercion_failure of
      type_expr * type_expr * (type_expr * type_expr) list * bool
  | Too_many_arguments of bool * type_expr
  | Abstract_wrong_label of label * type_expr
  | Scoping_let_module of string * type_expr
  | Masked_instance_variable of Longident.t
  | Not_a_variant_type of Longident.t
  | Incoherent_label_order
  | Less_general of string * (type_expr * type_expr) list
  | Wrong_level of (type_expr list) * (type_expr list)    (* XXO begin  *)
  | Illegal_etag_program of Parsetree.expression        
  | Unbound_type_constructor	
  | Unmatched_type_expression
  | Illegal_etag_erasure
  | Ill_ident_for_type of Longident.t
  | Type_mismatch of type_expr
  | Not_constructed_type of type_expr
  | Run_occur_check of type_expr * type_expr
  | Run_alpha_not_generalizable of type_expr * type_expr  (* XXO end *)
  | Internal_error of string

exception Error of Location.t * error
exception Error_Translation_type_check_subset


(* Forward declaration, to be filled in by Typemod.type_module *)

let type_module =
  ref ((fun env md -> assert false) :
       Env.t -> Parsetree.module_expr -> Typedtree.module_expr)

(* Forward declaration, to be filled in by Typeclass.class_structure *)
let type_object =
  ref (fun env s -> assert false :
       Env.t -> Location.t -> Parsetree.class_structure ->
         class_structure * class_signature * string list)

(* From here ==================================  XXO *)
(* Run time/Static etag flag *)
let te_flag = ref false
let te_success = ref false
let set_TE_flag ()   = te_flag := true
let unset_TE_flag () = te_flag := false

(* get the tag from construct discription *)

let rec path_to_lid path =
  match path with
    Path.Pident i -> Longident.Lident (Ident.name i)
  | Path.Pdot (p,s,_) -> Longident.Ldot (path_to_lid p, s)
  | Path.Papply (p1,p2) ->
      Longident.Lapply(path_to_lid p1, path_to_lid p2)

let update_lid lid name loc=
  match lid with
    Longident.Lident _ -> Longident.Lident name
  | Longident.Ldot (p,_) -> Longident.Ldot (p,name)
  | _ -> raise(Error(loc, Ill_ident_for_type lid))

let get_type_descr ty tenv loc =
  let ty = repr (expand_head tenv ty) in
  match ty.desc with
  | Tconstr (path,_,_) -> Env.find_type path tenv
  | _ -> raise(Error(loc, Type_mismatch ty))

let get_type_path ty tenv loc =
  let ty = Ctype.repr (Ctype.expand_head tenv ty) in
  match ty.desc with
  | Tconstr (path,_,_) -> path
  | _ -> raise(Error(loc, Type_mismatch ty))

let get_constr_lid tag ty tenv loc = 
 match tag with
| Cstr_exception path -> path_to_lid path
| _ ->
  let name, _ =
    match get_type_descr ty tenv loc with
           | {type_kind=Type_variant (constr_list,pf)} ->
               Datarepr.find_constr_by_tag tag constr_list
           | _ -> raise(Error(loc, Not_constructed_type ty))
  and type_path = get_type_path ty tenv loc
       in update_lid (path_to_lid type_path) name loc   

(* To here ====================================  XXO *)

(*
  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
    Const_int _ -> instance Predef.type_int
  | 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 =
  newty (Tconstr(Predef.path_option,[ty], ref Mnil))

let option_none ty loc =
  let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
  { exp_desc = Texp_construct(cnone, [],Keep);
    exp_type = ty; exp_loc = loc; exp_env = Env.initial }

let option_some texp =
  let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in
  { exp_desc = Texp_construct(csome, [texp],Keep); exp_loc = texp.exp_loc;
    exp_type = type_option texp.exp_type; exp_env = texp.exp_env } 

let extract_option_type env ty =
  match expand_head env ty with {desc = Tconstr(path, [ty], _)}
    when Path.same path Predef.path_option -> ty
  | _ -> assert false

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
      | Type_record (fields, _, _) ->
          List.map (fun (name, _, _) -> name) fields
      | Type_abstract when td.type_manifest <> None ->
          extract_label_names sexp env (expand_head env ty)
      | _ -> assert false
      end
  | _ ->
      assert false

(* Typing of patterns *)

(* Creating new conjunctive types is not allowed when typing patterns *)
let unify_pat env pat expected_ty =
  try
    unify env pat.pat_type expected_ty
  with
    Unify trace ->
      raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
  | Tags(l1,l2) ->
      raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))

(* make all Reither present in open variants *)
let finalize_variant pat =
  match pat.pat_desc with
    Tpat_variant(tag, opat, row) ->
      let row = row_repr row in
      let field = row_field tag row in
      begin match field with
      | Rabsent -> assert false
      | Reither (true, [], _, e) when not row.row_closed ->
          set_row_field e (Rpresent None)
      | Reither (false, ty::tl, _, e) when not row.row_closed ->
          set_row_field e (Rpresent (Some ty));
          begin match opat with None -> assert false
          | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
          end
      | Reither (c, l, true, e) when not row.row_fixed ->
          set_row_field e (Reither (c, [], false, ref None))
      | _ -> ()
      end;
      (* Force check of well-formedness *)
      unify_pat pat.pat_env pat
        (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
                        row_bound=[]; row_fixed=false; row_name=None}));
  | _ -> ()

let rec iter_pattern f p =
  f p;
  iter_pattern_desc (iter_pattern f) p.pat_desc

let has_variants p =
  try
    iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ())
      p;
    false
  with Exit ->
    true


(* pattern environment *)
let pattern_variables = ref ([]: (Ident.t * type_expr) list)
let pattern_force = ref ([] : (unit -> unit) list)
let reset_pattern () =
  pattern_variables := [];
  pattern_force := []

let enter_variable loc name ty =
  if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
  then raise(Error(loc, Multiply_bound_variable));
  let id = Ident.create name in
  pattern_variables := (id, ty) :: !pattern_variables;
  id

let sort_pattern_variables vs =
  List.sort
    (fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
    vs

let enter_orpat_variables loc env  p1_vs p2_vs =
  (* unify_vars operate on sorted lists *)

  let p1_vs = sort_pattern_variables p1_vs
  and p2_vs = sort_pattern_variables p2_vs in

  let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
      | (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 ->
          if x1==x2 then
            unify_vars rem1 rem2
          else begin
            begin try
              unify env t1 t2
            with
            | Unify trace ->
                raise(Error(loc, Pattern_type_clash(trace)))
            end ;
          (x2,x1)::unify_vars rem1 rem2
          end
      | [],[] -> []
      | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
      | [],(x,_)::_  -> raise (Error (loc, Orpat_vars x))
      | (x,_)::_, (y,_)::_ ->
          let min_var =
            if Ident.name x < Ident.name y then x
            else y in
          raise (Error (loc, Orpat_vars min_var)) in
  unify_vars p1_vs p2_vs

let rec build_as_type env p =
  match p.pat_desc with
    Tpat_alias(p1, _) -> build_as_type env p1
  | Tpat_tuple pl ->
      let tyl = List.map (build_as_type env) pl in
      newty (Ttuple tyl)
  | Tpat_construct(cstr, pl) ->
      if cstr.cstr_private = Private then p.pat_type else
      let tyl = List.map (build_as_type env) pl in
      let ty_args, ty_res = instance_constructor cstr in
      List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
        (List.combine pl tyl) ty_args;
      ty_res
  | Tpat_variant(l, p', _) ->
      let ty = may_map (build_as_type env) p' in
      newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
                      row_bound=[]; row_name=None;
                      row_fixed=false; row_closed=false})
  | Tpat_record lpl ->
      let lbl = fst(List.hd lpl) in
      if lbl.lbl_private = Private then p.pat_type else
      let ty = newvar () in
      let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in
      let do_label lbl =
        let _, ty_arg, ty_res = instance_label false lbl in
        unify_pat env {p with pat_type = ty} ty_res;
        if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin
          let arg = List.assoc lbl.lbl_pos ppl in
          unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
        end else begin
          let _, ty_arg', ty_res' = instance_label false lbl in
          unify env ty_arg ty_arg';
          unify_pat env p ty_res'
        end in
      Array.iter do_label lbl.lbl_all;
      ty
  | Tpat_or(p1, p2, path) ->
      let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
      unify_pat env {p2 with pat_type = ty2} ty1;
      begin match path with None -> ()
      | Some path ->
          let td = try Env.find_type path env with Not_found -> assert false in
          let params = List.map (fun _ -> newvar()) td.type_params in
          match expand_head env (newty (Tconstr (path, params, ref Mnil)))
          with {desc=Tvariant row} when static_row row ->
            unify_pat env {p1 with pat_type = ty1}
              (newty (Tvariant{row with row_closed=false; row_more=newvar()}))
          | _ -> ()
      end;
      ty1
  | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type

let build_or_pat env loc lid =
  let path, decl =
    try Env.lookup_type lid env
    with Not_found ->
      raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
  in
  let tyl = List.map (fun _ -> newvar()) decl.type_params in
  let fields =
    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
    match ty.desc with
      Tvariant row when static_row row ->
        (row_repr row).row_fields
    | _ -> raise(Error(loc, Not_a_variant_type lid))
  in
  let bound = ref [] in
  let pats, fields =
    List.fold_left
      (fun (pats,fields) (l,f) ->
        match row_field_repr f with
          Rpresent None ->
            (l,None) :: pats,
            (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})
            :: pats,
            (l, Reither(false, [ty], true, ref None)) :: fields
        | _ -> pats, fields)
      ([],[]) fields in
  let row =
    { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
  in
  let ty = newty (Tvariant row) in
  let gloc = {loc with Location.loc_ghost=true} in
  let pats =
    List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=gloc;
                            pat_env=env; pat_type=ty})
      pats
  in
  match pats with
    [] -> raise(Error(loc, Not_a_variant_type lid))
  | 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 find_record_qual = function
  | [] -> None
  | (Longident.Ldot (modname, _), _) :: _ -> Some modname
  | _ :: rest -> find_record_qual rest

let type_label_a_list type_lid_a lid_a_list =
  match find_record_qual lid_a_list with
  | None -> List.map type_lid_a lid_a_list
  | Some modname ->
      List.map
        (function
         | (Longident.Lident id), sarg ->
              type_lid_a (Longident.Ldot (modname, id), sarg)
         | lid_a -> type_lid_a lid_a)
        lid_a_list

let rec type_pat env sp =
  match sp.ppat_desc with
    Ppat_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
      rp {
        pat_desc = Tpat_var id;
        pat_loc = sp.ppat_loc;
        pat_type = ty;
        pat_env = env }
  | Ppat_alias(sq, name) ->
	  let q = type_pat env sq in 
	  begin_def ();
	  let ty_var = build_as_type env q in
	  end_def ();
	  generalize ty_var;
	  let id = enter_variable sp.ppat_loc name ty_var in
	  rp {
      pat_desc = Tpat_alias(q, id);
      pat_loc = sp.ppat_loc;
      pat_type = q.pat_type;
      pat_env = env }
  | Ppat_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
      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 }
  | Ppat_construct(lid, sarg, explicit_arity) ->
    (match (sp.ppat_ext) with (* XXO *)
    | (Some v) -> 
		begin  
          match (Obj.magic v).pat_desc with
          | Tpat_construct (cd,pl) ->
              let sargs =
				match sarg with
                  None -> []
				| Some {ppat_desc = Ppat_tuple spl} when cd.cstr_arity > 1 -> spl 
				| Some sp -> [sp] in
			  let args = List.map (type_pat env) sargs in
		      {(Obj.magic v) with pat_desc = Tpat_construct(cd,args)}
	      | _ -> type_pat env {sp with ppat_ext = None}
		end                                        
    | None ->
		let constr =
          try
			Env.lookup_constructor lid env
          with Not_found ->
			raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
		let sargs =
          match sarg with
			None -> []
          | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
          | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
          | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
              replicate_list sp constr.cstr_arity
          | Some sp -> [sp] in
		if List.length sargs <> constr.cstr_arity then
          raise(Error(sp.ppat_loc, 
					  Constructor_arity_mismatch(lid,
												 constr.cstr_arity, 
												 List.length sargs)));
		let args = List.map (type_pat env) sargs in 
		let (ty_args, ty_res) = instance_constructor constr in
(*		let pat_types = List.map (fun pat -> pat.pat_type) in *)
		if ((!te_flag) == false) then
		  List.iter2 (unify_pat env) args ty_args;
		rp {
        pat_desc = Tpat_construct(constr, args); 
          pat_loc = sp.ppat_loc;
          pat_type = ty_res;
          pat_env = env })
  | Ppat_variant(l, sarg) ->
      let arg = may_map (type_pat env) sarg in
      let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
      let row = { row_fields =
                    [l, Reither(arg = None, arg_type, true, ref None)];
                  row_bound = arg_type;
                  row_closed = false;
                  row_more = newvar ();
                  row_fixed = false;
                  row_name = None } in
      rp {
        pat_desc = Tpat_variant(l, arg, row);
        pat_loc = sp.ppat_loc;
        pat_type = newty (Tvariant row);
        pat_env = env }
  | Ppat_record lid_sp_list ->
      (match sp.ppat_ext with                                            (* XXO *)
      | Some v ->                                                        (* XXO *)
        begin match (Obj.magic v).pat_desc with                          (* XXO *)
	| Tpat_record dpl ->                                                 (* XXO *)
	    let pl = List.map (fun (i,p) -> type_pat env p) lid_sp_list in   (* XXO *)
	    let dppl = List.combine dpl pl in                                (* XXO *)
	    let dpl' = List.map (fun ((d,p),p1) -> (d,p1)) dppl              (* XXO *)
	    in {(Obj.magic v) with pat_desc = Tpat_record dpl'}              (* XXO *)
	| _ -> raise (Error(sp.ppat_loc,Internal_error "typecore.ml: Tpat_record expected."))               (* XXO *)
	end                                                                  (* XXO *)
      | None ->                                                          (* XXO *)

      let rec check_duplicates = function
        [] -> ()
      | (lid, sarg) :: remainder ->
          if List.mem_assoc lid remainder
          then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
          else check_duplicates remainder in
      check_duplicates lid_sp_list;
      let ty = newvar() in
      let type_label_pat (lid, sarg) =
        let label =
          try
            Env.lookup_label lid env
          with Not_found ->
            raise(Error(sp.ppat_loc, Unbound_label lid)) in
        let (_, ty_arg, ty_res) = instance_label false label in
        begin try
          unify env ty_res ty
        with Unify trace ->
          raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
        end;
        let arg = type_pat env sarg in
        unify_pat env arg ty_arg;
        (label, arg)
      in
      rp {
        pat_desc = Tpat_record(type_label_a_list type_label_pat lid_sp_list);
        pat_loc = sp.ppat_loc;
        pat_type = ty;
        pat_env = env } )
  | Ppat_array spl ->
      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;
      rp {
        pat_desc = Tpat_array pl;
        pat_loc = sp.ppat_loc;
        pat_type = instance (Predef.type_array ty_elt);
        pat_env = env }
  | Ppat_or(sp1, sp2) ->
      let initial_pattern_variables = !pattern_variables in
      let p1 = type_pat env sp1 in
      let p1_variables = !pattern_variables in
      pattern_variables := initial_pattern_variables ;
      let p2 = type_pat env sp2 in
      let p2_variables = !pattern_variables in
      unify_pat env p2 p1.pat_type;
      let alpha_env =
        enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
      pattern_variables := p1_variables ;
      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 }
  | Ppat_constraint(sp, sty) ->
      let p = type_pat env sp in
      let ty, force = Typetexp.transl_simple_type_delayed env sty in
      unify_pat env p ty;
      pattern_force := force :: !pattern_force;
      p
  | Ppat_type lid ->
      build_or_pat env sp.ppat_loc lid

let get_ref r =
  let v = !r in r := []; v

let add_pattern_variables env =
  let pv = get_ref pattern_variables in
  List.fold_right
    (fun (id, ty) env ->
       Env.add_value id {val_type = ty;
                         val_level = !Typetexp.global_level;  (* XXO *)
			 val_kind = Val_reg} env)
    pv env

let type_pattern env spat =
  reset_pattern ();
  let pat = type_pat env spat in
  let new_env = add_pattern_variables env in
  (pat, new_env, get_ref pattern_force)

let type_pattern_list env spatl =
  reset_pattern ();
  let patl = List.map (type_pat env) spatl in
  let new_env = add_pattern_variables env in
  (patl, new_env, get_ref pattern_force)

let type_class_arg_pattern cl_num val_env met_env l spat =
  reset_pattern ();
  let pat = type_pat val_env spat in
  if has_variants pat then begin
    Parmatch.pressure_variants val_env [pat];
    iter_pattern finalize_variant pat
  end;
  List.iter (fun f -> f()) (get_ref pattern_force);
  if is_optional l then unify_pat val_env pat (type_option (newvar ()));
  let (pv, met_env) =
    List.fold_right
      (fun (id, ty) (pv, env) ->
         let id' = Ident.create (Ident.name id) in
         ((id', id, ty)::pv,
          Env.add_value id' {val_type = ty;
	                     val_level = [];                     (* XXO *)
                             val_kind = Val_ivar (Immutable, cl_num)}
            env))
      !pattern_variables ([], met_env)
  in
  let val_env = add_pattern_variables val_env in
  (pat, pv, val_env, met_env)

let mkpat d = { ppat_desc = d; ppat_loc = Location.none; ppat_ext = None } (* XXO *)
let type_self_pattern cl_num privty val_env met_env par_env spat =
  let spat =
    mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                       "selfpat-" ^ cl_num))
  in
  reset_pattern ();
  let pat = type_pat val_env spat in
  List.iter (fun f -> f()) (get_ref pattern_force);
  let meths = ref Meths.empty in
  let vars = ref Vars.empty in
  let pv = !pattern_variables in
  pattern_variables := [];
  let (val_env, met_env, par_env) =
    List.fold_right
      (fun (id, ty) (val_env, met_env, par_env) ->
         (Env.add_value id {val_type = ty; val_level=[]; val_kind = Val_unbound} val_env, (* XXO *)
          Env.add_value id {val_type = ty;
	                    val_level= [];                                                (* XXO *)
                            val_kind = Val_self (meths, vars, cl_num, privty)}
            met_env,
          Env.add_value id {val_type = ty; val_level=[]; val_kind = Val_unbound} par_env)) (* XXO *)
      pv (val_env, met_env, par_env)
  in
  (pat, meths, vars, val_env, met_env, par_env)

let delayed_checks = ref []
let reset_delayed_checks () = delayed_checks := []
let add_delayed_check f = delayed_checks := f :: !delayed_checks
let force_delayed_checks () =
  List.iter (fun f -> f ()) (List.rev !delayed_checks);
  reset_delayed_checks ()


(* Generalization criterion for expressions *)

let rec is_nonexpansive exp =
  match exp.exp_desc with
    Texp_ident(_,_) -> true
  | Texp_constant _ -> true
  | Texp_let(rec_flag, pat_exp_list, body) ->
      List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
      is_nonexpansive body
  | Texp_function _ -> true
  | Texp_apply(e, (None,_)::el) ->
      is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el)
  | Texp_tuple el ->
      List.for_all is_nonexpansive el
  | Texp_construct(_, el,_) ->
      List.for_all is_nonexpansive el
  | Texp_variant(_, arg) -> is_nonexpansive_opt arg
  | Texp_record(lbl_exp_list, opt_init_exp) ->
      List.for_all
        (fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
        lbl_exp_list
      && is_nonexpansive_opt opt_init_exp
  | Texp_field(exp, lbl) -> is_nonexpansive exp
  | Texp_array [] -> true
  | Texp_ifthenelse(cond, ifso, ifnot) ->
      is_nonexpansive ifso && is_nonexpansive_opt ifnot
  | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
      true
  (* Note: nonexpansive only means no _observable_ side effects *)
  | Texp_lazy e -> is_nonexpansive e
  | Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
      let count = ref 0 in
      List.for_all
        (function
            Cf_meth _ -> true
          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
          | Cf_init e -> is_nonexpansive e
          | Cf_inher _ | Cf_let _ -> false)
        fields &&
      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
        vars true &&
      !count = 0
  | Texp_bracket e -> is_nonexpansive e     (* XXO *)
  | Texp_escape e -> is_nonexpansive e      (* XXO *)
  | Texp_run e -> is_nonexpansive e         (* XXO *)
  | Texp_runoffshore(e,_) -> is_nonexpansive e   (* YYO *)(* WT: *)
  | Texp_runoffshore_arg(_,e) -> (* YYO *)(* WT: *)
      is_nonexpansive e   
  | Texp_etag (_, e, e', _) -> is_nonexpansive e (* XXO *)
  | _ -> false

and is_nonexpansive_opt = function
    None -> true
  | Some e -> is_nonexpansive e

(* Typing of printf formats.
   (Handling of * modifiers contributed by Thorsten Ohl.) *)

let type_format loc fmt =

  let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in

  let bad_conversion fmt i c =
    raise (Error (loc, Bad_conversion (fmt, i, c))) in
  let incomplete_format fmt =
    raise (Error (loc, Incomplete_format fmt)) in

  let range_closing_index fmt i =

    let len = String.length fmt in
    let find_closing j =
      if j >= len then incomplete_format fmt else
      try String.index_from fmt j ']' with
      | Not_found -> incomplete_format fmt in
    let skip_pos j =
      if j >= len then incomplete_format fmt else
      match fmt.[j] with
      | ']' -> find_closing (j + 1)
      | c -> find_closing j in
    let rec skip_neg j =
      if j >= len then incomplete_format fmt else
      match fmt.[j] with
      | '^' -> skip_pos (j + 1)
      | c -> skip_pos j in
    find_closing (skip_neg (i + 1)) in

  let rec type_in_format fmt =

    let len = String.length fmt in

    let ty_input = newvar ()
    and ty_result = newvar ()
    and ty_aresult = newvar () in

    let meta = ref 0 in

    let rec scan_format i =
      if i >= len then
        if !meta = 0
        then ty_aresult, ty_result
        else incomplete_format fmt else
      match fmt.[i] with
      | '%' -> scan_opts i (i + 1)
      | _ -> scan_format (i + 1)
    and scan_opts i j =
      if j >= len then incomplete_format fmt else
      match fmt.[j] with
      | '_' -> scan_rest true i (j + 1)
      | _ -> scan_rest false i j
    and scan_rest skip i j =
      let rec scan_flags i j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
        | _ -> scan_width i j
      and scan_width i j = scan_width_or_prec_value scan_precision i j
      and scan_decimal_string scan i j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '0' .. '9' -> scan_decimal_string scan i (j + 1)
        | _ -> scan i j
      and scan_width_or_prec_value scan i j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '*' ->
            let ty_aresult, ty_result = scan i (j + 1) in
            ty_aresult, ty_arrow Predef.type_int ty_result
        | '-' | '+' -> scan_decimal_string scan i (j + 1)
        | _ -> scan_decimal_string scan i j
      and scan_precision i j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
        | _ -> scan_conversion i j

      and conversion j ty_arg =
        let ty_aresult, ty_result = scan_format (j + 1) in
        ty_aresult,
        if skip then ty_result else ty_arrow ty_arg ty_result

      and scan_conversion i j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '%' | '!' -> scan_format (j + 1)
        | 's' | 'S' -> conversion j Predef.type_string
        | '[' ->
          let j = range_closing_index fmt j in
          conversion j Predef.type_string
        | 'c' | 'C' -> conversion j Predef.type_char
        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
          conversion j Predef.type_int
        | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
        | 'B' | 'b' -> conversion j Predef.type_bool
        | 'a' ->
          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
        | 't' -> conversion j (ty_arrow ty_input ty_aresult)
        | 'l' | 'n' | 'L' as c ->
          let j = j + 1 in
          if j >= len then conversion (j - 1) Predef.type_int else begin
            match fmt.[j] with
            | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
              let ty_arg =
                match c with
                | 'l' -> Predef.type_int32
                | 'n' -> Predef.type_nativeint
                | _ -> Predef.type_int64 in
              conversion j ty_arg
            | c -> conversion (j - 1) Predef.type_int
          end
        | '{' | '(' as c ->
          let j = j + 1 in
          if j >= len then incomplete_format fmt else
          let sj =
            Printf.sub_format incomplete_format bad_conversion c fmt j in
          let sfmt = String.sub fmt j (sj - j - 1) in
          let ty_sfmt = type_in_format sfmt in
          begin match c with
          | '{' -> conversion sj ty_sfmt
          | _ -> incr meta; conversion (j - 1) ty_sfmt end
        | ')' when !meta > 0 -> decr meta; scan_format (j + 1)
        | c -> bad_conversion fmt i c in
      scan_flags i j in

    let ty_ares, ty_res = scan_format 0 in
    newty
      (Tconstr(Predef.path_format4,
               [ty_res; ty_input; ty_ares; ty_result],
               ref Mnil)) in

  type_in_format fmt

(* Approximate the type of an expression, for better recursion *)

let rec approx_type env sty =
  match sty.ptyp_desc with
    Ptyp_arrow (p, _, sty) ->
      let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
      newty (Tarrow (p, ty1, approx_type env sty, Cok))
  | Ptyp_tuple args ->
      newty (Ttuple (List.map (approx_type env) args))
  | Ptyp_constr (lid, ctl) ->
      begin try
        let tyl = List.map (approx_type env) ctl in
        let (path, _) = Env.lookup_type lid env in
        newconstr path tyl
      with Not_found -> newvar ()
      end
  | _ -> newvar ()

let rec type_approx env sexp =
  match sexp.pexp_desc with
    Pexp_let (_, _, e) -> type_approx env e
  | Pexp_function (p,_,(_,e)::_) when is_optional p ->
       newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
  | Pexp_function (p,_,(_,e)::_) ->
       newty (Tarrow(p, newvar (), type_approx env e, Cok))
  | Pexp_match (_, (_,e)::_) -> type_approx env e
  | Pexp_try (e, _) -> type_approx env e
  | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
  | Pexp_ifthenelse (_,e,_) -> type_approx env e
  | Pexp_sequence (_,e) -> type_approx env e
  | Pexp_constraint (e, sty1, sty2) ->
      let approx_ty_opt = function
        | None -> newvar ()
        | Some sty -> approx_type env sty
      in
      let ty = type_approx env e
      and ty1 = approx_ty_opt sty1
      and ty2 = approx_ty_opt sty2 in
      begin try unify env ty ty1 with Unify trace ->
        raise(Error(sexp.pexp_loc, Expr_type_clash trace))
      end;
      if sty2 = None then ty1 else ty2
  | _ -> newvar ()

(* List labels in a function type, and whether return type is a variable *)
let rec list_labels_aux env visited ls ty_fun =
  let ty = expand_head env ty_fun in
  if List.memq ty visited then
    List.rev ls, false
  else match ty.desc with
    Tarrow (l, _, ty_res, _) ->
      list_labels_aux env (ty::visited) (l::ls) ty_res
  | _ ->
      List.rev ls, ty.desc = Tvar

let list_labels env ty = list_labels_aux env [] [] ty

(* Check that all univars are safe in a type *)
let check_univars env kind exp ty_expected vars =
  (* need to expand twice? cf. Ctype.unify2 *)
  let vars = List.map (expand_head env) vars in
  let vars = List.map (expand_head env) vars in
  let vars' =
    List.filter
      (fun t ->
        let t = repr t in
        generalize t;
        if t.desc = Tvar && t.level = generic_level then
          (log_type t; t.desc <- Tunivar; true)
        else false)
      vars in
  if List.length vars = List.length vars' then () else
  let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
  and ty_expected = repr ty_expected in
  raise (Error (exp.exp_loc,
                Less_general(kind, [ty, ty; ty_expected, ty_expected])))

(* Check that a type is not a function *)
let check_partial_application env exp =
  match expand_head env exp.exp_type with
  | {desc = Tarrow _} ->
      Location.prerr_warning exp.exp_loc Warnings.Partial_application
  | _ -> ()

(* Hack to allow coercion of self. Will clean-up later. *)
let self_coercion = ref ([] : (Path.t * Location.t list ref) list)

(* Typing of expressions *)

let unify_exp env exp expected_ty =
  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
    Printtyp.raw_type_expr expected_ty; *)
  try
    unify env exp.exp_type expected_ty
  with
    Unify trace ->
      raise(Error(exp.exp_loc, Expr_type_clash(trace)))
  | Tags(l1,l2) ->
      raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))

(* From Here ==================================== XXO *)
(* Tag elimination function *)
let rec erasure_exp exp=
   match exp.pexp_desc with
      Pexp_ident lid -> exp
    | Pexp_constant cst ->  exp
    | Pexp_let(rec_flag, spat_sexp_list, sbody) ->  
         let spat_sexp_list' = List.map erasure_pat_exp spat_sexp_list in
         let sbody' = erasure_exp sbody in
         {exp with pexp_desc = Pexp_let(rec_flag, spat_sexp_list', sbody') }
    | Pexp_function (lid, expopt,matches) ->   
        let expopt' = erasure_optexp expopt in
		{ exp with pexp_desc = Pexp_function(lid, expopt', List.map erasure_pat_exp matches) }
    | Pexp_apply(sfunct, sargs) ->
        let funct = erasure_exp sfunct in
        let args = List.map (fun (l, arg)->(l, (erasure_exp arg))) sargs in
        {exp with pexp_desc = Pexp_apply(funct, args) }
    | Pexp_match (sarg, ms) -> 
		let arg = erasure_exp sarg in
		{exp with pexp_desc = Pexp_match(arg,List.map erasure_pat_exp ms) }
    | Pexp_try (exp1, pe_list) -> 
		{exp with pexp_desc = Pexp_try (erasure_exp exp1, List.map erasure_pat_exp pe_list)}
	| Pexp_destruct(lid, exp', Erase) -> erasure_exp exp'  
    | Pexp_destruct(lid, exp', Keep) -> 
		{exp with pexp_desc = Pexp_destruct(lid,erasure_exp exp',Keep)}
    | Pexp_construct(lid, sarg, explicit_arity, Erase) ->
          begin 
			match sarg with
			| Some arg -> erasure_exp arg 
			| None -> {exp with 
					   pexp_desc = Pexp_construct(Longident.parse "()", None,false,Erase)}
		  end

    | Pexp_construct(lid, sarg, explicit_arity, Keep) ->
		{ exp with 
		  pexp_desc = Pexp_construct(lid, erasure_optexp sarg, explicit_arity, Keep) }
    | Pexp_variant(l, expopt) -> { exp with pexp_desc = Pexp_variant(l, erasure_optexp expopt)} 
    | Pexp_record (lid_sexp_list, opt_sexp) -> 
		let el (lid,sexp) = (lid, erasure_exp sexp) in
		{exp with pexp_desc = Pexp_record (List.map el lid_sexp_list, erasure_optexp opt_sexp)}
    | Pexp_field(sarg, lid) -> {exp with pexp_desc = Pexp_field(erasure_exp sarg, lid)}
    | Pexp_setfield (srecord, lid, snewval) -> 
		{exp with pexp_desc = Pexp_setfield (erasure_exp srecord, lid, erasure_exp snewval)}
    | Pexp_array expl -> {exp with pexp_desc = Pexp_array (List.map erasure_exp expl)}
    | Pexp_ifthenelse (exp1, exp2, expop) ->
       let exp1' = erasure_exp exp1 in
       let exp2' = erasure_exp exp2 in
       let expop' = erasure_optexp expop in
       {exp with pexp_desc = Pexp_ifthenelse (exp1',exp2',expop')}
    | Pexp_sequence (exp1,exp2) ->
       {exp with pexp_desc = Pexp_sequence(erasure_exp exp1, erasure_exp exp2)}
   | Pexp_while (exp1, exp2) -> {exp with pexp_desc = Pexp_while(erasure_exp exp1, erasure_exp exp2)}
   | Pexp_for (str,exp1,exp2,dirflg,exp3) -> 
       {exp with pexp_desc = Pexp_for (str, erasure_exp exp1, erasure_exp exp2, dirflg, erasure_exp exp3)}
   | Pexp_constraint (exp1, cto1, cto2) -> 
       {exp with pexp_desc = Pexp_constraint (erasure_exp exp1, cto1, cto2) }
   | Pexp_new li -> exp (* we do not handle objects *)
   | Pexp_setinstvar(str,exp2) -> {exp with pexp_desc = Pexp_setinstvar(str,erasure_exp exp2) }
   | Pexp_override sl -> 
	   let nl  = List.map (fun (s,e) -> (s,erasure_exp e)) sl in 
	   {exp with pexp_desc = Pexp_override nl }
   | Pexp_letmodule(s,modexp,exp1) ->   
	   {exp with pexp_desc = Pexp_letmodule(s, erasure_modexp modexp, erasure_exp exp1) }
   | Pexp_assert e -> {exp with pexp_desc = Pexp_assert (erasure_exp e) }
   | Pexp_assertfalse -> exp
   | Pexp_lazy e -> {exp with pexp_desc = Pexp_lazy (erasure_exp e)}
   | Pexp_poly(e,topt) -> {exp with pexp_desc = Pexp_poly (erasure_exp e, topt) }
   | Pexp_object _ -> assert false
   | Pexp_send (exp1, s) ->
       {exp with pexp_desc = Pexp_send(erasure_exp exp1, s)}
   | Pexp_when (exp1, exp2) ->
       {exp with pexp_desc = Pexp_when(erasure_exp exp1, erasure_exp exp2)}
   | Pexp_run exp1 ->
       {exp with pexp_desc = Pexp_run(erasure_exp exp1)}
    | Pexp_runoffshore(exp1,s) ->
		raise (Error (exp.pexp_loc, Internal_error "Runoffshore inside etag not supported in erasure."))
    | Pexp_runoffshore_arg(s_list,exp1) ->
		raise (Error (exp.pexp_loc, Internal_error "Runoffshore_arg inside etag not supported in erasure."))
   | Pexp_bracket exp1 ->
       {exp with pexp_desc = Pexp_bracket(erasure_exp exp1)}
   | Pexp_escape exp1 ->
       {exp with pexp_desc = Pexp_escape(erasure_exp exp1)}
   | Pexp_cspval (t,li) -> exp (* problem with this? *)
   | Pexp_tuple es -> {exp with pexp_desc = Pexp_tuple(List.map erasure_exp es) }
   | Pexp_etag (t, exp') -> 
	   raise (Error (exp.pexp_loc, Internal_error "Etag inside etag not supported in erasure."))
and 
erasure_optexp opt = 
  match opt with
    None -> None
  | Some exp' -> Some (erasure_exp exp')
and
erasure_pat_exp (spat,sexp) =
 (erasure_pat spat, erasure_exp sexp)
and erasure_pat spat =
  match spat.ppat_desc with
    Ppat_any -> spat
  | Ppat_var _ -> spat
  | Ppat_alias (pat,name)-> { spat with ppat_desc = Ppat_alias(erasure_pat pat, name) }  
  | Ppat_constant _ -> spat
  | Ppat_tuple patlist -> 
      let patlist' = List.map erasure_pat patlist
	  in {ppat_desc=Ppat_tuple patlist';
	      ppat_loc= spat.ppat_loc;
	      ppat_ext= spat.ppat_ext}
  | Ppat_construct (lid,optpat,b) ->
	  { spat with ppat_desc = Ppat_construct(lid, erasure_optpat optpat, b)}
  | Ppat_variant (l, optpat) ->
	  { spat with ppat_desc = Ppat_variant (l, erasure_optpat optpat) }
  | Ppat_record lid_pat_ls -> 
	  let f (lid,pat) = (lid, erasure_pat pat) in 
	  { spat with ppat_desc = Ppat_record (List.map f lid_pat_ls) } 
  | Ppat_array patls -> {spat with ppat_desc = Ppat_array (List.map erasure_pat patls)}
  | Ppat_or (pat1, pat2) ->
      {spat with ppat_desc = Ppat_or(erasure_pat pat1, erasure_pat pat2)}
  | Ppat_constraint (pat, ctyp) ->{spat with ppat_desc = Ppat_constraint (erasure_pat pat, ctyp) }
  | Ppat_type lid -> spat
and erasure_optpat op = 
  match op with None -> None | Some p -> Some (erasure_pat p)
and erasure_modexp mexp = 
  match mexp.pmod_desc with 
  | Pmod_ident t -> mexp
  | Pmod_structure s -> {mexp with pmod_desc = Pmod_structure (erasure_structure s) }
  | Pmod_functor (fname,mtyp,mexp') -> 
	  { mexp with pmod_desc = Pmod_functor(fname,mtyp,erasure_modexp mexp') }
  | Pmod_apply(me1,me2) -> 
	  { mexp with pmod_desc = Pmod_apply(erasure_modexp me1, erasure_modexp me2) }
  | Pmod_constraint (me,mt) ->
	  { mexp with pmod_desc = Pmod_constraint(erasure_modexp me, mt) }
and erasure_structure s = List.map erasure_sitem s
and erasure_sitem s = 
  match s.pstr_desc with
  | Pstr_eval e -> {s with pstr_desc = Pstr_eval (erasure_exp e) }
  | Pstr_value (rflag,pelist) -> 
	  { s with pstr_desc = Pstr_value(rflag, List.map erasure_pat_exp pelist) }
  | Pstr_primitive (_,_) -> s
  | Pstr_type _ -> s
  | Pstr_exception _ -> s
  | Pstr_exn_rebind _ -> s
  | Pstr_module(modname,moddef) -> 
	  {s with pstr_desc = Pstr_module(modname, erasure_modexp moddef) }
  | Pstr_recmodule ds -> 
	  let f (nm,tp,e) = (nm,tp,erasure_modexp e) in 
	  {s with pstr_desc = Pstr_recmodule (List.map f ds) }
  | Pstr_modtype _ -> s
  | Pstr_open _ -> s
  | Pstr_class _ -> raise(Error(s.pstr_loc, Internal_error "Classes not supported."))
  | Pstr_class_type _ -> s 
  | Pstr_include e -> 
	  { s with  pstr_desc = Pstr_include (erasure_modexp e) }

(* generates a fresh identifier *)
let gennewstring =
     let count = ref 0 in
     fun s ->  incr count; s ^ "_" ^ string_of_int !count
let gennewvar =
   fun () ->
     let varstring = gennewstring "etag" in
     Longident.Lident(varstring)

(* Walid: Genboth should disappear *)
let genboth  =
   fun () ->
     let varstring = gennewstring "etag" in
     (Longident.Lident(varstring),varstring)

let genboth_name str  =
     let varstring = gennewstring str in
     (Longident.Lident(varstring),varstring)

let rec gen_n_vars n =
  if n = 0 
  then ([],[])
  else let (vs,ss) = gen_n_vars (n-1) in
       let (v,s) = genboth () in
         (v::vs, s:: ss)
let longidenttostring li =
  match li with
    Longident.Lident s -> s
  | _ -> fatal_error ("Trx.longidenttostring: li is not a simple id")
let newpat pdesc loc =
  {ppat_desc =pdesc; ppat_loc = loc; ppat_ext = None }
let newexp exp_desc loc =
  {pexp_desc = exp_desc; pexp_loc = loc; pexp_ext = None }

(* Walid: This looks too inefficient and should be simplified *)
let shell f c fstring = 
      let _ = gennewvar() in
      {f with 
       pexp_desc = 
        Pexp_apply({f with 
                    pexp_desc = 
                     Pexp_function
		       ("",None,[(newpat (Ppat_var fstring) f.pexp_loc)
			         ,c])},["", f])}
            
(* Walid: should be done with a match, not a function application. *)
let untag lid loc = 
    let (newid, newst) = genboth () in 
    let pat1 = newpat (Ppat_var newst) loc in
    let exp1 = newexp (Pexp_ident newid) loc in
    let pat2 = newpat(Ppat_construct (lid, Some pat1, false)) loc 
    in newexp(Pexp_function("", None,[pat2, exp1])) loc


(* Emir's wrappers *)
(* Walid: These will replace newexp and newpat in next release. *)
let mkPat d = { ppat_desc = d; ppat_loc = Location.none; ppat_ext = None }
let mkExp d = { pexp_desc = d; pexp_loc = Location.none; pexp_ext = None } 

let idfun () = 
  let (newid,newst) = genboth () in
  mkExp (Pexp_function ("",None, [(mkPat (Ppat_var newst), mkExp (Pexp_ident newid))]))

exception Yikes
let extend p e m = 
  fun p2 -> if p = p2 then e else m p2 

module X2 = 
struct
open Parsetree
open Typedtree
open Types
open Misc

let abstract f = 
  let (x_id,x_st) = genboth_name "x" in
  mkExp (Pexp_function("",None, [ (mkPat (Ppat_var x_st), 
								   f (mkExp (Pexp_ident x_id)))]))

let single_or_tuple xs = 
  match xs with 
  | [x] -> x
  | xs  -> mkExp (Pexp_tuple xs)

let rec wrap m (b : elimination_tag) tp (env : Env.t) s = 
  match tp.desc with 
  | Tvar -> s
  | Tarrow(lbl,tdom,tcod,_) -> 
	  let (x_id,x_st) = genboth_name "x" in
	  let e_ux = unwrap m b tdom env (mkExp (Pexp_ident x_id)) in
	  let e_wa2 = wrap m b tcod env e_ux in
	  let e_l = mkExp (Pexp_function("",None, 
									 [ (mkPat (Ppat_var x_st),
										e_wa2)])) in
	  e_l
  | Ttuple telist -> 
	let idss = List.map (fun x -> genboth_name "x") telist in
	let fW ((id,_), t) = wrap m b t env (mkExp (Pexp_ident id)) in
	let e_tup = single_or_tuple (List.map fW (List.combine idss telist)) in
	let p_tup = mkPat (Ppat_tuple
						 (List.map (fun (_,x) -> mkPat (Ppat_var x)) 
							idss)) in
	let e_mtc = mkExp (Pexp_match(s,
								  [ (p_tup,e_tup) ])) in
	e_mtc
  | Tobject _ -> s
  | Tfield _ -> s
  | Tnil     -> s
  | Tlink tp -> wrap m b tp env s 
  | Tsubst tp -> wrap m b tp env s 
  | Tunivar   -> s
  | Tpoly (te,tes) -> s
  | Tannotation(li,[],_) -> mkExp(Pexp_construct (li, None, false, b))
  | Tannotation(li,targs,tres) -> 
	  let names = List.map (fun x -> genboth_name "x") targs in 
	  let tpat  = mkPat 
		  (Ppat_tuple (List.map 
						 (fun (_,s) -> mkPat (Ppat_var s)) names)) in
	  let f ((x,_),t) = wrap m b t env (mkExp (Pexp_ident x)) in
	  let qs = List.map f (List.combine names targs) in
	  let tuple_qs = single_or_tuple qs in
	  let c_tuple_qs = mkExp (Pexp_construct(li, Some tuple_qs, false, b)) in 
	  mkExp (Pexp_match(s, [(tpat,c_tuple_qs)]))
  | Tconstr(tcpath,tp_args_list,_) -> 
	  begin
		match Path.name tcpath with
		| "code" -> 
			begin
			  match tp_args_list with 
			  | [_;t] -> mkExp 
					(Pexp_bracket (wrap m b t env (mkExp (Pexp_escape s))))
			  | _ -> raise 
					(Error(Location.none, 
						   Internal_error "Error with code in wrap. "))
			end
		| _ -> 
			begin
			  match (fst m) tcpath with
			  | Some f -> mkExp (Pexp_apply (f, [("", s)]))
			  | None -> 
				  begin
					let descr = Env.find_type tcpath env in 
					match descr.type_kind with 
					| Type_abstract  -> s
					| Type_record(ftypes,rrep,_) -> s
					| Type_variant(csargs,_) -> 
						let (f_id,f_str) = genboth_name (Path.name tcpath^"_w") in
						let b1 = 
						  buildUW_datatype wrap 
							(extend tcpath (Some (mkExp (Pexp_ident f_id))) 
							   (fst m),
							 snd m)
							b env tcpath (descr.type_params) tp_args_list csargs in
						let a1 = b1 in
						mkExp
						  (Pexp_let(Recursive, 
									[(mkPat (Ppat_var f_str), a1)],
									mkExp (Pexp_apply (
										   mkExp (Pexp_ident f_id), 
										   [("",s)]))))
									
				  end
			end
	  end
  | Tvariant _ -> s
and unwrap m (b : elimination_tag) tp env s = 
  match tp.desc with 
  | Tvar -> s
  | Tarrow(lbl,tdom,tcod,_) -> 
	  let (x_id,x_st) = genboth_name "x" in
	  let e_ux  = wrap m b tdom env (mkExp (Pexp_ident x_id)) in
	  let e_wa2 = unwrap m b tcod env e_ux in
	  let e_l = mkExp (Pexp_function("",None, 
									 [ (mkPat (Ppat_var x_st),
										e_wa2)])) in
	  e_l
  | Ttuple telist -> 
	let idss = List.map (fun x -> genboth_name "x") telist in
	let fU ((id,_), t) = unwrap m b t env (mkExp (Pexp_ident id)) in
	let e_tup = mkExp (Pexp_tuple 
						 (List.map fU (List.combine idss telist))) in
	let p_tup = mkPat (Ppat_tuple
						 (List.map (fun (_,x) -> mkPat (Ppat_var x)) 
							idss)) in
	let e_mtc = mkExp (Pexp_match(s,
								  [ (p_tup,e_tup) ])) in
	e_mtc
  | Tobject _ -> s	  
  | Tfield _ -> s
  | Tnil     -> s
  | Tlink tp -> unwrap m b tp env s 
  | Tsubst tp -> unwrap m b tp env s 
  | Tunivar   -> s
  | Tpoly (te,tes) -> s
  | Tannotation(li,[],tres) -> 
	  mkExp (Pexp_construct (Longident.parse "()", None,false,Keep)) 
  | Tannotation(li,targs,tres) -> 
	  let xs = List.map (fun x -> genboth_name "x") targs in
	  let ps1 = List.map (fun (_,x_s) -> mkPat (Ppat_var x_s)) xs in 
	  let ps2 = match ps1 with 
		[] -> None
	  | [x] -> Some x
	  | xs -> Some (mkPat(Ppat_tuple xs)) in
	  let p3 = mkPat (Ppat_construct (li, ps2, false)) in
	  let f ((x_id,_), t) = unwrap m b t env (mkExp (Pexp_ident x_id)) in
	  let es = List.map f (List.combine xs targs) in
	  let es_tup = single_or_tuple es in
	  mkExp (Pexp_match (s, [(p3,es_tup)]))
  | Tconstr(tcpath,tp_args,_) -> 
	  begin
		match Path.name tcpath with 
		| "code" -> 
			(match tp_args with 
			| [_;t] ->  mkExp (Pexp_bracket (unwrap m b t env 
											  (mkExp (Pexp_escape s))))
			| _ -> raise (Error(Location.none, 
								Internal_error "Error with code in unwrap.")))
		| _ -> 
			begin
			  match (snd m) tcpath with 
			  | Some exp -> mkExp (Pexp_apply(exp, [("",s)]))
			  | None -> 
				  begin
					let descr = Env.find_type tcpath env in 
					match descr.type_kind with 
					| Type_abstract -> s
					| Type_record _  -> s
					| Type_variant(csargs,_) -> 
						begin
						  let (f_id,f_str) = genboth_name (Path.name tcpath^"_u") in
						  let (x_id,x_str) = genboth_name "x" in
						  let b1 = 
							buildUW_datatype unwrap 
							  (fst m, 
							   (extend tcpath 
								  (Some (mkExp (Pexp_ident f_id))) (snd m))
							  ) b
							  env tcpath (descr.type_params) tp_args csargs in
						  let a1 = mkExp (Pexp_function
											("",None, 
											 [ (mkPat (Ppat_var x_str),
												mkExp (Pexp_apply (b1,[("",mkExp (Pexp_ident x_id))])))
											 ])) in
						  mkExp 
							(Pexp_let (Asttypes.Recursive,
									   [(mkPat (Ppat_var f_str), a1)],
									   mkExp 
										 (Pexp_apply (mkExp (Pexp_ident f_id),
													  [("",s)]))))
													 
						end
						  
				  end
			end
	  end
  | Tvariant x -> s
and buildUW_datatype uw m b env tcpath tparams targs csargs = 
		let build_match (cname,ts) = 
		  let v_iss = List.map (fun x-> genboth_name "x") ts in
		  let li = Longident.parse cname in
		  let p' = match List.map (fun (_,s) -> mkPat (Ppat_var s)) v_iss with
			[] -> None
		  | [x] -> Some x
		  | xs -> Some (mkPat (Ppat_tuple xs)) in
		  let p = mkPat (Ppat_construct (li, p', false)) in
		  let args = List.map (fun ((lid,_),t) -> 
			let t' = Ctype.apply env tparams t targs in 
			uw m b t' env (mkExp (Pexp_ident lid))) (List.combine v_iss ts) in
		  let body_args = match args with 
			[] -> None | xs -> Some (single_or_tuple xs) in 
		  let body_exp = mkExp (Pexp_construct(li,body_args,false,b)) 
		  in (p,body_exp) in 
	  let matches = List.map build_match csargs in 
	  let f = mkExp (Pexp_function("",None,matches))
	  in f 


end


let rec w m (b : Parsetree.elimination_tag) tp env = 
  match tp.desc with 
  | Tvar -> idfun ()
  | Tarrow  (lbl, tdom,tcod,_) -> 
	  let (f_id,f_st) = genboth_name "et_f" in
	  let (x_id,x_st) = genboth_name "et_x" in
	  let e_wb  = w m b tcod env in
	  let e_ud  = u m b tdom env in 
	  let e_ux  = mkExp (Pexp_apply (e_ud, [("", mkExp (Pexp_ident x_id))])) in
	  let e_fux = mkExp (Pexp_apply (mkExp (Pexp_ident f_id), [("",e_ux)]))  in
	  let e_wfux= mkExp (Pexp_apply (e_wb, [("",e_fux )])) in
	  let e_l1  = mkExp (Pexp_function("",None, [(mkPat (Ppat_var x_st),
												 e_wfux)])) in
	  let e_l2  = mkExp (Pexp_function("",None, [(mkPat (Ppat_var f_st), 
												 e_l1)]))
	  in e_l2 
  | Ttuple  telist -> 
	  let ws = List.map (fun t ->  w m b t env) telist in 
	  let vs = List.map (fun x -> genboth_name "et_x") telist in
	  let ps = mkPat (Ppat_tuple (List.map (fun (_,s) -> mkpat (Ppat_var s)) vs)) in
	  let bs = mkExp (Pexp_tuple (List.map (fun ((x,_),we) -> 
		 ( mkExp (Pexp_apply(we, [("",mkExp (Pexp_ident x))])))) (List.combine vs ws)))
	  in mkExp (Pexp_function("",None, [(ps,bs)]))
  | Tconstr (tcpath,tp_list_args,_) -> 
	  if Path.name tcpath = "code"
	  then 
		begin
		  match tp_list_args with 
		  | [_;t] ->  mkExp (Pexp_bracket (w m b t env))
		  | _ -> raise (Error(Location.none, 
							  Internal_error "Error withcode in wrap."))
		end
	  else 
	  begin
		match m tcpath with 
		| Some exp -> exp 
		| None -> 
			begin
			  let descr = Env.find_type tcpath env in
			  match descr.type_kind with 
			  | Type_abstract -> idfun () 
			  | Type_variant (csargs,_) -> 
				  begin
					let (f_id,f_str) = genboth_name "et_f" in
					let (x_id,x_str) = genboth () in
					let b1 = 
					  (buildUW_datatype w
						 (extend tcpath (Some (mkExp (Pexp_ident f_id))) m)  
						 b  env 
						tcpath (descr.type_params) tp_list_args csargs) in
					let a1 = mkExp (Pexp_function("",None, 
												  [ (mkPat (Ppat_var x_str),
													 mkExp (Pexp_apply (b1,[("",mkExp (Pexp_ident x_id))])))
												  ])) in
					mkExp 
					  (Pexp_let (Asttypes.Recursive,
								 [(mkPat (Ppat_var f_str), a1)],
								 mkExp (Pexp_ident f_id)))
				  end
			  | Type_record (ftypes, rrep,_) -> 
				  begin 
					idfun ()
				  end
			end
	  end
  | Tobject _ -> idfun ()
  | Tfield (nm,fkind,t1,t2) -> idfun ()
  | Tnil -> idfun ()
  | Tlink te -> w m b te env
  | Tsubst te -> w m b te env
  | Tvariant rwdesc -> idfun ()
  | Tunivar -> idfun ()
  | Tpoly  (te, tes) -> idfun ()
  | Tannotation (li,[],_) -> mkExp(Pexp_construct (li, None, false, b))
  | Tannotation (li,targs,tres) -> 
	  let names = List.map (fun x -> genboth ()) targs in
	  let tpat = mkPat (Ppat_tuple (List.map (fun (_,s) -> mkPat (Ppat_var s)) names)) in
	  let qs = List.map (fun ((i,_), t) -> mkExp (Pexp_apply (w m b t env, [("", mkExp(Pexp_ident i))]))) 
		  (List.combine names targs) in
	  let tuple_qs = match qs with 
	  | [q] -> q 
	  | _ -> mkExp (Pexp_tuple qs) in
	  let c_tuple_qs = mkExp(Pexp_construct(li,Some tuple_qs, false, b)) in
	  mkExp (Pexp_function("",None,[(tpat,c_tuple_qs)]))


and u m (b : Parsetree.elimination_tag) tp env = 
  match tp.desc with 
  | Tvar -> idfun ()
  | Tarrow  (lbl, tdom,tcod,_) -> 
	  let (f_id,f_st) = genboth () in
	  let (x_id,x_st) = genboth () in
	  let e_wb  = u m b tcod env in
	  let e_ud  = w m b tdom env in 
	  let e_ux  = mkExp (Pexp_apply (e_ud, [("", mkExp (Pexp_ident x_id))])) in
	  let e_fux = mkExp (Pexp_apply (mkExp (Pexp_ident f_id), [("",e_ux)]))  in
	  let e_wfux= mkExp (Pexp_apply (e_wb, [("",e_fux )])) in
	  let e_l1  = mkExp (Pexp_function("",None, [(mkPat (Ppat_var x_st),
												 e_wfux)])) in
	  let e_l2  = mkExp (Pexp_function("",None, [(mkPat (Ppat_var f_st), 
												 e_l1)]))
	  in e_l2 
  | Ttuple  telist -> 
	  let ws = List.map (fun t ->  u m b t env) telist in 
	  let vs = List.map (fun x -> genboth()) telist in
	  let ps = mkPat (Ppat_tuple (List.map (fun (_,s) -> mkpat (Ppat_var s)) vs)) in
	  let bs = mkExp (Pexp_tuple (List.map (fun ((x,_),we) -> 
		 ( mkExp (Pexp_apply(we, [("",mkExp (Pexp_ident x))])))) (List.combine vs ws)))
	  in mkExp (Pexp_function("",None, [(ps,bs)]))
  | Tconstr (tcpath,tp_list_args,_) -> 
	  if Path.name tcpath = "code"
	  then 
		begin
		  match tp_list_args with 
		  | [_;t] ->  mkExp (Pexp_bracket (u m b t env))
		  | _ -> raise (Error(Location.none, Internal_error "Error withcode in wrap."))
		end
	  else 
	  begin
		match m tcpath with 
		| Some exp -> exp 
		| None -> 
			begin
			  let descr = Env.find_type tcpath env in
			  match descr.type_kind with 
			  | Type_abstract -> idfun () 
			  | Type_variant (csargs,_) -> 
				  begin
					let (f_id,f_str) = genboth () in
					let (x_id,x_str) = genboth () in
					let b1 = 
					  (buildUW_datatype u
						 (extend tcpath (Some (mkExp (Pexp_ident f_id))) m)  
						 b  env 
						tcpath (descr.type_params) tp_list_args csargs) in
					let a1 = mkExp (Pexp_function("",None, 
												  [ (mkPat (Ppat_var x_str),
													 mkExp (Pexp_apply (b1,[("",mkExp (Pexp_ident x_id))])))
												  ])) in
					mkExp 
					  (Pexp_let (Asttypes.Recursive,
								 [(mkPat (Ppat_var f_str), a1)],
								 mkExp (Pexp_ident f_id)))
				  end
			  | Type_record (ftypes, rrep,_) -> 
				  begin 
					idfun ()
				  end
			end
	  end
  | Tobject _ -> idfun ()
  | Tfield (nm,fkind,t1,t2) -> idfun ()
  | Tnil -> idfun ()
  | Tlink te -> u m b te env
  | Tsubst te -> u m b te env
  | Tvariant rwdesc -> idfun ()
  | Tunivar -> idfun ()
  | Tpoly  (te, tes) -> idfun ()
  | Tannotation (li,[],tres) -> 
	  let (x_id,x_st) = genboth () in
	  mkExp (Pexp_function
			   ("",None,
				[(mkPat (Ppat_var x_st), 
				  mkExp (Pexp_construct (Longident.parse "()", None,false,Keep)))]))
  | Tannotation (li,targs,tres) -> 
	  let xs = List.map (fun x -> genboth()) targs in
	  let ps1 = List.map (fun (_,x_s) -> mkPat (Ppat_var x_s)) xs in 
	  let p2 = match ps1 with 
		[] -> None
	  | [x] -> Some x
	  | xs  -> Some (mkPat (Ppat_tuple xs)) in
	  let p3 = mkPat (Ppat_construct(li, p2, false)) in
	  let es = List.map 
		  (fun ((x_i,_),t) -> mkExp (Pexp_apply(u m b t env, [("",mkExp (Pexp_ident x_i))])))
		  (List.combine xs targs) in
	  let e2 = match es with 
	  | [] -> raise Yikes
	  | [x] -> x
	  | xs  -> mkExp (Pexp_tuple xs) in
	  mkExp (Pexp_function ("",None, [(p3,e2)]))
and buildUW_datatype uw m  b env tcpath tparams targs csargs  = 
  let build_match (cname,ts) = 
	let v_iss = List.map (fun x -> genboth ()) ts in
	let li = Longident.parse cname in
	let p' = match List.map (fun (_,s) ->  (mkPat (Ppat_var s))) v_iss with
	| [] ->  None
	| [x] -> Some x
	| xs  -> Some (mkPat (Ppat_tuple xs)) in
	let p =  (mkPat (Ppat_construct (li, p' ,false))) in
	let args =  
	  List.map (fun ((lid,_),t) -> 
		let t' = Ctype.apply env tparams t targs in (* instantiate parameters to actual types *)
		mkExp (Pexp_apply(uw m b t' env, [("",mkExp (Pexp_ident lid))])))
		(List.combine v_iss ts) in
	let body_arg = 
	  match args with  
	  | []  -> None
	  | [x] -> Some x
	  | xs  -> Some (mkExp (Pexp_tuple xs)) in 
	let body_exp = mkExp (Pexp_construct(li,body_arg,false,b))
	in (p,body_exp) in
  let matches = List.map build_match csargs in
  let f = mkExp (Pexp_function("",None, matches))
  in f 

let uncode_atyp atyp = 
  match atyp.desc with 
	Tconstr(path,[_;ts],_) -> 
	  if (Path.name path = "code")
	  then ts
	  else atyp
  | _ -> atyp

let rec wrap atyp sexp =
   let (fvar,fstring) = genboth() in
   match atyp.desc with
       Tconstr(path,[_;ts],_) -> 
	 if (Path.name path =  "code") 
	 then
	   {sexp with
	     pexp_desc = 
	     Pexp_bracket (wrap ts 
			     {sexp with pexp_desc = Pexp_escape sexp})}
	     else sexp
   | Tconstr(_,_,_) -> sexp
   | Tannotation(lid, args, res) ->
         shell sexp 
         {sexp with pexp_desc = Pexp_construct(lid, Some sexp, false,Keep)}
         fstring
   | Tarrow(l,ty1,ty2,_) -> 
       let (id, ids) = genboth() in
       let pat = (newpat (Ppat_var ids) sexp.pexp_loc) in
       let exp'= (newexp (Pexp_ident id) sexp.pexp_loc) in
       let content =
         {sexp with 
           pexp_desc = 
           Pexp_function
             ("", None, [(pat,(wrap ty2 
				 {sexp with 
				   pexp_desc= 
				   (Pexp_apply(newexp (Pexp_ident fvar) sexp.pexp_loc, 
					       ["",unwrap ty1 exp']))}))])}
       in shell sexp content fstring
   | Ttuple tylist ->
       let len = List.length tylist in
       let (vars, vstrs) = gen_n_vars len in  
       let nexps = 
         List.map (fun id -> newexp (Pexp_ident id) sexp.pexp_loc) vars in 
(*        let newvars = List.map (fun _ -> gennewvar ()) tylist in *)
       let npats =
         List.map (fun ss -> newpat (Ppat_var ss) sexp.pexp_loc) vstrs in
       let tupleelms = List.map2 wrap tylist nexps in
       let newtuple = {sexp with pexp_desc = Pexp_tuple tupleelms} in
       {sexp with 
         pexp_desc = Pexp_apply
           ({sexp with pexp_desc = Pexp_function("",None, [(newpat(Ppat_tuple npats) sexp.pexp_loc, newtuple)])},[("", sexp)])}
   | Tvar -> sexp
   | Tobject _ -> fatal_error "Tobject appear in wrap"
   | Tfield _ -> fatal_error "Tfield appear in wrap"
   | Tnil -> fatal_error "Tnil appear in wrap"
   | Tlink ty' -> wrap ty' sexp
   | Tsubst _ -> fatal_error "Tsubst appear in wrap"
   | Tvariant _ -> fatal_error "Tvariant appear in wrap"  
   | Tunivar -> fatal_error "Tunivar appear in wrap"  
   | Tpoly _ -> fatal_error "Tpoly appear in wrap"  
and unwrap atyp sexp =
  let  (fvar,fvst) = genboth() in
   (match atyp.desc with
     Tconstr(path,[_;ts],_) -> 
       if (Path.name path = "code") 
       then
	 {sexp with
	   pexp_desc = 
	   Pexp_bracket (unwrap ts 
			   {sexp with pexp_desc = Pexp_escape sexp})}
       else sexp
   | Tconstr(_,_,_) -> sexp 
   | Tannotation(lid, [args], res) ->
       let content = untag lid sexp.pexp_loc in 
       {sexp with pexp_desc = Pexp_apply(content, ["",sexp])}
   | Tannotation(lid, args, res) ->  
       let content = untag lid sexp.pexp_loc in 
       {sexp with pexp_desc = Pexp_apply(content, ["",sexp])}

   | Tarrow(l,ty1,ty2,_) -> 
       let (id, ids) = genboth() in
       let pat = (newpat (Ppat_var ids) sexp.pexp_loc) in
       let exp'= (newexp (Pexp_ident id) sexp.pexp_loc) in
       let content =
         {sexp with 
           pexp_desc = 
	   Pexp_function
	     ("", None, 
	      [(pat, (unwrap ty2 
			{sexp with 
			  pexp_desc = 
			  Pexp_apply(newexp (Pexp_ident fvar) 
				       sexp.pexp_loc,["", wrap ty1 exp'])}))])}
       in shell sexp content fvst  
   | Ttuple tylist ->
       let len = List.length tylist in
       let (vars, vstrs) = gen_n_vars len in
       let nexps = 
         List.map (fun id -> newexp (Pexp_ident id) sexp.pexp_loc) vars in 
       let npats =
         List.map (fun ss -> newpat (Ppat_var ss) sexp.pexp_loc) vstrs in
       let tupleatts = List.map2 unwrap tylist nexps in
       let newtuple = {sexp with pexp_desc = Pexp_tuple tupleatts} in
       {sexp with
	 pexp_desc = 
         Pexp_apply
	   ({sexp with 
              pexp_desc = 
              Pexp_function("", None, 
                            [(newpat (Ppat_tuple npats) sexp.pexp_loc, 
                              newtuple)])},
            ["", sexp])}
   | Tvar -> fatal_error "Tvar appear in unwrap"
   | Tobject _ -> fatal_error "Tobject appear in unwrap"
   | Tfield _ -> fatal_error "Tfield appear in unwrap"
   | Tnil -> fatal_error "Tnil appear in unwrap"
   | Tlink ty' -> unwrap ty' sexp
   | Tsubst _ -> fatal_error "Tsubst appear in unwrap"
   | Tvariant _ -> fatal_error "Tvariant appear in unwrap"
   | Tunivar -> fatal_error "Tunivar appear in unwrap"
   | Tpoly _ -> fatal_error "Tpoly appear in unwrap" )


(* Walid: uni_trace is debugging code and should be removed.*) 
let rec uni_trace fmt l = 
  match l with 
    [] -> ()
  | [(x,y)] -> Format.fprintf fmt " (%a) = (%a) " Printtyp.type_expr x Printtyp.type_expr y 
  | ((x,y)::rest) -> 
      (Format.fprintf fmt " (%a) = (%a) " Printtyp.type_expr x Printtyp.type_expr y;
       Format.fprintf fmt ", ";
       uni_trace fmt rest)


let newpat desc loc =
{ppat_desc = desc; ppat_loc = loc; ppat_ext = None}

let newexp desc loc =
{pexp_desc = desc; pexp_loc = loc; pexp_ext = None}


let genstvar count  =
     incr count;
     let varstring = "dstr" ^ "_" ^ string_of_int !count in
     (Longident.Lident(varstring),varstring)

let rec gen_vars n count =
  if n = 0 
  then []
  else let slls = gen_vars (n-1) count in
       let vs = genstvar count in
         vs::slls

let gencontent pairls len loc =
  match pairls with
   (id, s):: pairs -> 
      if len = 1 
      then (newpat (Ppat_var s) loc, newexp (Pexp_ident id) loc)
      else (newpat (Ppat_tuple (List.map (fun (_ , ss) -> 
				      (newpat (Ppat_var ss) loc)) pairls)) loc,
	    newexp (Pexp_tuple(List.map (fun (ids,_) -> 
				     (newexp (Pexp_ident ids) loc)) pairls)) loc)
  | [] -> assert false

let gendestr len lid erase loc=
    let count = ref 0 in
    let vars = gen_vars len count in
    let (pat, exp) = gencontent vars len loc in
    newexp (Pexp_function("", None,
			  [newpat(Ppat_construct(lid, Some pat, false)) loc, exp])) loc (* XXO *)



let sametype env exp expected_ty = 
  try
    unify env exp.exp_type expected_ty;
    true
   with Unify trace ->
   (if !Clflags.debug_messages then 
   (Format.fprintf Format.std_formatter "exp_type is @ %a@\n" Printtyp.type_expr exp.exp_type;                          
   Format.fprintf Format.std_formatter "while expected @ %a@ \n" Printtyp.type_expr expected_ty); false)
(* To Here ====================================== XXO *)
	   
let rec type_exp env sexp =
  match sexp.pexp_desc with
    Pexp_ident lid ->
      let unSome =                                            (* XXO *)
        (function | Some x -> x | None -> assert false) in    (* XXO *)
      let stored_pervasives_id =                              (* XXO *)
       (match sexp.pexp_ext with                              (* XXO *)
          | Some exp ->                                       (* XXO *)
	      (match (Obj.magic exp).exp_desc with            (* XXO *)
	       | Texp_ident (i,vd) when Printtyp.ident_can_be_quoted i -> (* XXO *)
		 Some (path_to_lid i)                         (* XXO *)
	       | _ -> None)                                   (* XXO *)
          | None -> None) (* XXO *)                           (* XXO *)
      in let lid = if stored_pervasives_id <> None            (* XXO *)
         then unSome stored_pervasives_id else lid            (* XXO *)
      in                                                      (* XXO *)
      begin try
        let (path, desc) = Env.lookup_value lid env in
        let unify_level (tl1,tl2) =
	  let rec ul = function                          (* XXO *)
	    | (t1::tl1,t2::tl2) ->                       (* XXO *)
	         unify env t1 t2; ul (tl1,tl2)           (* XXO *)
	    | _ -> ()                                    (* XXO *)
          in ul (List.rev tl1, List.rev tl2)     (* XXO *)
	in unify_level (desc.val_level,!Typetexp.global_level); (* XXO *)
        re {
          exp_desc =
            begin match desc.val_kind with
              Val_ivar (_, cl_num) ->
                let (self_path, _) =
                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                in
                Texp_instvar(self_path, path)
            | Val_self (_, _, cl_num, _) ->
                let (path, _) =
                  Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                in
                Texp_ident(path, desc)
            | Val_unbound ->
                raise(Error(sexp.pexp_loc, Masked_instance_variable lid))
(* XXO:  The following clause handles the normal cases *)
            | _ ->
	      if (List.length desc.val_level) > (List.length !Typetexp.global_level)             (* XXO *)
	       then raise (Error (sexp.pexp_loc, Wrong_level         (* XXO *)
	                  (desc.val_level, !Typetexp.global_level))) (* XXO *)
	       else                                                  (* XXO *)
                Texp_ident(path, desc)
            end;
          exp_loc = sexp.pexp_loc;
(* XXO:  Instantiates type scheme to a type *)
          exp_type = instance desc.val_type;
          exp_env = env }
      with Not_found ->
        raise(Error(sexp.pexp_loc, Unbound_value lid))
      end
  | Pexp_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
	  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_function _ ->     (* defined in type_expect *)
      type_expect env sexp (newvar())
  | Pexp_apply(sfunct, sargs) ->
      begin_def (); (* one more level for non-returning functions *)
      if !Clflags.principal then begin_def ();
      let funct = type_exp env sfunct in
      if !Clflags.principal then begin
        end_def ();
        generalize_structure funct.exp_type
      end;
      let rec lower_args ty_fun =
        match (expand_head env ty_fun).desc with
          Tarrow (l, ty, ty_fun, com) ->
            unify_var env (newvar()) ty;
            lower_args ty_fun
        | _ -> ()
      in
      let ty = instance funct.exp_type in
      end_def ();
      lower_args ty;
      begin_def ();
      let (args, ty_res) = type_application env funct sargs in
      end_def ();
      unify_var env (newvar()) funct.exp_type;
      re {
        exp_desc = Texp_apply(funct, args);
        exp_loc = sexp.pexp_loc;
        exp_type = ty_res;
        exp_env = env }
  | Pexp_bracket(sexp) ->   (* XXO:  Typechecking for B *)
      let t = newvar() in
      let _ = Typetexp.global_level := t::!Typetexp.global_level in
      let exp = type_exp env sexp in
      let r =
        { exp_desc = Texp_bracket(exp);
          exp_loc = sexp.pexp_loc;
          exp_type = instance (Predef.type_code t exp.exp_type);
          exp_env = env }  in 
      let _ = Typetexp.global_level := (List.tl !Typetexp.global_level)
      in r
  | Pexp_escape(sexp) ->    (* XXO:  Typechecking for E *)
      let (t,tl) = match !Typetexp.global_level with
                   | (t::tl) -> (t,tl)
		   | [] -> raise (Error (sexp.pexp_loc, Wrong_level (!Typetexp.global_level,[]))) in
      let _ = Typetexp.global_level := tl in
      let exp = type_exp env sexp in
      let ty = newvar() in
      let codety = instance (Predef.type_code t ty) in
      let _ = try unify env exp.exp_type codety
              with Unify trace ->
                raise(Error(sexp.pexp_loc, Expr_type_clash trace))
      in let r =
        { exp_desc = Texp_escape(exp);
          exp_loc = sexp.pexp_loc;
          exp_type = ty;
          exp_env = env } in
      let _ = Typetexp.global_level := t::tl
      in r
  | Pexp_run(sexp) ->       (* XXO:  Typechecking for R *)
      begin_def();
      let exp = type_exp env sexp in
      let (ty1,ty2) = (newvar(),newvar()) in
      let codety = instance (Predef.type_code ty1 ty2) in
      begin
        try unify env exp.exp_type codety;
	end_def ();
        if deep_occur ty1 ty2 then
          raise (Error (sexp.pexp_loc, Run_occur_check (ty1,codety) ));
	generalize ty1;
	if ty1.level <> generic_level then
          raise (Error (sexp.pexp_loc, Run_alpha_not_generalizable (ty1,codety) ));
          { exp_desc = Texp_run(exp);
            exp_loc = sexp.pexp_loc;
            exp_type = ty2;
            exp_env = env }
        with Unify trace ->
                raise(Error(sexp.pexp_loc, Expr_type_clash trace))
      end
  | Pexp_runoffshore(sexp,lang) ->  (* YYO: Typechecking for offshore *)
      let exp = type_exp env sexp in
      if(isInSubsetTypeCheck exp)==false then
         raise(Error_Translation_type_check_subset);
      let (ty1,ty2) = (newvar(),newvar()) in
      let codety = instance (Predef.type_code ty1 ty2) in
      begin
        try unify env exp.exp_type codety;
          { exp_desc = Texp_runoffshore(exp, lang);
            exp_loc = sexp.pexp_loc;
            exp_type = ty2;
            exp_env = env }
        with Unify trace ->
                raise(Error(sexp.pexp_loc, Expr_type_clash trace))
      end
  | Pexp_runoffshore_arg(s_list,sexp) ->  (* YYO *)
      let exp = type_exp env sexp in
      if(isInSubsetTypeCheck exp)==false then
         raise(Error_Translation_type_check_subset);
      let (ty1, ty2) = (newvar(),newvar()) in
      let codety = instance (Predef.type_code ty1 ty2) in
      begin
        try unify env exp.exp_type codety;
          { exp_desc = Texp_runoffshore_arg(s_list,exp);
            exp_loc = sexp.pexp_loc;
            exp_type = ty2;
            exp_env = env }
        with Unify trace ->
                raise(Error(sexp.pexp_loc, Expr_type_clash trace))
      end
  | Pexp_cspval(obj,li) ->  (* Typechecking for CSPVAL. *)
     let ty = instance (newvar ()) in   
     { exp_desc = Texp_cspval(obj,li);
        exp_loc = sexp.pexp_loc;
        exp_type = ty;
        exp_env = env }
  | Pexp_etag(satype, sexp) ->  (* XXO Static type checker *)  
             let atype = Typetexp.transl_annot_type env true satype in
             let stye = Typetexp.source atype in
             let rtye = Typetexp.target atype in
             let res =  type_expect env sexp stye in
             let (ty1,ty2) = (newvar(),newvar()) in
             let (ty'1,ty'2) = (newvar(),newvar()) in
             let codety' = instance (Predef.type_code ty'1 ty'2) in 
             let codety= instance (Predef.type_code ty1 ty2) in
(*			 let emir_wexp = X2.abstract 
				 (X2.wrap ((fun x -> None),(fun x -> None)) Keep  atype env) in
			 let emir_uexp = 
				  X2.unwrap ((fun x -> None),(fun x -> None)) Keep  atype env sexp in
			 let _ = Format.fprintf Format.std_formatter 
				 "Tag elimination type checking.\n Type =@\n@[ %a @].@\nNew wrapper = @[ %a @]  @\n.\nNew unwrapper = @[ %a @] @.\n" 
														  Printtyp.type_expr (uncode_atyp atype)
				 Printast.inpc emir_wexp 
				 Printast.inpc emir_uexp in
			 let ee1 = type_exp env emir_wexp  in
			 let ee2 = type_exp env emir_uexp  in  *)
			 
			 let wexp = (* emir_uexp *)  unwrap atype sexp  in
			 let wres = type_expect env wexp rtye in
             begin
               try
                 unify env res.exp_type codety; 
                 unify env atype codety';
				 let exp = 
                   {exp_desc = Texp_cspval (Obj.magic env, Longident.parse "");
                    exp_loc = sexp.pexp_loc;
                    exp_type = rtye;
                    exp_env = env } 
				 in {exp with exp_desc = Texp_etag(ty'2, res, wres, exp)}
               with Unify trace ->
                 raise(Error(sexp.pexp_loc, Expr_type_clash trace))
             end
  | Pexp_match(sarg, caselist) ->
      let arg = type_exp env sarg in
      let ty_res = newvar() in
      let cases, partial =
        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
      in
      re {
        exp_desc = Texp_match(arg, cases, partial);
        exp_loc = sexp.pexp_loc;
        exp_type = ty_res;
        exp_env = env }
  | Pexp_try(sbody, caselist) ->
      let body = type_exp env sbody in
      let cases, _ =
        type_cases env (instance Predef.type_exn) body.exp_type None
          caselist in
      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
      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 }
| Pexp_destruct(lid, sres,erase) ->                                         (* XXO *)
    type_destruct env sexp.pexp_loc lid sres (newvar()) erase sexp.pexp_ext (* XXO *)
| Pexp_construct(lid, sarg, explicit_arity,erase) ->
    type_construct env sexp.pexp_loc lid sarg explicit_arity (newvar ()) erase sexp.pexp_ext  (* XXO *)
| 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
    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 ();
                              row_bound = [];
                              row_closed = false;
                              row_fixed = false;
                              row_name = None});
    exp_env = env }
| Pexp_record(lid_sexp_list, opt_sexp) ->
    let ty = newvar() in
    let num_fields = ref 0 in
    let type_label_exp envold env (lid, sarg) =
      let label = try Env.lookup_label lid envold with 
		Not_found -> raise(Error(sexp.pexp_loc, Unbound_label lid)) in
      begin_def ();
      if !Clflags.principal then begin_def ();
      let (vars, ty_arg, ty_res) = instance_label true label in
      if !Clflags.principal then begin
        end_def ();
(* START *)
        generalize_structure ty_arg;
        generalize_structure ty_res
      end;
      begin try
        unify envold (instance ty_res) ty
      with Unify trace ->
        raise(Error(sexp.pexp_loc, Label_mismatch(lid, trace)))
      end;
      let arg = type_argument env sarg ty_arg in
      end_def ();
        if vars <> [] && not (is_nonexpansive arg) then
          generalize_expansive env arg.exp_type;
        check_univars env "field value" arg label.lbl_arg vars;
        num_fields := Array.length label.lbl_all;
        if label.lbl_private = Private then
          raise(Error(sexp.pexp_loc, Private_type ty));
      (label, {arg with exp_type = instance arg.exp_type}) in (* end type_label_exp *)
    (match sexp.pexp_ext with                                              (* XXO *)
    | Some v ->                                                            (* XXO *)
        begin 
		  match (Obj.magic v).exp_desc with                            (* XXO *)
		  | Texp_record (del,eo) -> (* XXO *)
			  let f ((lid,sexp),(l_desc,te))  = 
				let (ld_lid,tsexp)  = 
				  begin try
					type_label_exp  ((Obj.magic v).exp_env) env  (lid,sexp) 
				  with 
				  | Unify trace -> 
					  (if !Clflags.debug_messages then 
						(Format.fprintf 
						   Format.std_formatter 
						   "427: Unification failure in Texp-record.type_label_exp with trace %a." 
						   uni_trace trace);
					   raise (Unify trace))
				  | e ->  
					  (if !Clflags.debug_messages then 
						Format.fprintf Format.std_formatter 
						  "Texp-record fails with exception <1587>"; raise e) 
				  end in
				let _ = unify_exp te.exp_env tsexp (te.exp_type) 
				in (ld_lid,{tsexp with exp_env = env})
			  in
			  let lists = List.combine lid_sexp_list del in
			  let fieldsExps = List.map f lists in
			  let eo = match opt_sexp with                                     (* XXO *)
			  | None -> None                                          (* XXO *)
			  | Some e -> Some (type_exp env e)                       (* XXO *)
			  in {(Obj.magic v) with exp_desc = Texp_record(fieldsExps, eo) }         (* XXO *)
		  | _ -> fatal_error "typecore.ml: Texp_record expected"               (* XXO *)
		end                                                                  (* XXO *)
    | None ->                                                              (* XXO *)
		let lbl_exp_list = type_label_a_list (type_label_exp  env env) lid_sexp_list in
      let rec check_duplicates seen_pos lid_sexp lbl_exp =
        match (lid_sexp, lbl_exp) with
          ((lid, _) :: rem1, (lbl, _) :: rem2) ->
            if List.mem lbl.lbl_pos seen_pos
            then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
            else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
        | (_, _) -> () in
      check_duplicates [] lid_sexp_list lbl_exp_list;
      let opt_exp =
        match opt_sexp, lbl_exp_list with
          None, _ -> None
        | Some sexp, (lbl, _) :: _ ->
            let ty_exp = newvar () in
            let unify_kept lbl =
              if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
                  lbl_exp_list
              then begin
                let _, ty_arg1, ty_res1 = instance_label false lbl
                and _, ty_arg2, ty_res2 = instance_label false lbl in
                unify env ty_exp ty_res1;
                unify env ty ty_res2;
                unify env ty_arg1 ty_arg2
              end in
            Array.iter unify_kept lbl.lbl_all;
            Some(type_expect env sexp ty_exp)
        | _ -> assert false
      in
      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 sexp env ty in
        let rec missing_labels n = function
            [] -> []
          | lbl :: rem ->
              if List.mem n present_indices then missing_labels (n + 1) rem
              else lbl :: missing_labels (n + 1) rem
        in
        let missing = missing_labels 0 label_names in
        raise(Error(sexp.pexp_loc, Label_missing missing))
      end
      else if opt_sexp <> None && List.length lid_sexp_list = !num_fields then
        Location.prerr_warning sexp.pexp_loc Warnings.Useless_record_with;
      re {
        exp_desc = Texp_record(lbl_exp_list, opt_exp);
        exp_loc = sexp.pexp_loc;
        exp_type = ty;
        exp_env = env }
)
(* END *)

(*<<<<<<< typecore.ml
        generalize_structure ty_arg;
        generalize_structure ty_res
      end;
      begin try
        unify envold (instance ty_res) ty
      with Unify trace ->
        raise(Error(sexp.pexp_loc, Label_mismatch(lid, trace)))
      end;
      let arg = type_argument env sarg ty_arg in
      end_def ();
      if vars <> [] && not (is_nonexpansive arg) then
        generalize_expansive env arg.exp_type;
      check_univars env "field value" arg label.lbl_arg vars;
      num_fields := Array.length label.lbl_all;
      if label.lbl_private = Private then
        raise(Error(sexp.pexp_loc, Private_type ty));
      (label, {arg with exp_type = instance arg.exp_type}) in (* end type_label_exp *)
    (match sexp.pexp_ext with                                              (* XXO *)
    | Some v ->                                                            (* XXO *)
        begin 
		  match (Obj.magic v).exp_desc with                            (* XXO *)
		  | Texp_record (del,eo) -> (* XXO *)
			  let f ((lid,sexp),(l_desc,te))  = 
				let (ld_lid,tsexp)  = 
				  begin try
					type_label_exp  ((Obj.magic v).exp_env) env  (lid,sexp) 
				  with 
				  | Unify trace -> 
					  (if !Clflags.debug_messages then 
						(Format.fprintf 
						   Format.std_formatter 
						   "427: Unification failure in Texp-record.type_label_exp with trace %a." 
						   uni_trace trace);
					   raise (Unify trace))
				  | e ->  
					  (if !Clflags.debug_messages then 
						Format.fprintf Format.std_formatter 
						  "Texp-record fails with exception <1587>"; raise e) 
				  end in
				let _ = unify_exp te.exp_env tsexp (te.exp_type) 
				in (ld_lid,{tsexp with exp_env = env})
			  in
			  let lists = List.combine lid_sexp_list del in
			  let fieldsExps = List.map f lists in
			  let eo = match opt_sexp with                                     (* XXO *)
			  | None -> None                                          (* XXO *)
			  | Some e -> Some (type_exp env e)                       (* XXO *)
			  in {(Obj.magic v) with exp_desc = Texp_record(fieldsExps, eo) }         (* XXO *)
		  | _ -> fatal_error "typecore.ml: Texp_record expected"               (* XXO *)
		end                                                                  (* XXO *)
    | None ->                                                              (* XXO *)
		let lbl_exp_list = type_label_a_list (type_label_exp  env env) lid_sexp_list in
		let rec check_duplicates seen_pos lid_sexp lbl_exp =
          match (lid_sexp, lbl_exp) with
            ((lid, _) :: rem1, (lbl, _) :: rem2) ->
              if List.mem lbl.lbl_pos seen_pos
              then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
              else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
          | (_, _) -> () in
		check_duplicates [] lid_sexp_list lbl_exp_list;
		let opt_exp =
		  match opt_sexp, lbl_exp_list with
			None, _ -> None
		  | Some sexp, (lbl, _) :: _ ->
			  let ty_exp = newvar () in
			  let unify_kept lbl =
				if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
					lbl_exp_list
				then begin
                  let _, ty_arg1, ty_res1 = instance_label false lbl
                  and _, ty_arg2, ty_res2 = instance_label false lbl in
                  unify env ty_exp ty_res1;
                  unify env ty ty_res2;
                  unify env ty_arg1 ty_arg2
				end in
              Array.iter unify_kept lbl.lbl_all;
              Some(type_expect env sexp ty_exp)
          | _ -> assert false
		in
		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 sexp env ty in
          let rec missing_labels n = function
              [] -> []
			| lbl :: rem ->
				if List.mem n present_indices then missing_labels (n + 1) rem
				else lbl :: missing_labels (n + 1) rem
          in
          let missing = missing_labels 0 label_names in
          raise(Error(sexp.pexp_loc, Label_missing missing))
		end;
		re {
		exp_desc = Texp_record(lbl_exp_list, opt_exp);
		  exp_loc = sexp.pexp_loc;
		  exp_type = ty;
		  exp_env = env })
=======
        if vars <> [] && not (is_nonexpansive arg) then
          generalize_expansive env arg.exp_type;
        check_univars env "field value" arg label.lbl_arg vars;
        num_fields := Array.length label.lbl_all;
        if label.lbl_private = Private then
          raise(Error(sexp.pexp_loc, Private_type ty));
        (label, {arg with exp_type = instance arg.exp_type}) in
      let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list in
      let rec check_duplicates seen_pos lid_sexp lbl_exp =
        match (lid_sexp, lbl_exp) with
          ((lid, _) :: rem1, (lbl, _) :: rem2) ->
            if List.mem lbl.lbl_pos seen_pos
            then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
            else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
        | (_, _) -> () in
      check_duplicates [] lid_sexp_list lbl_exp_list;
      let opt_exp =
        match opt_sexp, lbl_exp_list with
          None, _ -> None
        | Some sexp, (lbl, _) :: _ ->
            let ty_exp = newvar () in
            let unify_kept lbl =
              if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
                  lbl_exp_list
              then begin
                let _, ty_arg1, ty_res1 = instance_label false lbl
                and _, ty_arg2, ty_res2 = instance_label false lbl in
                unify env ty_exp ty_res1;
                unify env ty ty_res2;
                unify env ty_arg1 ty_arg2
              end in
            Array.iter unify_kept lbl.lbl_all;
            Some(type_expect env sexp ty_exp)
        | _ -> assert false
      in
      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 sexp env ty in
        let rec missing_labels n = function
            [] -> []
          | lbl :: rem ->
              if List.mem n present_indices then missing_labels (n + 1) rem
              else lbl :: missing_labels (n + 1) rem
        in
        let missing = missing_labels 0 label_names in
        raise(Error(sexp.pexp_loc, Label_missing missing))
      end
      else if opt_sexp <> None && List.length lid_sexp_list = !num_fields then
        Location.prerr_warning sexp.pexp_loc Warnings.Useless_record_with;
      re {
        exp_desc = Texp_record(lbl_exp_list, opt_exp);
        exp_loc = sexp.pexp_loc;
        exp_type = ty;
        exp_env = env }
>>>>>>> 1.1.1.2.2.7
*)
  | Pexp_field(sarg, lid) ->
      (match sexp.pexp_ext with                                              (* XXO begin *)
      | Some v ->                                                         
        begin 
		  match (Obj.magic v).exp_desc with
		  | Texp_field (e,ld) ->           
			  let e' = type_exp env sarg   
			  in {(Obj.magic v) with exp_desc = Texp_field(e', ld); 
				  exp_type = instance (newvar ())}            
		  | _ -> fatal_error "typecore.ml: Texp_field expected"
		end
      | None ->                                                              (* XXO end*)
      let arg = type_exp env sarg in
      let label =
        try
          Env.lookup_label lid env
        with Not_found ->
          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;
      re {
        exp_desc = Texp_field(arg, label);
        exp_loc = sexp.pexp_loc;
        exp_type = ty_arg;
        exp_env = env } )
  | Pexp_setfield(srecord, lid, snewval) ->
      (match sexp.pexp_ext with                                          (* XXO begin *)
      | Some v ->                                                        
        begin match (Obj.magic v).exp_desc with                          
	| Texp_setfield (e1,ld,e2) ->                                        
	    let e1' = type_exp env srecord in                                
	    let e2' = type_exp env snewval                                   
	    in {(Obj.magic v) with exp_desc = Texp_setfield(e1',ld,e2'); 
			exp_type = instance (newvar ())}     (* XXO *)
	| _ -> fatal_error "typecore.ml: Texp_setfield expected"             
	end                                                                  (* XXO end *)
      | None ->                                                              
      let record = type_exp env srecord in
      let label =
        try
          Env.lookup_label lid env
        with Not_found ->
          raise(Error(sexp.pexp_loc, Unbound_label lid)) in
      if label.lbl_mut = Immutable then
        raise (Error(sexp.pexp_loc, Label_not_mutable lid));
      begin_def ();
      let (vars, ty_arg, ty_res) = instance_label true label in
      unify_exp env record ty_res;
      let newval = type_expect env snewval ty_arg in
      end_def ();
      if vars <> [] && not (is_nonexpansive newval) then
        generalize_expansive env newval.exp_type;
      check_univars env "field value" newval label.lbl_arg vars;
      if label.lbl_private = Private then
        raise(Error(sexp.pexp_loc, Private_label(lid, 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
      re {
        exp_desc = Texp_array argl;
        exp_loc = sexp.pexp_loc;
        exp_type = instance (Predef.type_array ty);
        exp_env = env }
  | Pexp_ifthenelse(scond, sifso, sifnot) ->
      let cond = type_expect env scond (instance Predef.type_bool) in
      begin match sifnot with
        None ->
          let ifso = type_expect env sifso (instance Predef.type_unit) in
          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
          re {
            exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
            exp_loc = sexp.pexp_loc;
            exp_type = ifso.exp_type;
            exp_env = env }
      end
  | Pexp_sequence(sexp1, sexp2) -> 
      let exp1 = type_statement env sexp1 in
      let exp2 = type_exp env sexp2 in
      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
      re {
        exp_desc = Texp_while(cond, body);
        exp_loc = sexp.pexp_loc;
        exp_type = instance Predef.type_unit;
        exp_env = env }
  | Pexp_for(param, slow, shigh, dir, sbody) ->
      let low  =  type_expect env slow (instance Predef.type_int) in
      let high =  type_expect env shigh (instance Predef.type_int) in
      let (id, new_env) =
        Env.enter_value param {val_type = instance Predef.type_int;
	                        val_level = !Typetexp.global_level;  (* XXO *)
                                val_kind = Val_reg} env in
      let body = type_statement new_env sbody in
      re {
        exp_desc = Texp_for(id, low, high, dir, body);
        exp_loc = sexp.pexp_loc;
        exp_type = instance Predef.type_unit;
        exp_env = env }
  | Pexp_constraint(sarg, sty, sty') ->
      let (arg, ty') =
        match (sty, sty') with
          (None, None) ->               (* Case actually unused *)
            let arg = type_exp env sarg in
            (arg, arg.exp_type)
        | (Some sty, None) ->
            if !Clflags.principal then begin_def ();
            let ty = Typetexp.transl_simple_type env false sty in
            if !Clflags.principal then begin
              end_def ();
              generalize_structure ty;
              let ty1 = instance ty and ty2 = instance ty in
              (type_expect env sarg ty1, ty2)
            end else
              (type_expect env sarg ty, ty)
        | (None, Some sty') ->
            let (ty', force) =
              Typetexp.transl_simple_type_delayed env sty'
            in
            let arg = type_exp env sarg in
            begin match arg.exp_desc, !self_coercion, (repr ty').desc with
              Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
              Tconstr(path',_,_) when Path.same path path' ->
                r := sexp.pexp_loc :: !r;
                force ()
            | _ ->
                let ty, b = enlarge_type env ty' in
                force ();
                begin try Ctype.unify env arg.exp_type ty with Unify trace ->
                  raise(Error(sarg.pexp_loc,
                        Coercion_failure(ty', full_expand env ty', trace, b)))
                end
            end;
            (arg, ty')
        | (Some sty, Some sty') ->
            let (ty, force) =
              Typetexp.transl_simple_type_delayed env sty
            and (ty', force') =
              Typetexp.transl_simple_type_delayed env sty'
            in
            begin try
              let force'' = subtype env ty ty' in
              force (); force' (); force'' ()
            with Subtype (tr1, tr2) ->
              raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
            end;
            (type_expect env sarg ty, ty')
      in
      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
      re {
        exp_desc = Texp_when(cond, body);
        exp_loc = sexp.pexp_loc;
        exp_type = body.exp_type;
        exp_env = env }
  | Pexp_send (e, met) ->
      if !Clflags.principal then begin_def ();
      let obj = type_exp env e in
      begin try
        let (exp, typ) =
          match obj.exp_desc with
            Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
              let (id, typ) =
                filter_self_method env met Private meths privty
              in
              if (repr typ).desc = Tvar then
                Location.prerr_warning sexp.pexp_loc
                  (Warnings.Undeclared_virtual_method met);
              (Texp_send(obj, Tmeth_val id), typ)
          | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
              let method_id =
                begin try List.assoc met methods with Not_found ->
                  raise(Error(e.pexp_loc, Undefined_inherited_method met))
                end
              in
              begin match
                Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
                Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
              with
                (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
                (path, _) ->
                  let (_, typ) =
                    filter_self_method env met Private meths privty
                  in
                  let method_type = newvar () in
                  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,
                                                     {val_type = method_type;
						       val_level = [];    (* XXO *)
                                                       val_kind = Val_reg});
                                exp_loc = sexp.pexp_loc;
                                exp_type = method_type;
                                exp_env = env },
                              [Some {exp_desc = Texp_ident(path, desc);
                                     exp_loc = obj.exp_loc;
                                     exp_type = desc.val_type;
                                     exp_env = env },
                               Required]),
                   typ)
              |  _ ->
                  assert false
              end
          | _ ->
              (Texp_send(obj, Tmeth_name met),
               filter_method env met Public obj.exp_type)
        in
        if !Clflags.principal then begin
          end_def ();
          generalize_structure typ;
        end;
        let typ =
          match repr typ with
            {desc = Tpoly (ty, [])} ->
              instance ty
          | {desc = Tpoly (ty, tl); level = l} ->
              if !Clflags.principal && l <> generic_level then
                Location.prerr_warning sexp.pexp_loc
                  (Warnings.Not_principal "this use of a polymorphic method");
              snd (instance_poly false tl ty)
          | {desc = Tvar} as ty ->
              let ty' = newvar () in
              unify env (instance ty) (newty(Tpoly(ty',[])));
              (* if not !Clflags.nolabels then
                 Location.prerr_warning loc (Warnings.Unknown_method met); *)
              ty'
          | _ ->
              assert false
        in
          re {
            exp_desc = exp;
            exp_loc = sexp.pexp_loc;
            exp_type = typ;
            exp_env = env }
      with Unify _ ->
        raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
      end
  | Pexp_new cl ->
      (match sexp.pexp_ext with                                              (* XXO *)
      | Some v ->                                                            (* XXO *)
        begin match (Obj.magic v).exp_desc with                              (* XXO *)
	| Texp_new _ -> {(Obj.magic v) with exp_type = instance (newvar ())}         (* XXO *)
	| _ -> fatal_error "typecore.ml: Texp_new expected"                  (* XXO *)
	end                                                                  (* XXO *)
      | None ->                                                              (* XXO *)
      let (cl_path, cl_decl) =
        try Env.lookup_class cl env with Not_found ->
          raise(Error(sexp.pexp_loc, Unbound_class cl))
      in
        begin match cl_decl.cty_new with
          None ->
            raise(Error(sexp.pexp_loc, Virtual_class cl))
        | Some ty ->
            re {
              exp_desc = Texp_new (cl_path, cl_decl);
              exp_loc = sexp.pexp_loc;
              exp_type = instance ty;
              exp_env = env }
        end)
  | Pexp_setinstvar (lab, snewval) ->
      let _ = if !Typetexp.global_level != [] then                (* XXO *)
         raise (Error (sexp.pexp_loc, 
					   Internal_error "Setinstvar not supported in code.")) in  (* XXO *)
      begin try
        let (path, desc) = Env.lookup_value (Longident.Lident lab) env in
        match desc.val_kind with
          Val_ivar (Mutable, cl_num) ->
            let newval = type_expect env snewval (instance desc.val_type) in
            let (path_self, _) =
              Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
            in
            re {
              exp_desc = Texp_setinstvar(path_self, path, newval);
              exp_loc = sexp.pexp_loc;
              exp_type = instance Predef.type_unit;
              exp_env = env }
        | Val_ivar _ ->
            raise(Error(sexp.pexp_loc, Instance_variable_not_mutable lab))
        | _ ->
            raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
      with
        Not_found ->
          raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
      end
  | Pexp_override lst ->
      let _ = if !Typetexp.global_level != [] then                (* XXO *)
         raise (Error (sexp.pexp_loc, Internal_error "Override not supported in code.")) in  (* XXO *)
      let _ = 
       List.fold_right
        (fun (lab, _) l ->
           if List.exists ((=) lab) l then
             raise(Error(sexp.pexp_loc,
                         Value_multiply_overridden lab));
           lab::l)
        lst
        [] in
      begin match
        try
          Env.lookup_value (Longident.Lident "selfpat-*") env,
          Env.lookup_value (Longident.Lident "self-*") env
        with Not_found ->
          raise(Error(sexp.pexp_loc, Outside_class))
      with
        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
        (path_self, _) ->
          let type_override (lab, snewval) =
            begin try
              let (id, _, ty) = Vars.find lab !vars in
              (Path.Pident id, type_expect env snewval (instance ty))
            with
              Not_found ->
                raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
            end
          in
          let modifs = List.map type_override lst in
          re {
            exp_desc = Texp_override(path_self, modifs);
            exp_loc = sexp.pexp_loc;
            exp_type = self_ty;
            exp_env = env }
      | _ ->
          assert false
      end
  | Pexp_letmodule(name, smodl, sbody) ->
      if !Typetexp.global_level != []                              (* XXO *)
        then raise (Error (sexp.pexp_loc, 
						   Internal_error "Letmodule not supported in code.")); (* XXO *)
      let ty = newvar() in
      Ident.set_current_time ty.level;
      let context = Typetexp.narrow () in
      let modl = !type_module env smodl in
      let (id, new_env) = Env.enter_module name modl.mod_type env in
      Ctype.init_def(Ident.current_time());
      Typetexp.widen context;
      let body = type_exp new_env sbody in
      (* Unification of body.exp_type with the fresh variable ty
         fails if and only if the prefix condition is violated,
         i.e. if generative types rooted at id show up in the
         type body.exp_type.  Thus, this unification enforces the
         scoping condition on "let module". *)
      begin try
        Ctype.unify new_env body.exp_type ty
      with Unify _ ->
        raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
      end;
      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 ();
         exp_env = env
       }
  | 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);
         exp_env = env;
       }
  | Pexp_object s ->
      let desc, sign, meths = !type_object env sexp.pexp_loc s in
      re {
        exp_desc = Texp_object (desc, sign, meths);
        exp_loc = sexp.pexp_loc;
        exp_type = sign.cty_self;
        exp_env = env;
      }
  | Pexp_poly _ ->
      assert false

and type_argument env sarg ty_expected' =
  (* ty_expected' may be generic *)
  let no_labels ty =
    let ls, tvar = list_labels env ty in
    not tvar && List.for_all ((=) "") ls
  in
  let ty_expected = instance ty_expected' in
  match expand_head env ty_expected', sarg with
  | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
      type_expect env sarg ty_expected
  | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
      (* apply optional arguments when expected type is "" *)
      (* we must be very careful about not breaking the semantics *)
      if !Clflags.principal then begin_def ();
      let texp = type_exp env sarg in
      if !Clflags.principal then begin
        end_def ();
        generalize_structure texp.exp_type
      end;
      let rec make_args args ty_fun =
        match (expand_head env ty_fun).desc with
        | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
            make_args
              ((Some(option_none (instance ty_arg) sarg.pexp_loc), Optional)
               :: args)
              ty_fun
        | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
            args, ty_fun, no_labels ty_res'
        | Tvar ->  args, ty_fun, false
        |  _ -> [], texp.exp_type, false
      in
      let args, ty_fun', simple_res = make_args [] texp.exp_type in
      let warn = !Clflags.principal &&
        (lv <> generic_level || (repr ty_fun').level <> generic_level)
      and texp = {texp with exp_type = instance texp.exp_type}
      and ty_fun = instance ty_fun' in
      if not (simple_res || no_labels ty_res) then begin
        unify_exp env texp ty_expected;
        texp
      end else begin
      unify_exp env {texp with exp_type = ty_fun} ty_expected;
      if args = [] then texp else
      (* eta-expand to avoid side effects *)
      let var_pair name ty =
        let id = Ident.create name in
        {pat_desc = Tpat_var id; pat_type = ty;
         pat_loc = Location.none; pat_env = env},
        {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
         Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg; val_level=[]})}  (* XXO *)
      in
      let eta_pat, eta_var = var_pair "eta" ty_arg in
      let func texp =
        { texp with exp_type = ty_fun; exp_desc =
          Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
                                   Texp_apply (texp, args@
                                               [Some eta_var, Required])}],
                        Total) } in
      if warn then Location.prerr_warning texp.exp_loc
          (Warnings.Without_principality "eliminated optional argument");
      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
      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

and type_application env funct sargs =
  (* funct.exp_type may be generic *)
  let result_type omitted ty_fun =
    List.fold_left
      (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
      ty_fun omitted
  in
  let has_label l ty_fun =
    let ls, tvar = list_labels env ty_fun in
    tvar || List.mem l ls
  in
  let ignored = ref [] in
  let rec type_unknown_args args omitted ty_fun = function
      [] ->
        (List.map
           (function None, x -> None, x | Some f, x -> Some (f ()), x)
           (List.rev args),
         instance (result_type omitted ty_fun))
    | (l1, sarg1) :: sargl ->
        let (ty1, ty2) =
          let ty_fun = expand_head env ty_fun in
          match ty_fun.desc with
            Tvar ->
              let t1 = newvar () and t2 = newvar () in
              let not_identity = function
                  Texp_ident(_,{val_kind=Val_prim
                                  {Primitive.prim_name="%identity"}}) ->
                    false
                | _ -> true
              in
              if ty_fun.level >= t1.level && not_identity funct.exp_desc then
                Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
              unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
              (t1, t2)
          | Tarrow (l,t1,t2,_) when l = l1
            || !Clflags.classic && l1 = "" && not (is_optional l) ->
              (t1, t2)
          | td ->
              let ty_fun =
                match td with Tarrow _ -> newty td | _ -> ty_fun in
              let ty_res = result_type (omitted @ !ignored) ty_fun in
              match ty_res.desc with
                Tarrow _ ->
                  if (!Clflags.classic || not (has_label l1 ty_fun)) then
                    raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
                  else
                    raise(Error(funct.exp_loc, Incoherent_label_order))
              | _ ->
                  raise(Error(funct.exp_loc, Apply_non_function
                                (expand_head env funct.exp_type)))
        in
        let optional = if is_optional l1 then Optional else Required in
        let arg1 () =
          let arg1 = type_expect env sarg1 ty1 in
          if optional = Optional then
            unify_exp env arg1 (type_option(newvar()));
          arg1
        in
        type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl
  in
  let ignore_labels =
    !Clflags.classic ||
    begin
      let ls, tvar = list_labels env funct.exp_type in
      not tvar &&
      let labels = List.filter (fun l -> not (is_optional l)) ls in
      List.length labels = List.length sargs &&
      List.for_all (fun (l,_) -> l = "") sargs &&
      List.exists (fun l -> l <> "") labels &&
      (Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
       true)
    end
  in
  let warned = ref false in
  let rec type_args args omitted ty_fun ty_old sargs more_sargs =
    match expand_head env ty_fun with
      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
      when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
        let may_warn loc w =
          if not !warned && !Clflags.principal && lv <> generic_level
          then begin
            warned := true;
            Location.prerr_warning loc w
          end
        in
        let name = label_name l
        and optional = if is_optional l then Optional else Required in
        let sargs, more_sargs, arg =
          if ignore_labels && not (is_optional l) then begin
            (* In classic mode, omitted = [] *)
            match sargs, more_sargs with
              (l', sarg0) :: _, _ ->
                raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
            | _, (l', sarg0) :: more_sargs ->
                if l <> l' && l' <> "" then
                  raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
                else
                  ([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
            | _ ->
                assert false
          end else try
            let (l', sarg0, sargs, more_sargs) =
              try
                let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
                if sargs1 <> [] then
                  may_warn sarg0.pexp_loc
                    (Warnings.Not_principal "commuting this argument");
                (l', sarg0, sargs1 @ sargs2, more_sargs)
              with Not_found ->
                let (l', sarg0, sargs1, sargs2) =
                  extract_label name more_sargs in
                if sargs1 <> [] || sargs <> [] then
                  may_warn sarg0.pexp_loc
                    (Warnings.Not_principal "commuting this argument");
                (l', sarg0, sargs @ sargs1, sargs2)
            in
            sargs, more_sargs,
            if optional = Required || is_optional l' then
              Some (fun () -> type_argument env sarg0 ty)
            else begin
              may_warn sarg0.pexp_loc
                (Warnings.Not_principal "using an optional argument here");
              Some (fun () -> option_some (type_argument env sarg0 
                                             (extract_option_type env ty)))
            end
          with Not_found ->
            sargs, more_sargs,
            if optional = Optional &&
              (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
            then begin
              may_warn funct.exp_loc
                (Warnings.Without_principality "eliminated optional argument");
              ignored := (l,ty,lv) :: !ignored;
              Some (fun () -> option_none (instance ty) Location.none)
            end else begin
              may_warn funct.exp_loc
                (Warnings.Without_principality "commuted an argument");
              None
            end
        in
        let omitted =
          if arg = None then (l,ty,lv) :: omitted else omitted in
        let ty_old = if sargs = [] then ty_fun else ty_old in
        type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
    | _ ->
        match sargs with
          (l, sarg0) :: _ when ignore_labels ->
            raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
        | _ ->
            type_unknown_args args omitted (instance ty_fun)
              (sargs @ more_sargs)
  in
  match funct.exp_desc, sargs with
    (* Special case for ignore: avoid discarding warning *)
    Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
    ["", sarg] ->
      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) "" in
      let exp = type_expect env sarg ty_arg in
      begin match (expand_head env exp.exp_type).desc with
      | Tarrow _ ->
          Location.prerr_warning exp.exp_loc Warnings.Partial_application
      | Tvar ->
          add_delayed_check (fun () -> check_partial_application env exp)
      | _ -> ()
      end;
      ([Some exp, Required], ty_res)
  | _ ->
      let ty = funct.exp_type in
      if ignore_labels then
        type_args [] [] ty ty [] sargs
      else
        type_args [] [] ty ty sargs []

(* From here ===================================== XXO *)
and type_destruct env loc lid sarg ty_expected er vo =
  match vo with     
  | Some v -> begin 
      match (Obj.magic v).exp_desc with
      | Texp_destruct (cd,el,ertag) -> 
          let arg = type_exp env sarg in
		  if er <> ertag 
		  then raise 
			  (Error(loc,Internal_error "Mismatch on tags in type_destruct. Should not occur"));
		  if (!te_flag) && (er == Erase) 
		  then 
			let rec newtypes n = if n = 1 then [newvar()] else (newvar())::(newtypes (n-1)) in
			let getrestype args = 
			  match args with
			  | [] -> raise (Error(loc, Internal_error "Destructor should not be called on nullary constructors."))
			  |	[arg1] -> arg1
			  |	_ -> newty(Ttuple args) in
            let args = newtypes (cd.cstr_arity) in
			let res = getrestype args in
			let arg_type = newty(Tannotation(lid,args, newvar())) in
			unify_exp env arg arg_type;
			{ (Obj.magic v) with
			  exp_desc = Texp_destruct(cd, {arg with exp_type=arg_type},er);
			  exp_type = res }
		  else 
			begin 
			  unify_exp env arg el.exp_type; 
			  {(Obj.magic v) with exp_desc = Texp_destruct(cd,arg,er)}
			end
      | _ -> raise(Error(loc, Internal_error "Mismatch with pexp_ext in type_destruct."))
  end
  | None  -> 
      let constr = try Env.lookup_constructor lid env 
	               with Not_found -> raise(Error(loc, Unbound_constructor lid)) in
      let (ty_res, ty_arg) = instance_constructor constr in
      let arg = type_exp env sarg in
      let lenres = constr.cstr_arity in
      let res = 
		if lenres = 1 
		then 
		  match ty_res with 
		  | [tyres] -> tyres
		  | _ -> raise(Error(loc, Internal_error "Number of result types disagree in destructors."))
		else newty(Ttuple(ty_res)) in
	  if !Typetexp.global_level != [] 
	  then  
		begin 
		  unify_exp env arg ty_arg; 
		  let texp =
			{ exp_desc = Texp_destruct (constr, arg,er);
			  exp_loc = loc; exp_type = res; exp_env = env} in
		  unify_exp env texp ty_expected;
		  texp
		end
	  else
		begin
		  unify_exp env arg ty_arg;
          let funct = gendestr lenres lid er loc in
		  let tfunct = type_expect env funct (newty (Tarrow("",ty_arg,res,Cok))) in
          let texp =
			{ exp_desc = Texp_apply (tfunct, [(Some arg, Required)]);
			  exp_loc = loc; exp_type = res; exp_env = env } in
		  unify_exp env texp ty_expected;
		  texp
		end
		  
(* To here ======================================= XXO *)





and type_construct env loc lid sarg explicit_arity ty_expected er vo =  (* XXO *)
  match vo with     (* XXO *)
  | Some v -> 
	  begin 
		match (Obj.magic v).exp_desc with
		| Texp_construct (cd,el,Erase) ->
            let sargs =               
              match sarg with
              | None -> []
              | Some {pexp_desc = Pexp_tuple sel} when cd.cstr_arity > 1 -> sel 
              | Some se -> [se] in
			let args = List.map (type_exp env) sargs in
			if (!te_flag) 
		    then 
			  let argtys = List.map (fun x -> x.exp_type) args in
		      { exp_desc = Texp_construct(cd, args,Erase);
				exp_loc = (Obj.magic v).exp_loc;     
				exp_type = newty(Tannotation(lid, argtys,(Obj.magic v).exp_type));
				exp_env = (Obj.magic v).exp_env}
			else {(Obj.magic v) with exp_desc = Texp_construct(cd,args,Erase)}
		| Texp_construct (cd,el,Keep ) -> 
			let sargs =               
              match sarg with
              | None -> []
              | Some {pexp_desc = Pexp_tuple sel} when cd.cstr_arity > 1 -> sel 
              | Some se -> [se] in
			let args = List.map (type_exp env) sargs in
			{(Obj.magic v) with exp_desc = Texp_construct(cd,args,Keep)}
	    | _ -> raise (Error(loc,Internal_error "Mismatch in type_construct"))
	  end  
  | None ->                                                                  (* XXO *)
	  let constr =  try Env.lookup_constructor lid env with
	  | Not_found -> raise(Error(loc, Unbound_constructor lid)) in
	  let sargs =
		match sarg with
		  None -> []
		| Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
			  (* Emir: Missing case v.s. old. Check carefully. *) 
		| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
		| Some se -> [se] 
	  in if List.length sargs <> constr.cstr_arity then 
		raise (Error(loc, Constructor_arity_mismatch (lid, constr.cstr_arity, List.length sargs)));
	  if !Clflags.principal then begin_def ();
	  let (ty_args, ty_res) = instance_constructor constr in
	  if !Clflags.principal then 
		begin
		  end_def ();
		  List.iter generalize_structure ty_args;
		  generalize_structure ty_res
		end;

	  if !te_flag  && (er == Erase) (* XXO *)
	  then                                               
		let args = List.map2 (type_argument env) sargs ty_args in
(*		let argtyps = List.map (fun x -> x.exp_type) args in  *)
		let texp =
		  { exp_desc = Texp_construct(constr, args,er); exp_loc = loc; exp_env = env; 
			exp_type = newty(Tannotation(lid,ty_args,ty_res))}
		in unify_exp env texp ty_expected; texp
	  else 
		let texp = re 
		  { exp_desc = Texp_construct(constr, [] ,er); 
			exp_loc = loc; 
			exp_env = env;
			exp_type = instance ty_res } in
		unify_exp env texp ty_expected;
		let args = List.map2 (type_argument env) sargs ty_args in
		if constr.cstr_private = Private then
		  raise(Error(loc, Private_type ty_res));
		{ texp with exp_desc = Texp_construct(constr, args,er) } 
    
(* Typing of an expression with an expected type.
   Some constructs are treated specially to provide better error messages. *)

and type_expect ?in_function env sexp ty_expected =
  match sexp.pexp_desc with
    Pexp_constant(Const_string s as cst) ->
      let exp =
        re {
          exp_desc = Texp_constant cst;
          exp_loc = sexp.pexp_loc;
          exp_type =
            (* Terrible hack for format strings *)
            begin match (repr (expand_head env ty_expected)).desc with
              Tconstr(path, _, _) when Path.same path Predef.path_format4 ->
                type_format sexp.pexp_loc s
            | _ -> instance Predef.type_string
            end;
          exp_env = env } in
      unify_exp env exp ty_expected;
      exp
  | Pexp_destruct(lid, sarg,er) -> (* XXO *)
      type_destruct env sexp.pexp_loc lid sarg ty_expected er sexp.pexp_ext 
  | Pexp_construct(lid, sarg, explicit_arity,er) ->
      type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected er sexp.pexp_ext
  | 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
      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
      re {
        exp_desc = Texp_sequence(exp1, exp2);
        exp_loc = sexp.pexp_loc;
        exp_type = exp2.exp_type;
        exp_env = env }
  | Pexp_function (l, Some default, [spat, sbody]) ->
      let loc = default.pexp_loc in
      let scases =
        [{ppat_loc = loc; ppat_desc =
          Ppat_construct(Longident.Lident"Some",
                         Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"; ppat_ext = None}, (* XXO *)
                         false); ppat_ext = None},                                           (* XXO *)
         {pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*"); pexp_ext = None}; (* XXO *)
         {ppat_loc = loc; ppat_desc =
          Ppat_construct(Longident.Lident"None", None, false); ppat_ext = None},             (* XXO *)
         default] in
      let smatch =
        {pexp_loc = loc; pexp_desc =
         Pexp_match({pexp_loc = loc; pexp_desc =
                     Pexp_ident(Longident.Lident"*opt*"); pexp_ext = None},  (* XXO *)
                    scases); pexp_ext = None} in                             (* XXO *)
      let sfun =
        {pexp_loc = sexp.pexp_loc; pexp_desc =
         Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"; ppat_ext = None}, (* XXO *)
                                {pexp_loc = sexp.pexp_loc; pexp_desc =
                                 Pexp_let(Default, [spat, smatch], sbody); pexp_ext = None}]);  (* XXO *)
				            pexp_ext = None}                                    (* XXO *)
      in
      type_expect ?in_function env sfun ty_expected
  | Pexp_function (l, _, caselist) ->
      let (loc, ty_fun) =
        match in_function with Some p -> p
        | None -> (sexp.pexp_loc, ty_expected)
      in
      let (ty_arg, ty_res) =
        try filter_arrow env ty_expected l
        with Unify _ ->
          match expand_head env ty_expected with
            {desc = Tarrow _} as ty ->
              raise(Error(sexp.pexp_loc, Abstract_wrong_label(l, ty)))
          | _ ->
              raise(Error(loc,
                          Too_many_arguments (in_function <> None, ty_fun)))
      in
      if is_optional l then begin
        try unify env ty_arg (type_option(newvar()))
        with Unify _ -> assert false
      end;
      let cases, partial =
        type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res
          (Some sexp.pexp_loc) caselist in
      let all_labeled ty =
        let ls, tvar = list_labels env ty in
        not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls)
      in
      if is_optional l && all_labeled ty_res then
        Location.prerr_warning (fst (List.hd cases)).pat_loc
          Warnings.Unerasable_optional_argument;
      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 }
  | Pexp_poly(sbody, sty) ->
      let ty =
        match sty with None -> repr ty_expected
        | Some sty ->
            let ty = Typetexp.transl_simple_type env false sty in
            repr ty
      in
      let set_type ty =
        unify_exp env
          { exp_desc = Texp_tuple []; exp_loc = sexp.pexp_loc;
            exp_type = ty; exp_env = env } ty_expected in
      begin
        match ty.desc with
          Tpoly (ty', []) ->
            if sty <> None then set_type ty;
            let exp = type_expect env sbody ty' in
            re { exp with exp_type = ty }
        | Tpoly (ty', tl) ->
            if sty <> None then set_type ty;
            (* One more level to generalize locally *)
            begin_def ();
            let vars, ty'' = instance_poly true tl ty' in
            let exp = type_expect env sbody ty'' in
            end_def ();
            check_univars env "method" exp ty_expected vars;
            re { exp with exp_type = ty }
        | _ -> assert false
      end
  | _ ->
      let exp = type_exp env sexp in
      unify_exp env exp ty_expected;
      exp

(* Typing of statements (expressions whose values are discarded) *)

and type_statement env sexp =
  begin_def();
  let exp = type_exp env sexp in
  end_def();
  let ty = expand_head env exp.exp_type and tv = newvar() in
  begin match ty.desc with
  | Tarrow _ ->
      Location.prerr_warning sexp.pexp_loc Warnings.Partial_application
  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
  | Tvar when ty.level > tv.level ->
      Location.prerr_warning sexp.pexp_loc Warnings.Nonreturning_statement
  | Tvar ->
      add_delayed_check (fun () -> check_partial_application env exp)
  | _ ->
      Location.prerr_warning sexp.pexp_loc Warnings.Statement_type
  end;
  unify_var env tv ty;
  exp

(* Typing of match cases *)

and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
  let ty_arg' = newvar () in
  let pattern_force = ref [] in
  let pat_env_list =
    List.map
      (fun (spat, sexp) ->
        if !Clflags.principal then begin_def ();
        let (pat, ext_env, force) = type_pattern env spat in
        pattern_force := force @ !pattern_force;
        let pat =
          if !Clflags.principal then begin
            end_def ();
            iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
            { pat with pat_type = instance pat.pat_type }
          end else pat
        in
        unify_pat env pat ty_arg';
        (pat, ext_env))
      caselist in
  (* Check for polymorphic variants to close *)
  let patl = List.map fst pat_env_list in
  if List.exists has_variants patl then begin
    Parmatch.pressure_variants env patl;
    List.iter (iter_pattern finalize_variant) patl
  end;
  (* `Contaminating' unifications start here *)
  List.iter (fun f -> f()) !pattern_force;
  begin match pat_env_list with [] -> ()
  | (pat, _) :: _ -> unify_pat env pat ty_arg
  end;
  let in_function = if List.length caselist = 1 then in_function else None in
  let cases =
    List.map2
      (fun (pat, ext_env) (spat, sexp) ->
        let exp = type_expect ?in_function ext_env sexp ty_res in
        (pat, exp))
      pat_env_list caselist
  in
  let partial =
    match partial_loc with None -> Partial
    | Some loc -> Parmatch.check_partial loc cases
  in
  add_delayed_check (fun () -> Parmatch.check_unused env cases);
  cases, partial

(* Typing of let bindings *)

and type_let env rec_flag spat_sexp_list =
  begin_def();
  if !Clflags.principal then begin_def ();
  let (pat_list, new_env, force) = type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
  in
  if rec_flag = Recursive then
    List.iter2
      (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
      pat_list spat_sexp_list;
  let pat_list =
    if !Clflags.principal then begin
      end_def ();
      List.map
        (fun pat ->
          iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
          {pat with pat_type = instance pat.pat_type})
        pat_list
    end else pat_list in
  (* Polymoprhic variant processing *)
  List.iter
    (fun pat ->
      if has_variants pat then begin
        Parmatch.pressure_variants env [pat];
        iter_pattern finalize_variant pat
      end)
    pat_list;
  (* Only bind pattern variables after generalizing *)
  List.iter (fun f -> f()) force;
  let exp_env =
    match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
  let exp_list =
	List.map2
      (fun (spat, sexp) pat -> type_expect exp_env sexp pat.pat_type)
      spat_sexp_list pat_list in
  List.iter2
    (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
    pat_list exp_list;
  end_def();
  List.iter2
    (fun pat exp ->
       if not (is_nonexpansive exp) then
         iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
    pat_list exp_list;
  List.iter
    (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
    pat_list;
  (List.combine pat_list exp_list, new_env)

(* Typing of toplevel bindings *)

let type_binding env rec_flag spat_sexp_list =
  Typetexp.reset_type_variables();
  type_let env rec_flag spat_sexp_list

(* Typing of toplevel expressions *)

let type_expression env sexp =
  Typetexp.reset_type_variables();
  begin_def();
  let exp = type_exp env sexp in
  end_def();
  if is_nonexpansive exp then generalize exp.exp_type
  else generalize_expansive env exp.exp_type;
  exp

(* Error report *)


open Format
open Printtyp
open Printast (* XXO *)
let report_error ppf = function
  | Unbound_value lid ->
      fprintf ppf "Unbound value %a" longident lid
  | Unbound_constructor lid ->
      fprintf ppf "Unbound constructor %a" longident lid
  | Unbound_label lid ->
      fprintf ppf "Unbound record field label %a" longident lid
  | Constructor_arity_mismatch(lid, expected, provided) ->
      fprintf ppf
       "@[The constructor %a@ expects %i argument(s),@ \
        but is here applied to %i argument(s)@]"
       longident lid expected provided
  | Label_mismatch(lid, trace) ->
      report_unification_error ppf trace
        (function ppf ->
           fprintf ppf "The record field label %a@ belongs to the type"
                   longident lid)
        (function ppf ->
           fprintf ppf "but is here mixed with labels of type")
  | Pattern_type_clash trace ->
      report_unification_error ppf trace
        (function ppf ->
           fprintf ppf "This pattern matches values of type")
        (function ppf ->
           fprintf ppf "but is here used to match values of type")
  | Multiply_bound_variable ->
      fprintf ppf "This variable is bound several times in this matching"
  | Orpat_vars id ->
      fprintf ppf "Variable %s must occur on both sides of this | pattern"
        (Ident.name id)
  | Expr_type_clash trace ->
      report_unification_error ppf trace
        (function ppf ->
           fprintf ppf "This expression has type")
        (function ppf ->
           fprintf ppf "but is here used with type")
  | Apply_non_function typ ->
      begin match (repr typ).desc with
        Tarrow _ ->
          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"
      end
  | Apply_wrong_label (l, ty) ->
      let print_label ppf = function
        | "" -> fprintf ppf "without label"
        | l ->
            fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l
      in
      reset_and_mark_loops ty;
      fprintf ppf
        "@[<v>@[<2>Expecting function has type@ %a@]@.\
          This argument cannot be applied %a@]"
        type_expr ty print_label l
  | Label_multiply_defined lid ->
      fprintf ppf "The record field label %a is defined several times"
              longident lid
  | Label_missing labels ->
      let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in
      fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
        print_labels labels
  | Label_not_mutable lid ->
      fprintf ppf "The record field label %a is not mutable" longident lid
  | Incomplete_format s ->
      fprintf ppf "Premature end of format string ``%S''" s
  | Bad_conversion (fmt, i, c) ->
      fprintf ppf
        "Bad conversion %%%c, at char number %d \
         in format string ``%s''" c i fmt
  | Undefined_method (ty, me) ->
      reset_and_mark_loops ty;
      fprintf ppf
        "@[<v>@[This expression has type@;<1 2>%a@]@,\
         It has no method %s@]" type_expr ty me
  | Undefined_inherited_method me ->
      fprintf ppf "This expression has no method %s" me
  | Unbound_class cl ->
      fprintf ppf "Unbound class %a" longident cl
  | Virtual_class cl ->
      fprintf ppf "One cannot create instances of the virtual class %a"
        longident cl
  | Unbound_instance_variable v ->
      fprintf ppf "Unbound instance variable %s" v
  | Instance_variable_not_mutable v ->
      fprintf ppf "The instance variable %s is not mutable" v
  | Not_subtype(tr1, tr2) ->
      report_subtyping_error ppf tr1 "is not a subtype of type" tr2
  | Outside_class ->
      fprintf ppf "This object duplication occurs outside a method definition"
  | Value_multiply_overridden v ->
      fprintf ppf "The instance variable %s is overridden several times" v
  | Coercion_failure (ty, ty', trace, b) ->
      report_unification_error ppf trace
        (function ppf ->
           let ty, ty' = prepare_expansion (ty, ty') in
           fprintf ppf
             "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
           (type_expansion ty) ty')
        (function ppf ->
           fprintf ppf "but is here used with type");
      if b then
        fprintf ppf ".@.@[<hov>%s@ %s@]"
          "This simple coercion was not fully general."
          "Consider using a double coercion."
  | Too_many_arguments (in_function, ty) ->
      reset_and_mark_loops ty;
      if in_function then begin
        fprintf ppf "This function expects too many arguments,@ ";
        fprintf ppf "it should have type@ %a"
          type_expr ty
      end else begin
        fprintf ppf "This expression should not be a function,@ ";
        fprintf ppf "the expected type is@ %a"
          type_expr ty
      end
  | Abstract_wrong_label (l, ty) ->
      let label_mark = function
        | "" -> "but its first argument is not labeled"
        |  l -> sprintf "but its first argument is labeled ~%s" l in
      reset_and_mark_loops ty;
      fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
      type_expr ty (label_mark l)
  | Scoping_let_module(id, ty) ->
      reset_and_mark_loops ty;
      fprintf ppf
       "This `let module' expression has type@ %a@ " type_expr ty;
      fprintf ppf
       "In this type, the locally bound module name %s escapes its scope" id
  | Masked_instance_variable lid ->
      fprintf ppf
        "The instance variable %a@ \
         cannot be accessed from the definition of another instance variable"
        longident lid
  | Private_type ty ->
      fprintf ppf "Cannot create values of the private type %a" type_expr ty
  | Private_label (lid, ty) ->
      fprintf ppf "Cannot assign field %a of the private type %a"
        longident lid type_expr ty
  | Not_a_variant_type lid ->
      fprintf ppf "The type %a@ is not a variant type" longident lid
  | Incoherent_label_order ->
      fprintf ppf "This function is applied to arguments@ ";
      fprintf ppf "in an order different from other calls.@ ";
      fprintf ppf "This is only allowed when the real type is known."
  | Less_general (kind, trace) ->
      report_unification_error ppf trace
        (fun ppf -> fprintf ppf "This %s has type" kind)
        (fun ppf -> fprintf ppf "which is less general than")
(* Walid: Do we need new lines at the end? *)
  | Wrong_level (n,m) -> 
      begin 
		match (m,n) with
		| [],[] -> fprintf ppf "Wrong level: escape at level 0"
		| _,_   -> fprintf ppf "Wrong level: variable bound at level %d and used at level %d" 
			  (List.length n) (List.length m)  
	  end     (* XXO *)
  | Run_occur_check (t1,t2) ->   (* XXO *)
      reset_and_mark_loops t1;   (* XXO *)
      reset_and_mark_loops t2;   (* XXO *)
      fprintf ppf ".! occurs check error: %a occurs in %a"  type_expr t1 type_expr t2 (* XXO *)  
  | Run_alpha_not_generalizable (t1,t2) ->                                           (* XXO *)
      reset_and_mark_loops t1;                                                           (* XXO *)
      reset_and_mark_loops t2;                                                           (* XXO *)
      fprintf ppf ".! error: %a not generalizable in %a\n"  type_expr t1 type_expr t2   (* XXO *)
  | Not_constructed_type _ -> fprintf ppf "not constructed type\n"; assert false                     (* XXO *)
  | Type_mismatch _   -> fprintf ppf "Type mismatch\n"; assert false              (* XXO *)
  | Ill_ident_for_type _  -> fprintf ppf "Illegal  identifier for type\n"; assert false        (* XXO *)
  | Illegal_etag_program _  -> fprintf ppf "Illegal etag program\n"; assert false    (* XXO *)
  | Illegal_etag_erasure -> fprintf ppf "Illegal etag erasure\n"; assert false       (* XXO *)
  | Unmatched_type_expression -> fprintf ppf "Unmatched type expression\n"; assert false                 (* XXO *)
  | Unbound_type_constructor -> fprintf ppf "Unbound type constructor\n"; assert false (* XXO *)
  | Internal_error str -> fprintf ppf "Metaocaml internal error in type checking. Message:\n\t %s\n" str; assert false
(* From here ============================ XXO *)
let etag_handler sexp satype unsexp env =
    let atype = Typetexp.transl_annot_type env true satype in
    let _ = if !Clflags.debug_messages 
	        then Format.fprintf Format.std_formatter "In etag_handler @ %a @ \n"
	    Printtyp.type_expr atype in
    let _ = set_TE_flag() in
    try 
      let exp = type_exp env sexp in 
      if (sametype env exp atype) 
      then (unset_TE_flag (); erasure_exp sexp)
      else (unset_TE_flag (); unsexp)
    with   Error (_,err) -> (
      if !Clflags.debug_messages then
		(Printf.printf "Tag analysis failed [etag_handler]. \n The error is printed below:\n";
		 report_error Format.std_formatter err;
		 Format.pp_print_newline Format.std_formatter ();
		 Format.pp_print_flush Format.std_formatter ());
      unset_TE_flag(); unsexp) 


let build_destr constr  lid env erase loc  =
    let pfun = gendestr (constr.cstr_arity) lid erase loc in
    let tfun = type_expression env pfun in
    tfun


(* Walid: Is there a better way of doing this? *)
let build_destr_match what constr  lid env erase loc  =
  let count = ref 0 in
  let vars = gen_vars constr.cstr_arity count in
  let (pat,expr) = gencontent vars constr.cstr_arity loc in
  let dummy = newexp (Pexp_assertfalse) loc in
  let result = newexp 
      (Pexp_match (dummy, 
			 [newpat (Ppat_construct(lid, Some pat, false)) loc, expr])) loc in 
  let tmatch = type_expression env result in
  match tmatch with 
  | { exp_desc = Texp_match (dummy, ps, flg) } -> 
      { tmatch with exp_desc = Texp_match (what, ps, flg)}
  | _ -> assert false
  




(* To here ============================ XXO *)

