(* Hyunjun Eo

 Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System
 (National Creative Research Initiative Center 1998-2003)
 http://ropas.snu.ac.kr/n

 All rights reserved. This file is distributed under the terms of
 an Open Source License.
*)

(* Based on Objective Caml Code                            *)

open Asttypes
open Parsetree
open Longident
open String_ast.Ast

type convert_error = Refpat | Recordty | Valdec | Recvaldec | Fundec

exception NoLongIdent
exception NotConvertible of string * Location.t
exception Error of Location.t * convert_error

let nloc = Location.none

let report_error err =
  match err with
    Refpat -> print_string "ref pattern is not allowed."
  | Recordty -> print_string "record type has to be named."
  | Valdec -> print_string "val declaration with type variable."
  | Recvaldec -> print_string "val rec declaration with type variable."
  | Fundec -> print_string "fun declaration with type variable."

(* for data constructor *)

let con_count = ref (-1)
let new_con_ty () = (incr con_count; "@con_"^(string_of_int !con_count))

let rec make_variance n = 
  match n with
    0 -> []
  | i -> (false, false)::(make_variance (i-1))

let make_type' params kind manifest =
  {ptype_params = params; ptype_cstrs = [];
   ptype_kind = kind; ptype_manifest = manifest;
   ptype_variance = make_variance (List.length params);
   ptype_loc = Location.none} 

let make_type t p =
  match p with
    None -> []
  | Some (tn,tt) -> [tn, make_type' t Ptype_abstract (Some(tt))]

(* for desc, loc *)

let mktyp typ loc =
      { ptyp_desc = typ ;
        ptyp_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mkfield field loc =
      { pfield_desc = field ;
        pfield_loc = { Location.loc_start = loc.Location.loc_start;
                       Location.loc_end = loc.Location.loc_end;
                       Location.loc_ghost = false }}
let mkpat pat loc =
      { ppat_desc = pat ;
        ppat_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mkexp exp loc =
      { pexp_desc = exp ;
        pexp_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mkmty mty loc =
      { pmty_desc = mty ;
        pmty_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mksig signat loc =
      { psig_desc = signat ;
        psig_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mkmod modul loc =
      { pmod_desc = modul ;
        pmod_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}
let mkstr str loc =
      { pstr_desc = str ;
        pstr_loc = { Location.loc_start = loc.Location.loc_start;
                     Location.loc_end = loc.Location.loc_end;
                     Location.loc_ghost = false }}

(* expansive *)
let rec app2 f (_,e,_) = f e

let rec expansive e =
  match e with
    UnitExp(_) | IntExp(_,_) | RealExp(_,_) | StringExp(_,_) | CharExp(_,_)
  | VarExp(_,_) | ConExp(_,_) -> false
  | RecordFieldExp(e,_,_) -> expansive e
  | ArrayFieldExp(e1,e2,_) -> (expansive e1) or (expansive e2)
(*
  | UpdateArrayExp(e1,e2,e3,_) ->
      (expansive e1) or (expansive e2) or (expansive e3)
*)
  | SubstRecordExp(e1,_,e2,_) -> (expansive e1) or (expansive e2)
  | RaiseExp(e,_) -> expansive e
(*
  | AssignExp(e1,e2,_) -> (expansive e1) or (expansive e2)
*)
  | RefExp(e,_) -> expansive e
  | DeRefExp(e,_) -> expansive e
  | LetExp(_,e,_) -> expansive e
  | IfExp(e1,e2,e3,_) ->
      (expansive e1) or (expansive e2) or (expansive e3)
  | WhileExp(e1,e2,_) -> (expansive e1) or (expansive e2)
  | ForExp(_,e1,e2,e3,e4,_) ->
      (expansive e1) or (expansive e2) or (expansive e3) or (expansive e4)
  | ConstraintExp(e,_,_) -> expansive e
  | SeqExp(el,_) -> List.fold_left (fun x y -> x or (expansive y)) false el
  | TupleExp(el,_) -> List.fold_left (fun x y -> x or (expansive y)) false el
  | ListExp(el,_) -> List.fold_left (fun x y -> x or (expansive y)) false el
  | ArrayExp(el,_) -> List.fold_left (fun x y -> x or (expansive y)) false el
  | RecordExp(lel,_) ->
      List.fold_left (fun x y -> x or (app2 expansive y)) false lel
  | CaseExp(e,rl,_) -> (expansive e) or
      (List.fold_left (fun x y -> x or (app2 expansive y)) false rl)
  | HandleExp(e,rl,_) -> (expansive e) or
      (List.fold_left (fun x y -> x or (app2 expansive y)) false rl)
  | FnExp(fnrl,_) ->
      List.fold_left (fun x y -> x or (app2 expansive y)) false fnrl
  | _ -> true

let local_count = ref 0
let new_local () = (incr local_count; "@local_"^(string_of_int (!local_count)))

let abstype_count = ref 0
let new_abstype () =
  (incr abstype_count; "@abstype_"^(string_of_int (!abstype_count)))

module OrdString = struct type t = string
                          let compare x y = if x<y then -1
                                            else if x=y then 0 else 1
                   end
module LocalTable = Map.Make (OrdString)

let local_table = ref (LocalTable.empty )

let local_table_find local1 =
  try LocalTable.find local1 (!local_table)
  with Not_found -> []

let clear_local_table local1 =
  local_table := LocalTable.add local1 [] (!local_table)

let update_local_table local1 l =
  local_table := LocalTable.add local1
                                (l::(local_table_find local1))
                                (!local_table)

let rec update_local_table_labpat local1 ((l,_), p, _) =
  update_local_table_pat local1 p

and update_local_table_pat local1 p =
  let update_local_table' = update_local_table local1 in
  let update_local_table_pat' = update_local_table_pat local1 in
  let update_local_table_labpat' = update_local_table_labpat local1 in
  match p with
    RecordPat (l,loc) -> List.iter update_local_table_labpat' l
  | SubRecordPat (l,loc) -> List.iter update_local_table_labpat' l
  | VarPat ((l,_),loc) -> update_local_table' l
  | AppPat (l, p,loc) -> update_local_table_pat' p
  | ConstraintPat (p, t,loc) -> update_local_table_pat' p
  | AsPat ((id,_), _, p,loc) -> update_local_table_pat' p
  | TuplePat (l,loc) -> List.iter update_local_table_pat' l
  | ListPat (l,loc) -> List.iter update_local_table_pat' l
  | ArrayPat (l,loc) -> List.iter update_local_table_pat' l
  | OrPat(l,loc) -> List.iter update_local_table_pat' l
  | _ -> ()

(*
let print_loc loc =
  print_string "#"; print_int loc.Location.loc_start;
  print_string "-"; print_int loc.Location.loc_end;
  print_string "#\n"

let rec print_longid l =
  (match l with
    Lident v -> print_string v
  | Ldot(t,v)  -> print_longid t ; print_string "."; print_string v;
  | _ -> ()
  )
*)

let str_names = ref []
let sig_names = ref []
let fct_names = ref []

let trans_longid local1 local2 (sl,(id,_),loc) =
(*
 if sl = [] and "id" is defined by local module "@local_n",
   the result is "@local_n.id"
 if sl = "S"::t and structure "S" is defined by file "a.n",
   the result is "a.S.(...).id"
 if sl = "S"::t and structure "S" is defined by file ".",
   the result is "S.(...).id"             ("." means current file)
 (*
 local1 : current local module (string)
 local2 : ancestor local modules (string list)
 *)
*)
  let local_name = begin
(*
  local_name : ["@local_n"], if "id" is defined by local module "@local_n".
               [], if "id" in not defined by any local module.
*)
    let rec f l =
      match l with
        [] -> []
      | h::t ->
           try (fun x -> ())
               (List.find (fun x -> x = id) (local_table_find h));
               [(h,Location.none)]
           with Not_found -> f t
    in if sl = [] then f local2 else []
    end
  in
  match (local_name@sl) with
    [] -> begin
            try
              let x = Hashtbl.find Strtbl.str_table id in
              if (x = ".") then
                try let temp = List.find (fun x -> x=id) (!str_names) in
                    (Lident id)
                with Not_found ->
                  begin
                    Hashtbl.remove Strtbl.str_table id;
                    try let result = Hashtbl.find Strtbl.str_table id in
                        let _ = Hashtbl.add Strtbl.str_table id x in
                        Ldot (Lident result, id)
                    with Not_found -> (Lident id)
                  end
              else Ldot(Lident x, id)
            with Not_found ->
            try
              let x = Hashtbl.find Strtbl.sig_table id in
              if (x = ".") then
                try let temp = List.find (fun x -> x=id) (!sig_names) in
                    (Lident id)
                with Not_found ->
                  begin
                    Hashtbl.remove Strtbl.sig_table id;
                    try let result = Hashtbl.find Strtbl.sig_table id in
                        let _ = Hashtbl.add Strtbl.sig_table id x in
                        Ldot (Lident result, id)
                    with Not_found -> (Lident id)
                  end
              else Ldot(Lident x, id)
            with Not_found ->
            try
              let x = Hashtbl.find Strtbl.fct_table id in
              if (x = ".") then
                try let temp = List.find (fun x -> x=id) (!fct_names) in
                    (Lident id)
                with Not_found ->
                  begin
                    Hashtbl.remove Strtbl.fct_table id;
                    try let result = Hashtbl.find Strtbl.fct_table id in
                        let _ = Hashtbl.add Strtbl.fct_table id x in
                        Ldot (Lident result, id)
                    with Not_found -> (Lident id)
                  end
              else Ldot(Lident x, id)
            with Not_found -> (Lident id)
          end
  | (h,_)::t -> begin
      let x = try
                let y = Hashtbl.find Strtbl.str_table h in
                if (y = ".") then
                  try let temp = List.find (fun x -> x=h) (!str_names) in
                      (Lident h)
                  with Not_found ->
                    begin
                      Hashtbl.remove Strtbl.str_table h;
                      try let result = Hashtbl.find Strtbl.str_table h in
                          let _ = Hashtbl.add Strtbl.str_table h y in
                          Ldot (Lident result, h)
                      with Not_found -> (Lident h)
                    end
                else Ldot(Lident y, h)
              with Not_found ->
              try
                let y = Hashtbl.find Strtbl.sig_table h in
                if (y = ".") then
                  try let temp = List.find (fun x -> x=h) (!sig_names) in
                      (Lident h)
                  with Not_found ->
                    begin
                      Hashtbl.remove Strtbl.sig_table h;
                      try let result = Hashtbl.find Strtbl.sig_table h in
                          let _ = Hashtbl.add Strtbl.sig_table h y in
                          Ldot (Lident result, h)
                      with Not_found -> (Lident h)
                    end
                else Ldot(Lident y, h)
              with Not_found ->
              try
                let y = Hashtbl.find Strtbl.fct_table h in
                if (y = ".") then
                  try let temp = List.find (fun x -> x=h) (!fct_names) in
                      (Lident h)
                  with Not_found ->
                    begin
                      Hashtbl.remove Strtbl.fct_table h;
                      try let result = Hashtbl.find Strtbl.fct_table h in
                          let _ = Hashtbl.add Strtbl.fct_table h y in
                          Ldot (Lident result, h)
                      with Not_found -> (Lident h)
                    end
                else Ldot(Lident y, h)
              with Not_found -> (Lident h)
      in
        Ldot(List.fold_left (fun a (b,_) -> Ldot(a, b)) x t ,id)
      end

let rec trans_ty local1 local2 t =
  let trans_ty' = trans_ty local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
  match t with
    VarTy((a,_),loc) -> mktyp (Ptyp_var(a)) loc
  | ConstTy(tylist,([],("real",_),_),loc) ->
      mktyp (Ptyp_constr(trans_longid' ([],("float",loc),loc),
                         List.map trans_ty' tylist)) loc
  | ConstTy(tylist,lid,loc) ->
      mktyp (Ptyp_constr(trans_longid' lid, List.map trans_ty' tylist)) loc
  | RecordTy(labletylist,loc) -> raise (Error(loc, Recordty))
  | TupleTy(tylist,loc) -> mktyp (Ptyp_tuple(List.map trans_ty' tylist)) loc
  | FunTy(t1,t2,loc) -> mktyp (Ptyp_arrow("",trans_ty' t1,trans_ty' t2)) loc

let number_of_argument tyop =
  match tyop with
    None -> 0
  | Some(ty) -> begin
                  match ty with
                    TupleTy(l,_) -> List.length l
                  | _ -> 1
                end

let trans_con local1 local2 ((id,_), tyop, _) =
(*
  ocaml makes error when 

     type t = A of int * int
     let a = (1,1)
     let b = A a

  we change
     type t = A of int * int
  =>
     type @con_A = int * int
     type t = A of @con_A
*)
  let _ = update_local_table local1 id in
  let trans_ty' = trans_ty local1 local2 in
    match tyop with
         None -> (None, (id,[]))
    | Some(ty) ->
        if (number_of_argument tyop) > 1 then begin
          let tyname = "@con_"^id in
             (Some(tyname, trans_ty' ty), (id, [trans_ty' ty]))
          end
        else (None, (id, [trans_ty' ty]))
   
let rec trans_labpat local1 local2 ((l,_), p, _) =
  (Lident l, trans_pat local1 local2 p)

and trans_pat local1 local2 p =
  let trans_labpat' = trans_labpat local1 local2 in
  let trans_pat' = trans_pat local1 local2 in
  let trans_listpat' = trans_listpat local1 local2 in
  let trans_ty' = trans_ty local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
  match p with
    WildPat loc -> mkpat Ppat_any loc
  | UnitPat loc -> mkpat (Ppat_construct(Lident "()", None, false)) loc
  | IntPat (i,loc) -> mkpat (Ppat_constant(Const_int i)) loc
  | StringPat (s,loc) -> mkpat (Ppat_constant(Const_string s)) loc
  | CharPat (c,loc) -> mkpat (Ppat_constant(Const_char c)) loc
  | RecordPat (l,loc) -> mkpat (Ppat_record(List.map trans_labpat' l)) loc
  | SubRecordPat (l,loc) -> mkpat (Ppat_record(List.map trans_labpat' l)) loc
  | RefPat (p,loc) -> raise (Error(loc, Refpat))
  | VarPat (("true",_),loc) ->
      mkpat (Ppat_construct(Lident "true", None, false)) loc
  | VarPat (("false",_),loc) ->
      mkpat (Ppat_construct(Lident "false", None, false)) loc
  | VarPat ((l,_),loc) -> mkpat (Ppat_var(l)) loc
  | AppPat (l, p,loc) ->
      mkpat (Ppat_construct(trans_longid' l, Some (trans_pat' p), false)) loc
  | ConstraintPat (p, t,loc) ->
      mkpat (Ppat_constraint(trans_pat' p, trans_ty' t)) loc
  | AsPat ((id,_), None, p,loc) -> mkpat (Ppat_alias(trans_pat' p, id)) loc
  | AsPat ((id,_), Some t, p,loc) ->
      mkpat (Ppat_alias(mkpat (Ppat_constraint(trans_pat' p, trans_ty' t)) loc,
                        id))
            loc
  | TuplePat (l,loc) -> mkpat (Ppat_tuple(List.map trans_pat' l)) loc
  | ListPat (l,loc) -> mkpat (trans_listpat' l loc) loc
  | ArrayPat (l,loc) -> mkpat (Ppat_array(List.map trans_pat' l)) loc
  | ConPat(l,loc) -> mkpat (Ppat_construct(trans_longid' l, None, false)) loc
  | OrPat([],loc) -> raise (NotConvertible ("or pat with no pat",loc))
  | OrPat(h::[],loc) -> raise (NotConvertible ("or pat with one pat",loc))
  | OrPat(h::t,loc) -> mkpat
      (match List.fold_left (fun a b -> mkpat (Ppat_or(a,(trans_pat' b))) loc)
                            (trans_pat' h) t
       with {ppat_desc = pattern} -> pattern)
       loc

and trans_listpat local1 local2 l loc =
  let trans_pat' = trans_pat local1 local2 in
  let trans_listpat' = trans_listpat local1 local2 in
  match l with
    [] -> Ppat_construct(Lident "[]", None, false)
  | h::t -> Ppat_construct(
              Lident "::",
              Some (mkpat(Ppat_tuple([trans_pat' h;
                                      mkpat(trans_listpat' t loc)loc]))
                         loc),
              false)
       
let rec trans_labexp local1 local2 ((l,_), e, _) =
  (Lident l, trans_exp local1 local2 e)

and trans_rule local1 local2 (p, e, _) =
  (trans_pat local1 local2 p, trans_exp local1 local2 e)

and trans_fnrule local1 local2 (pl, e, _) =
  match pl with
    [p] -> (trans_pat local1 local2 p, trans_exp local1 local2 e)
  | _ -> raise (NotConvertible ("FnRule", nloc))

and trans_exp local1 local2 p =
  let trans_exp' = trans_exp local1 local2 in
  let trans_labexp' = trans_labexp local1 local2 in
  let trans_letexp' = trans_letexp local1 local2 in
  let trans_seqexp' = trans_seqexp local1 local2 in
  let trans_listexp' = trans_listexp local1 local2 in
  let trans_fnrule' = trans_fnrule local1 local2 in
  let trans_rule' = trans_rule local1 local2 in
  let trans_ty' = trans_ty local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
  match p with
    UnitExp loc -> mkexp (Pexp_construct(Lident "()", None, false)) loc
  | IntExp (i,loc) -> mkexp (Pexp_constant(Const_int i)) loc
  | RealExp (f,loc) -> mkexp (Pexp_constant(Const_float f)) loc
  | StringExp (s,loc) -> mkexp (Pexp_constant(Const_string s)) loc
  | CharExp (c,loc) -> mkexp (Pexp_constant(Const_char c)) loc
  | VarExp (([],("true",_),_),loc) ->
      mkexp (Pexp_construct(Lident "true", None, false)) loc
  | VarExp (([],("false",_),_),loc) ->
      mkexp (Pexp_construct(Lident "false", None, false)) loc
  | VarExp (l,loc) -> mkexp (Pexp_ident(trans_longid' l)) loc
  | ConExp (l,loc) -> mkexp (Pexp_construct(trans_longid' l, None, false)) loc
(*
  we change (e0,e1) to (let x0=e0 and x1=e1 in (x0,x1)).
  but, because "::" is constructor,
  :: (let val x0 = e0
          val x1 = e1
      in  (x0,x1)) is impossible in ocaml.
  we must treat ":: (e0,e1)" specially.
  let val x0 = e0
      val x1 = e1
  in  :: (x0,x1)
*)
  | AppExp (ConExp(c,_), (TupleExp(l,loc1) as arg) ,loc) ->
    if not (expansive arg) then
      mkexp (Pexp_construct(
               trans_longid' c,
               Some(mkexp (Pexp_tuple (List.map trans_exp' l)) loc1),
               false)) loc
    else
      let rec f x l =
            match l with
              [] -> []
            | h::t -> (mkpat (Ppat_var ("X"^(string_of_int x))) loc,
                          trans_exp' h)
                      ::(f (x+1) t)
      in
      let rec g x l =
            match l with
              [] -> []
            | h::t -> (mkexp (Pexp_ident (Lident ("X"^(string_of_int x)))) loc)
                      ::(g (x+1) t)
      in
      let pel = f 0 l in
      let el = g 0 l in
      mkexp (Pexp_let(Nonrecursive, pel, 
        mkexp (Pexp_construct(trans_longid' c, Some(
          mkexp (Pexp_tuple el) loc1), false)) loc
        )) loc
  | AppExp (ConExp(l,loc1), e',loc) ->
      mkexp (Pexp_construct(trans_longid' l, Some(trans_exp' e'), false)) loc
(*
  | AppExp (e, e',loc) ->
      mkexp (Pexp_apply(trans_exp' e, [trans_exp' e'])) loc
*)
  | AppExp (e1, e2,loc) ->
      let rec find_function e =
        match e with
          AppExp(e1, e2, loc) ->
            let (ftn, al) = find_function e1 in (ftn, al@[e2])
        | _ -> (e, [])
      in
      let (ftn, al) = find_function e1 in
        if (List.fold_left (fun x y -> x or (expansive y)) false al) then
          let rec f x l =
            match l with
              [] -> []
            | h::t -> (mkpat (Ppat_var ("X"^(string_of_int x))) loc,
                       trans_exp' h) :: (f (x+1) t)
          in
          let rec g x l =
              match l with
                [] -> []
              | h::t -> ("", mkexp (Pexp_ident (Lident ("X"^(string_of_int x))))
                         loc) :: (g (x+1) t)
          in
          let pel = f 0 (al@[e2]) in
          let lel = g 0 (al@[e2]) in
            mkexp (Pexp_let (Nonrecursive, pel,
                             mkexp (Pexp_apply (trans_exp' ftn, lel)) loc))
                   loc
        else
          mkexp (Pexp_apply(trans_exp' ftn,
                              List.map (fun x -> ("",x))
                                (List.map trans_exp' (al@[e2]))
                           )) loc
  | RecordExp (l,loc) ->
(*
   ocaml doesn't specify ordering of evaluation of arguments.
   ocaml 2.04 implement reverse ordering of argumets in lexical ordering.
   nML preserve the lexical ordering.
   (Record, Tuple, List, Array)

   {a=e1,b=e2,c=e3} => let x1=e1 x2=e2 x3=e3 in {a=x1,b=x2,c=x3} end

*)
    if not (expansive (RecordExp (l,loc))) then
      mkexp (Pexp_record(List.map trans_labexp' l, None)) loc
    else
      let rec f x l =
          match l with
            [] -> []
          | (a,b,_)::t -> (mkpat (Ppat_var ("X"^(string_of_int x))) loc,
                           trans_exp' b)
                          ::(f (x+1) t)
      in
      let rec g x l =
          match l with
            [] -> []
          | ((a,_),_,_)::t ->
              (Lident a,
               (mkexp (Pexp_ident (Lident ("X"^(string_of_int x)))) loc))
              ::(g (x+1) t)
      in
      let pel = f 0 l in
      let lel = g 0 l in
      mkexp (Pexp_let(Nonrecursive, pel, mkexp (Pexp_record (lel, None)) loc))
            loc
  | RecordFieldExp (e, (l,_),loc) ->
      mkexp (Pexp_field(trans_exp' e, Lident l)) loc
  | ArrayFieldExp (e, e',loc) ->
      mkexp (Pexp_apply(mkexp (Pexp_ident(Ldot(Lident "Array", "get"))) loc,
                 [("", trans_exp'(e)); ("", trans_exp'(e'))])) loc
  | UpdateArrayExp (e, e',e'',loc) ->
      mkexp (Pexp_apply(mkexp(Pexp_ident(Ldot(Lident "Array", "set"))) loc,
                 [("", trans_exp'(e)); ("", trans_exp'(e')); ("", trans_exp' (e''))])) loc
  | SubstRecordExp (e, l, e',loc) ->
      mkexp (Pexp_record([trans_labexp' (l,e',loc)], Some(trans_exp' e))) loc
  | TupleExp (l,loc) ->
(*
   ocaml doesn't specify ordering of evaluation of arguments.
   ocaml 2.04 implement reverse ordering of argumets in lexical ordering.
   nML preserve the lexical ordering.
   (Record, Tuple, List, Array)
*)
    if not (expansive (TupleExp (l,loc))) then
      mkexp (Pexp_tuple(List.map trans_exp' l)) loc
    else
      let len = List.length l in
      let rec f x l =
          match l with
            [] -> []
          | h::t -> (mkpat (Ppat_var ("X"^(string_of_int x))) loc,
                     trans_exp' h)
                    ::(f (x+1) t)
      in
      let rec g x =
          if x = len then []
          else (mkexp (Pexp_ident (Lident ("X"^(string_of_int x)))) loc)
               ::(g (x+1))
      in
      let pel = f 0 l in
      let el = g 0 in
      mkexp (Pexp_let(Nonrecursive, pel, mkexp (Pexp_tuple el) loc)) loc
  | ListExp (l,loc) ->
    if not (expansive (ListExp (l,loc))) then
      let rec trans_listexp l =
        match l with
          [] -> Pexp_construct(Lident "[]", None, false)
        | h::t -> Pexp_construct(
                    Lident "::",
                    Some(mkexp (Pexp_tuple[trans_exp' h;
                                           mkexp (trans_listexp t) loc])
                               loc),
                    false)
      in mkexp (trans_listexp l) loc
    else
      mkexp (trans_listexp' l loc) loc
  | ArrayExp (l,loc) ->
(*
   ocaml doesn't specify ordering of evaluation of arguments.
   ocaml 2.04 implement reverse ordering of argumets in lexical ordering.
   nML preserve the lexical ordering.
   (Record, Tuple, List, Array)
*)
    if not (expansive (ArrayExp (l,loc))) then
      mkexp (Pexp_array(List.map trans_exp' l)) loc
    else
      let len = List.length l in
      let rec f x l =
          match l with
            [] -> []
          | h::t -> (mkpat (Ppat_var ("X"^(string_of_int x))) loc,
                     trans_exp' h)
                    ::(f (x+1) t)
      in
      let rec g x =
          if x = len then []
          else (mkexp (Pexp_ident (Lident ("X"^(string_of_int x)))) loc)
               ::(g (x+1))
      in
      let pel = f 0 l in
      let el = g 0 in
      mkexp (Pexp_let(Nonrecursive, pel, mkexp (Pexp_array el) loc)) loc
  | LetExp (SeqDec(d,loc1), e,loc) ->
      mkexp (trans_letexp'(d, trans_exp' e, loc)) loc
  | LetExp (d, e,loc) -> mkexp (trans_letexp'([d], trans_exp' e, loc)) loc
  | HandleExp (e, l,loc) ->
      mkexp (Pexp_try(trans_exp' e, List.map trans_rule' l)) loc
  | RaiseExp (e,loc) ->
      mkexp (Pexp_apply(mkexp (Pexp_ident(Lident "raise")) loc,
                        [("", trans_exp' e)])) loc
  | FnExp (l,loc) -> mkexp (Pexp_function("", None, List.map trans_fnrule' l)) loc
  | AssignExp (e, e',loc) ->
      mkexp (Pexp_apply(mkexp (Pexp_ident(Lident ":=")) loc,
                        [("", trans_exp' e); ("", trans_exp' e')])) loc
  | RefExp (e,loc) ->
      mkexp (Pexp_apply(mkexp(Pexp_ident(Lident "ref"))loc,[("", trans_exp' e)])) loc
  | DeRefExp (e,loc) ->
      mkexp (Pexp_apply(mkexp(Pexp_ident(Lident "!"))loc,[("", trans_exp' e)])) loc
  | SeqExp (l,loc) -> mkexp (trans_seqexp' l loc) loc
  | CaseExp (e, l,loc) ->
      mkexp (Pexp_match(trans_exp' e, List.map trans_rule' l)) loc
  | IfExp (e, e', e'',loc) ->
      mkexp (Pexp_ifthenelse(trans_exp' e, trans_exp' e', Some(trans_exp' e'')))
            loc
  | WhileExp (e, e',loc) -> mkexp (Pexp_while(trans_exp' e, trans_exp' e')) loc
  | ForExp (id, e, e', e'', e''',loc) -> raise (NotConvertible ("",loc))
  | ConstraintExp (e, t,loc) ->
      mkexp (Pexp_constraint(trans_exp' e, Some(trans_ty' t), None)) loc

(*
  [e0,e1,e2]
  ========>
  let x0 = e0
  and x1 = let x0 = e1
           and x1 = let x0 = e2
                    and x1 = []
                    in :: (x0,x1)
           in (x0,x1)
  in :: (x0,x1)
*)
and trans_listexp local1 local2 l loc =
  let trans_exp' = trans_exp local1 local2 in
  let trans_listexp' = trans_listexp local1 local2 in
  match l with
    [] -> Pexp_construct(Lident "[]", None, false)
  | h::t ->
    let pel = [mkpat (Ppat_var ("X0")) loc, trans_exp' h;
               mkpat (Ppat_var ("X1")) loc, mkexp (trans_listexp' t loc) loc] in
    let el = [mkexp (Pexp_ident (Lident ("X0"))) loc;
              mkexp (Pexp_ident (Lident ("X1"))) loc] in
      Pexp_let(Nonrecursive, pel, 
        mkexp (Pexp_construct(Lident "::", Some(
          mkexp (Pexp_tuple el) loc), false)) loc
        ) 

and trans_letexp local1 local2 (d,e,loc) =
  let trans_valbind' = trans_valbind local1 local2 in
  let trans_funbind' = trans_funbind local1 local2 in
  let trans_letexp' = trans_letexp local1 local2 in
  begin
    let trans_valdec (vd,pexp) =
      match vd with
        ValDec([],vbl,loc) ->
          Pexp_let(Nonrecursive, List.map trans_valbind' vbl, pexp)
      | RecValDec([],vbl,loc) ->
          Pexp_let(Recursive, List.map trans_valbind' vbl, pexp)
      | FunDec([],fbl,loc) ->
          Pexp_let(Recursive, List.flatten (List.map trans_funbind' fbl), pexp)
      | _ -> raise (NotConvertible ("",loc))
    in
      match d with
        [] -> raise (NotConvertible ("",loc))
      | h::[] -> trans_valdec (h, e)
      | h::t -> trans_valdec (h, mkexp (trans_letexp'(t,e,loc)) loc)
  end

and trans_seqexp local1 local2 l loc =
  let trans_exp' = trans_exp local1 local2 in
  let trans_seqexp' = trans_seqexp local1 local2 in
  match l with
    [] -> raise (NotConvertible ("",loc))
  | h::[] -> let {pexp_desc = e} = trans_exp' h in e
  | h::t -> Pexp_sequence(trans_exp' h, mkexp (trans_seqexp' t loc) loc)

and trans_valbind local1 local2 (p, e, _) =
  update_local_table_pat local1 p;
  (trans_pat local1 local2 p, trans_exp local1 local2 e)

and trans_funbind local1 local2 (l, loc) =
  let trans_pat' = trans_pat local1 local2 in
  let trans_exp' = trans_exp local1 local2 in
  begin
    let ((fid,locfid),al,_,loc1) = (List.hd l) in
    let _ = update_local_table local1 fid in
    let trans_function ((id,_),pl,e,loc) =
          if id <> fid then raise (NotConvertible ("",loc));
          (mkpat(Ppat_tuple(List.map trans_pat' pl))loc, trans_exp' e) in
    let count = ref (-1) in
    let init_var () = count := -1 in
    let new_var x = incr count; "x"^(string_of_int (!count)) in
    let arg_list = List.map new_var al in
    let rec trans_temp p =
          match p with
            [] -> init_var();
                  mkexp(Pexp_match(
                    mkexp(Pexp_tuple(List.map (fun x ->
                              mkexp(Pexp_ident(
                                 Lident (incr count;
                                         "x"^(string_of_int (!count))
                                        )))loc) al))loc,
                    List.map trans_function l))loc
          | h::t -> mkexp(Pexp_function ("", None, [
                      mkpat(Ppat_var(h))loc, trans_temp t
                    ]))loc
    in 
      [(mkpat (Ppat_var fid) locfid, trans_temp arg_list)]
  end

and trans_recordty local1 local2 l =
  let trans_ty' = trans_ty local1 local2 in
  let trans_recordty' = trans_recordty local1 local2 in
  match l with
    [] -> raise (NotConvertible ("",nloc))
  | ((lbl,_),ty,_)::[] -> (lbl, Immutable, trans_ty' ty)::[]
  | ((lbl,_),ty,_)::rest ->
      (lbl, Immutable, trans_ty' ty)::(trans_recordty' rest)


and trans_typebind local1 local2 p =
  let trans_ty' = trans_ty local1 local2 in
  let trans_recordty' = trans_recordty local1 local2 in
  let trans_con' = trans_con local1 local2 in
  match p with
    TypeBind (tyvs, (id,_), RecordTy(l,_), loc) ->
    begin
      let _ = update_local_table local1 id in
      let (t,_) = List.split tyvs in
      let trans_labty ((l,_),t,_) = (l, Immutable, trans_ty' t) in
        [(id, make_type' t (Ptype_record(List.map trans_labty l)) None)]
    end
  | TypeBind (tyvs, (id,_), ty, loc) ->
    begin
      let _ = update_local_table local1 id in
      let (kind,manifest) =
        match ty with
          RecordTy(l,_) -> (Ptype_record(trans_recordty' l), None)
        | _ -> (Ptype_abstract, Some(trans_ty' ty))
      and (t,_) = List.split tyvs
      in
        [(id, make_type' t kind manifest)]
    end
  | DataBind (tyvs, (id,_), cl, loc) ->
    begin
      let _ = update_local_table local1 id in
      let (t,_) = List.split tyvs in
      let make_type'' = make_type t in
      let (tl,dl) = List.split (List.map trans_con' cl) in
        (id, make_type' t (Ptype_variant dl) None)::
        (List.flatten (List.map make_type'' tl))
    end

and trans_dec local1 local2 p =
  let trans_exp' = trans_exp local1 local2 in
  let trans_valbind' = trans_valbind local1 local2 in
  let trans_funbind' = trans_funbind local1 local2 in
  let trans_typebind' = trans_typebind local1 local2 in
  let trans_con' = trans_con local1 local2 in
  let trans_dec' = trans_dec local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
  match p with
    ValDec ([], [(WildPat loc2,e, loc1)], loc) ->
      [mkstr (Pstr_eval(trans_exp' e)) loc]
  | ValDec ([], l, loc) ->
      [mkstr (Pstr_value(Nonrecursive, List.map trans_valbind' l)) loc]
  | RecValDec ([], l, loc) ->
      [mkstr (Pstr_value(Recursive, List.map trans_valbind' l)) loc]
  | FunDec ([], l, loc) ->
      [mkstr (Pstr_value(Recursive, List.flatten (List.map trans_funbind'  l)))
             loc]
  | ValDec (_, l, loc) -> raise (Error(loc, Valdec))
  | RecValDec (_, l, loc) -> raise (Error(loc, Recvaldec))
  | FunDec (_, l, loc) -> raise (Error(loc, Fundec))
  | TypeDec (l, loc) ->
      [mkstr (Pstr_type(List.flatten (List.map trans_typebind' l))) loc]
  | AbstypeDec (l, d, loc) -> begin
      let local1' = new_abstype() in
      let trans_typebind'' = trans_typebind local1' [] in
      let l' = [mkstr(Pstr_type(List.flatten(List.map trans_typebind'' l)))loc]
      in
      let dl' = mkstr (Pstr_module(local1',
                            mkmod (Pmod_structure l') loc)) loc in
      let f tb =
        match tb with
          DataBind(tv,(tid,_),cl,locd) -> begin
          let (t,_) = List.split tv in
            mkstr (Pstr_type[tid, make_type' t Ptype_abstract
                                (Some
                                 (mktyp
                                  (Ptyp_constr
                                   (Ldot
                                    (Lident local1', tid), 
                                    (List.map
                                     (fun x->mktyp (Ptyp_var x) locd)
                                     t
                                    )
                                   ))
                                  locd))
                            ]) loc
            end
        | _ -> raise (NotConvertible ("type bind in abstype",loc))
      in
      let d' = trans_dec local1 (local1'::local2) d in
      let _ = clear_local_table (local1') in
        dl'::((List.map f l)@d')
      end
  | ExceptionDec (l, loc) -> begin
      let trans_exnbind (c) = begin
            let (tl, (id,exndcl)) = trans_con' c in
            let make_type' = make_type [] in
               [mkstr (Pstr_type(make_type' tl)) loc;
                mkstr (Pstr_exception(id,exndcl)) loc]
            end
      in
          List.flatten (List.map trans_exnbind l)
      end
  | LocalDec (d1, d2, loc) -> begin
      let local1' = new_local() in
      let trans_dec'' = trans_dec local1' local2 in
      let d1' = mkstr (Pstr_module(local1',
                            mkmod (Pmod_structure(trans_dec'' d1)) loc)) loc in
      let d2' = trans_dec local1 (local1'::local2) d2 in
      let _ = clear_local_table (local1') in
        d1'::d2'
      end
  | OpenDec (l, loc) ->
      List.map (function x-> mkstr (Pstr_open(trans_longid' x)) loc) l
  | SeqDec (l, loc) -> List.flatten (List.map trans_dec' l)


let trans_longtypebind local1 local2 (tyvs, l, ty, loc) =
  let trans_ty' = trans_ty local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
    let (t,_) = List.split tyvs
    in  (trans_longid' l, Pwith_type (make_type' t Ptype_abstract 
                                                 (Some(trans_ty' ty))))

let trans_where (l,loc) =
  let trans_longtypebind' = trans_longtypebind "" [] in
  List.map trans_longtypebind' l

let trans_valdesc ((id,_), t, loc) =
  let trans_ty' = trans_ty "" [] in
  mksig (Psig_value(id,{pval_type = trans_ty' t; pval_prim = []})) loc

let trans_typedesc p =
  let trans_ty' = trans_ty "" [] in
  let trans_recordty' = trans_recordty "" [] in
  let trans_con' = trans_con "" [] in
  match p with
    TypeDesc (tyvs, (id,_), loc) ->
      let (t,_) = List.split tyvs
      in  [(id, make_type' t Ptype_abstract None)]
  | TypeBindDesc (tyvs, (id,_), RecordTy(l,_), loc) ->
    begin
      let (t,_) = List.split tyvs in
      let trans_labty ((l,_),t,_) = (l, Immutable, trans_ty' t) in
        [(id, make_type' t (Ptype_record(List.map trans_labty l)) None)]
    end
  | TypeBindDesc (tyvs, (id,_), ty, loc) ->
    begin
      let (kind,manifest) =
        match ty with
          RecordTy(l,_) -> (Ptype_record(trans_recordty' l), None)
        | _ -> (Ptype_abstract, Some(trans_ty' ty))
      and (t,_) = List.split tyvs
      in
        [(id, make_type' t kind manifest)]
    end
  | DataDesc (tyvs, (id,_), cl, loc) -> begin
      let (t,_) = List.split tyvs in
      let make_type'' = make_type t in
      let (tl,dl) = List.split (List.map trans_con' cl) in
        (id, make_type' t (Ptype_variant dl) None)::
        (List.flatten (List.map make_type'' tl))
      end

let rec trans_strdesc ((id,_), se, loc) =
           mksig (Psig_module(id, trans_sigexp se)) loc

and trans_spec p =
  let trans_con' = trans_con "" [] in
  match p with
    ValSpec (l,loc) -> List.map trans_valdesc l
  | TypeSpec (l,loc) ->
      [mksig(Psig_type(List.flatten(List.map trans_typedesc l)))loc]
  | ExnSpec (l,loc) -> begin
      let trans_exndesc (c) = begin
            let (tl, (id,exndcl)) = trans_con' c in
            let make_type' = make_type [] in
               [mksig (Psig_type(make_type' tl)) loc;
                mksig (Psig_exception(id,exndcl)) loc]
            end
      in
          List.flatten (List.map trans_exndesc l)
      end
  | IncludeSpec (s,loc) -> [mksig(Psig_include(trans_sigexp s))loc]
  | StrSpec (l,loc) -> List.map trans_strdesc l
  | SeqSpec (l,loc) -> List.flatten (List.map trans_spec l)

and trans_sigexp p =
  let trans_longid' = trans_longid "" [] in
  match p with
    VarSig (l,loc) -> mkmty (Pmty_ident(trans_longid' ([],l,loc))) loc
  | SigSig (s,loc) -> mkmty (Pmty_signature(trans_spec s)) loc
  | ConstraintSig (se, wh,loc) ->
      mkmty (Pmty_with(trans_sigexp se, trans_where wh)) loc

let trans_sigbind ((id,_), s, loc) = begin
  let _ = sig_names := id :: (!sig_names) in
  let result = mkstr (Pstr_modtype(id, trans_sigexp s)) loc in
  let _ = sig_names := List.tl (!sig_names) in
    result
  end
      

let trans_sigdec (l,loc) = List.map trans_sigbind l

let rec trans_strexp local1 local2 p =
  let trans_strdec' = trans_strdec local1 local2 in
  let trans_strexp' = trans_strexp local1 local2 in
  let trans_longid' = trans_longid local1 local2 in
  match p with
    VarStr (l,loc) -> mkmod (Pmod_ident(trans_longid' l)) loc
  | StrStr (d,loc) -> mkmod (Pmod_structure(trans_strdec' d)) loc
  | SigStr (ste, sie,loc) ->
      mkmod (Pmod_constraint(trans_strexp' ste, trans_sigexp sie)) loc
  | FctAppStr (id, [s],loc) ->
      mkmod (Pmod_apply(mkmod (Pmod_ident(trans_longid' ([],id,loc))) loc,
                        trans_strexp' s)) loc
  | FctAppStr (id, sl,loc) ->
      List.fold_left
        (function a -> function b -> mkmod (Pmod_apply(a,trans_strexp' b)) loc)
        (mkmod (Pmod_ident(trans_longid' ([],id,loc))) loc)
        sl

and trans_strbind local1 local2 ((id,_), sgop, se, loc) = mkstr (
  let trans_strexp' = trans_strexp local1 local2 in
  match sgop with
    None -> begin
      let _ = str_names := id :: (!str_names) in
      let result = Pstr_module(id, trans_strexp' se) in
      let _ = str_names := List.tl (!str_names) in
        result
      end
  | Some sie -> begin
      let _ = str_names := id :: (!str_names); in
      let result = Pstr_module(id, mkmod (Pmod_constraint(trans_strexp' se,
                                             trans_sigexp sie)) loc) in
      let _ = str_names := List.tl (!str_names) in
        result
      end) loc

and trans_strdec local1 local2 p = 
  let trans_dec' = trans_dec local1 local2 in
  let trans_strdec' = trans_strdec local1 local2 in
  let trans_strbind' = trans_strbind local1 local2 in
  match p with
    SimpleDec (d,loc) -> trans_dec' d
  | StrDec (l,loc) -> List.map trans_strbind' l
  | SeqStrDec (l,loc) -> List.flatten (List.map trans_strdec' l)

let rec trans_fctarg (al,se) =
  let trans_strexp' = trans_strexp "" [] in
  match al with
    [] -> raise (NotConvertible ("no argument on functor application",nloc))
  | ((aid,_),ase,aloc)::[] -> mkmod (Pmod_functor(aid, trans_sigexp ase,
                                        trans_strexp' se)) aloc
  | ((aid,_),ase,aloc)::rest -> mkmod (Pmod_functor(aid, trans_sigexp ase,
                                         trans_fctarg (rest,se))) aloc

let trans_fctdec p =
  match p with
    ((id,_), al, None, se, loc) -> begin
      let _ = fct_names := id :: (!fct_names) in
      let result = [mkstr (Pstr_module(id, trans_fctarg (al,se))) loc] in
      let _ = fct_names := List.tl (!fct_names) in
        result
      end
  | _ -> raise (NotConvertible ("",nloc))

let rec trans_topdec p = try
  let trans_strdec' = trans_strdec "" [] in
  match p with
    Sig (d,loc) -> trans_sigdec d
  | Fct (d,loc) -> trans_fctdec d
  | Str (d,loc) -> trans_strdec' d
  | SeqTopDec (dl,loc) -> List.flatten (List.map trans_topdec dl)
  with x -> begin
    Format.printf "Error in trans_topdec.@.";
    raise x
  end

let trans_dirarg p =
  let trans_longid' = trans_longid "" [] in
  match p with
    ArgNone -> Pdir_none
  | ArgString (s) -> Pdir_string (s)
  | ArgInt (i) -> Pdir_int (i)
  | ArgLident (l) -> Pdir_ident (trans_longid' l)

let trans_toplevel p =
  let trans_exp' = trans_exp "" [] in
  match p with
    TopDef (d) -> Ptop_def (trans_topdec d)
  | TopExp (el, loc) ->
    begin
      match el with
        [] -> raise (NotConvertible ("",loc))
      | h::[] ->
          Ptop_def([mkstr (Pstr_eval(trans_exp' h)) loc])
      | h::t ->
          Ptop_def([mkstr(Pstr_eval(
            List.fold_left
              (fun a b -> 
                 mkexp (Pexp_sequence(a, b))
                 {Location.loc_start = a.pexp_loc.Location.loc_start;
                  Location.loc_end = b.pexp_loc.Location.loc_end;
                  Location.loc_ghost = a.pexp_loc.Location.loc_ghost} )
              (trans_exp' h)
              (List.map trans_exp' t)
          )) loc])
    end
  | TopDir (s,a) -> Ptop_dir (s, trans_dirarg a)