open Parsetree
open Misc
open Asttypes
open Ctype
open Types
open Typedtree
open Format
open Printtyp
open Trxtime
open Parmatch
open Path
open Ident
open Linenum
open Env
open Typecore
open Dl
 
(* Reexport Trxtime *)

type ticks = Trxtime.ticks


let timenew     = Trxtime.timenew
let time        = Trxtime.time
let init_times  = Trxtime.init_times
let print_times = Trxtime.print_times 
let get_times   = Trxtime.get_times
let timecycles  = Trxtime.timecycles
let times       = Trxtime.times
let get_ticks   = Trxtime.get_ticks
let elapsed_ticks = Trxtime.elapsed_ticks

let te_success = Typecore.te_success

let texp_construct_keep (e1,e2) = Texp_construct (e1, e2, Keep)

(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(* Generic code used by all offshoring translators.                    *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)


exception TypeCheckingError
exception OffshoringError of string

let unSome o =
  match o with
    Some (x) -> x
  | None -> assert false

(* Correctness of this function depends on 
   the correct implementation of the pretty
   printer for types (the Printtyp module).
 *)
let type_expr_to_string te =
  Printtyp.type_expr Format.str_formatter te;
  "<" ^ (flush_str_formatter ()) ^ ">"
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(* This module contains the C-specific offshoring functionality.       *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
module OffshoreC = struct
  open Cabs
  open Cprint
  type runC_record = { lang: string; compiler: string; 
                       compiler_flags:string; 
                       working_dir: string; file_name:string;
                       main_function_name: string;
                       clean_temp:bool}
  let runC = {lang="C"; compiler = "gcc"; compiler_flags="-g -O2"; 
              working_dir=".";file_name="test";
              main_function_name="procedure";
              clean_temp = true}
      (* Difficult to remove the function below for the following
         reasons:
         1. If handled by lexer/parser, would have to make
         struct available to lexer/parser. This either
         means a separate module for itself, or a circular
         dependency
         2. Would have to duplicate code in parser for the fortran
         and C cases
       *)
  let getDefaultArg s = 
    match s with 
      "lang" -> runC.lang
    | "compiler" -> runC.compiler
    | "compiler_flags" -> runC.compiler_flags
    | "working_dir" ->  runC.working_dir
    | "file_name" -> runC.file_name
    | "main_function_name" ->  runC.main_function_name
    | _ -> fatal_error("Trx: C Unsupported option: " ^ s)

  let print_loc loc = Location.print Format.std_formatter loc
  let notSupported s loc = print_loc loc; raise (OffshoringError (s ^ " (unsupported subset)")) 
  let warning s loc = 
   Format.fprintf Format.err_formatter "%a Warning %s"  Location.print loc s;
	Format.pp_print_flush Format.err_formatter ()

  let cabs_location = { lineno = 0; filename = "cabs loc unknown"; byteno = 0; }
  (* cinfo is a per-function structure
         globs : variable declarations and function definitions
                 arising out of translation of a function
         defs  : local variable declarations for a function
         fname : function name
         stmts : function body
     translation of a function might result in the
     creation of new cinfo structures from the translation
      nested functions.
   *)
  type cinfo = 
      {
       globs: Cabs.definition list;             
       fname: string;                          
       defs:  Cabs.definition list;           
       stmts: Cabs.statement list;           
     }

  (* make a set (no duplicates) to contain variables *)
  module DefSet =
    Set.Make(struct
      type t = string
      let compare = Pervasives.compare
    end)


  (* sets to maintain global and local variable definitions *)
  let glob_set = ref DefSet.empty
  let def_set  = ref DefSet.empty
  let is_nested = ref false   (* to avoid nested functions *)

  let init_translation _ =
    glob_set := DefSet.empty;
    def_set  := DefSet.empty;
    is_nested:= false

        (* Generated code will only require 
           math.h, stdlib.h, assert.h (and
           mlvalues_h optionally)
         *)
  type reqhdrs_t =
      {
       math_h: bool ref;
       stdlib_h: bool ref;
       assert_h: bool ref;
       mlvalues_h: bool ref;
     }

  let req_hdrs = 
    {  math_h = ref false;
       stdlib_h = ref false; 
       assert_h = ref false;
       mlvalues_h = ref false; 
     } 
  let set_hdr r = r := true

  let deflist_of_reqhdrs hdrs =
    let hdr_list = 
      [(hdrs.math_h, "<math.h>");
       (hdrs.stdlib_h, "<sdlib.h>");
       (hdrs.assert_h, "<assert.h>");
       (hdrs.mlvalues_h, ("\"" ^ 
                          (Filename.concat 
                             Config.standard_library 
                             "caml/mlvalues.h") ^
                          "\""))] in
    let rec gen_incs hl =
      (match hl with 
        [] -> []
      | (h,hname)::xs -> 
          let ys = gen_incs xs in
          if !h then 
            INCLUDE(hname, cabs_location):: ys
          else ys) in
    gen_incs hdr_list
      
      (* Translate a type_expr into a Cabs type.  [type_expr -> typeSpecifier].
         This is used when the caller expects only to translate base types
         (i.e., no references).  *)

      (* Currently we pattern match over strings that denote the
         type names. Although this is less than desirable, it is
         difficult to do in any other manner because:
         1. The ASTs don't seem to have been designed to account
         for pattern matching on type names. Doing so introduces
         code explosion in patterns since there are multiple
         ways of representing ints (e.g. Int,  Tsubst, Tlink, etc).
         2. the way ASTs represent the base types depends on
         the module Path and ultimately on module Ident, which
         also stores the names as strings, so we could not do 
         much better using them. 
         3. Doing this ourselves, would involve a lot of rewriting
         of the functions that are done by the pretty printer itself.
       *)
  let xlate_basic_type te curr_loc =
    match type_expr_to_string te with
      "<int>" -> Tint
    | "<float>" -> Tdouble
    | "<bool>" -> Tint
    | "<char>" -> Tchar
    | "<string>" -> notSupported "xlate_basic_type: string" curr_loc
    | "<unit>" -> notSupported "xlate_basic_type: unit" curr_loc
    | _ -> notSupported ("xlate_basic_type: " ^ (type_expr_to_string te)) curr_loc
  let print_basic_type te curr_loc =
    match type_expr_to_string te with
      "<int>" -> "int"
    | "<float>" -> "double"
    | "<bool>" -> "int"
    | "<char>" -> "char" 
    | "<string>" -> notSupported "print_basic_type: string" curr_loc
    | "<unit>" -> notSupported "print_basic_type: unit" curr_loc
    | _ -> notSupported ("print_basic_type: " ^ (type_expr_to_string te)) curr_loc
  let get_simple_ref_base_type te curr_loc =
    let te_str = type_expr_to_string te in
    match te_str with
      "<int ref>" -> Tint
    | "<float ref>" -> Tdouble
    | "<bool ref>" -> Tint
    | "<char ref>" -> Tchar
    | _ -> notSupported ("reference type " ^ te_str) curr_loc
  let is_simple_ref_type te =
    let te_str = type_expr_to_string te in
    match te_str with
      "<int ref>" -> true
    | "<float ref>" -> true
    | "<bool ref>" -> true
    | "<char ref>" -> true
    | _ -> false
  let get_array_base_type te curr_loc =
    let te_str = type_expr_to_string te in
    match te_str with
      "<int array>" -> Tint
    | "<float array>" -> Tdouble
    | "<bool array>" -> Tint
    | "<char array>" -> Tchar
    | "<int array array>" -> Tint
    | "<float array array>" -> Tdouble
    | "<bool array array>" -> Tint
    | "<char array array>" -> Tchar
    | _ -> notSupported ("array type " ^ te_str) curr_loc
  let print_array_type te  curr_loc=
    let te_str = type_expr_to_string te in
    match te_str with
      "<int array>" -> "int*"
    | "<float array>" -> "double*"
    | "<bool array>" -> "int*"
    | "<char array>" -> "char*"
    | "<int array array>" -> "int**"
    | "<float array array>" -> "double**"
    | "<bool array array>" -> "int**"
    | "<char array array>" -> "char**"
    | _ -> notSupported ("array type " ^ te_str) curr_loc
  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
  let array_num_dims te  curr_loc =
    let te_str = type_expr_to_string te in
    match te_str with
      "<int array>" -> 1 
    | "<float array>" -> 1 
    | "<bool array>" -> 1
    | "<char array>" -> 1
    | "<int array array>" -> 2
    | "<float array array>" -> 2
    | "<bool array array>" -> 2
    | "<char array array>" -> 2
    | _ -> notSupported ("array type " ^ te_str) curr_loc
  let is_unit_type te = 
    type_expr_to_string te = "<unit>"

  let is_function_type te =
    match te.desc with
      Tarrow _ -> true
    | _ -> false

  let get_func_return_type te =
    match te.desc with
      Tarrow(lab,te1,te2,com) ->
        let rec gfrt ttee =
          match ttee.desc with
            Tarrow(ilab,ite1,ite2,icom) -> gfrt ite2
          | _ -> te2 in gfrt te2
    | _ -> raise (OffshoringError "expected arrow type")

  let mkCabs_iconst n =
    Cabs.mkCabs_iconst n
  let mkCabs_binop op trans_s eool info =
    Cabs.mkCabs_binop op trans_s eool info 
  let mkCabs_simple_decl cabstype varname expr isconst =
    Cabs.mkCabs_simple_decl cabstype varname expr isconst cabs_location
  let mkCabs_array_decl1 cabstype varname size =
    Cabs.mkCabs_array_decl1 cabstype varname size cabs_location
  let mkCabs_ptr_decl1 cabstype varname expr =
    Cabs.mkCabs_ptr_decl1 cabstype varname expr cabs_location
  let mkCabs_array_decl2 cabstype varname size1 size2 =
    Cabs.mkCabs_array_decl2 cabstype varname size1 size2 cabs_location
  let mkCabs_array_init_decl1 cabstype varname size cbsli init=
    let spec = [SpecType(cabstype)] in
    let decltype = ARRAY(JUSTBASE, [], (mkCabs_iconst size)) in
    let name = (varname, decltype, [], cbsli) in 
    let initnmlist = [(name, init)] in
    let initnmgroup = (spec, initnmlist) in
       DECDEF(initnmgroup, cbsli)
  let mkCabs_array_init_decl2 cabstype varname size1 size2 cbsli init=
    let spec = [SpecType(cabstype)] in
    let dtypeinner = ARRAY(JUSTBASE, [], (mkCabs_iconst size1)) in
    let decltype = ARRAY(dtypeinner, [], (mkCabs_iconst size2)) in
    let name = (varname, decltype, [], cbsli) in 
    let initnmlist = [(name, init)] in
    let initnmgroup = (spec, initnmlist) in
       DECDEF(initnmgroup, cbsli)
  let mkCabs_assignment varname expr =
    Cabs.mkCabs_assignment varname expr
  let mkCabs_call namestr cabsexpl =
    Cabs.mkCabs_call namestr cabsexpl
  let mkCabs_block defs stmts =
    Cabs.mkCabs_block defs stmts
  let mkCabs_fundef rettype fname (args: single_name list) blk =
    Cabs.mkCabs_fundef rettype fname (args: single_name list) blk cabs_location
  let mkCabs_simple_cast cabstype cabsexp =
    Cabs.mkCabs_simple_cast cabstype cabsexp cabs_location
  let texpcon_to_cabscon con =
    match con with
      Const_int (jint) ->
        mkCabs_iconst jint
    | Const_char (jchar) ->
        let cval = Int64.of_int (Char.code jchar) in
        Cabs.CONSTANT(CONST_CHAR ([cval]))
    | Const_string (jstr) ->
        Cabs.CONSTANT(CONST_STRING (jstr))
    | Const_float (jstr) ->
        Cabs.CONSTANT(CONST_FLOAT (jstr))
    | Const_int32 (i) ->
        mkCabs_iconst (Int32.to_int i)
    | Const_int64 (i) ->
        mkCabs_iconst (Int64.to_int i)
    | Const_nativeint (i) ->
        mkCabs_iconst (Nativeint.to_int i)

  (* translation function for expresions *)
  let rec trans_e e (infor : cinfo ref) = 
    let curr_loc = e.exp_loc in
    let ns s = notSupported s curr_loc in
    match e.exp_desc with
      Texp_ident (pp1,_) ->
        let ppath = Path.name pp1 in
        if (DefSet.mem ppath !def_set) = false then
          glob_set := DefSet.add ppath !glob_set;
        Cabs.VARIABLE ppath
    | Texp_constant (c) ->
        texpcon_to_cabscon c
    | Texp_let (f,pel,je) ->
        ns "Let as expression" 
    | Texp_function (pel, partial) ->
        ns "Function definition in expression" 
    | Texp_apply (ee,eool) -> 
        begin
          match ee.exp_desc with
            Texp_ident (pp1,ll1) ->
              begin
                let make_op op = mkCabs_binop op trans_e eool infor  in
                let trans_arg eool n = (trans_e (unSome (fst (List.nth eool n))) infor) in
                match (Path.name pp1) with
                  (* Binary operations.  *)
                  "Pervasives.+" -> make_op (ADD) 
                | "Pervasives.-" -> make_op (SUB)
                | "Pervasives.*" -> make_op (MUL)
                | "Pervasives./" -> make_op (DIV)
                | "Pervasives.mod" -> make_op (MOD)
                | "Pervasives.land" -> make_op (BAND)
                | "Pervasives.lor" -> make_op (BOR)
                | "Pervasives.lxor" -> make_op (XOR)
                | "Pervasives.lsl" -> make_op (SHL)
                | "Pervasives.lsr" -> make_op (SHR)
                | "Pervasives.asr" -> make_op (SHR)
                | "Pervasives.=" -> make_op (EQ)
                | "Pervasives.<>" -> make_op (NE)
                | "Pervasives.<" -> make_op (LT)
                | "Pervasives.>" -> make_op (GT)
                | "Pervasives.<=" -> make_op (LE)
                | "Pervasives.>=" -> make_op (GE)
                | "Pervasives.compare" -> ns "Pervasives.compare" 
                | "Pervasives.&&" -> make_op (AND)
                | "Pervasives.&" -> ns "deprecated Pervasives.&"  
                | "Pervasives.||" -> make_op (OR)
                | "Pervasives.or" -> ns "deprecated Pervasives.or"  
                | "Pervasives.min" ->
                    let isVarOrConst x = 
                      (match (unSome (fst (List.nth eool x))).exp_desc with
                        Texp_ident _ -> true
                      | Texp_constant _ -> true
                      | _ -> false) in
                    if (not (isVarOrConst 0) || not (isVarOrConst 1)) then
                      warning "Code duplication in min" curr_loc;
                    let a0 = trans_arg eool 0 in
                    let a1 = trans_arg eool 1 in
                    Cabs.QUESTION(BINARY(LE, a0, a1), a0, a1) 
                | "Pervasives.max" ->
                    let isVarOrConst x = 
                      (match (unSome (fst (List.nth eool x))).exp_desc with
                        Texp_ident _ -> true
                      | Texp_constant _ -> true
                      | _ -> false) in
                    if (not (isVarOrConst 0) || not (isVarOrConst 1)) then
                      warning "Code duplication in max" curr_loc;
                    let a0 =  trans_arg eool 0 in
                    let a1 =  trans_arg eool 1 in
                    Cabs.QUESTION(BINARY(GE, a0, a1), a0, a1)
                | "Pervasives.+." -> make_op (ADD)
                | "Pervasives.-." -> make_op (SUB)
                | "Pervasives./." -> make_op (DIV)
                | "Pervasives.*." -> make_op (MUL) 
                | "Pervasives.**" ->
                    set_hdr req_hdrs.math_h;
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                    mkCabs_call "pow" [a0; a1]
                | "Pervasives.=="   -> ns "Pervasives.== as expression" 
                | "Pervasives.!="   -> ns "Pervasives.!=  as expression" 
                      (* Unary.  *)
                | "Pervasives.not"  -> ns "Pervasives.not as expression" 
                | "Pervasives.lnot" -> ns "Pervasives.lnot as expression" 
                | "Pervasives.~-"   -> Cabs.UNARY(MINUS, trans_arg eool 0)
                | "Pervasives.~-."  -> Cabs.UNARY(MINUS, trans_arg eool 0)
                | "Pervasives.succ" -> Cabs.BINARY(ADD, trans_arg eool 0, (mkCabs_iconst 1))
                | "Pervasives.pred" -> Cabs.BINARY(SUB, trans_arg eool 0, (mkCabs_iconst 1))
                      (* Floating-point functions.  *)
                | "Pervasives.cos" ->
                    set_hdr req_hdrs.math_h;
                    mkCabs_call "cos" [trans_arg eool 0]
                | "Pervasives.sin" ->
                    set_hdr req_hdrs.math_h;
                    mkCabs_call "sin" [trans_arg eool 0]
                | "Pervasives.sqrt" ->
                    set_hdr req_hdrs.math_h;
                    mkCabs_call "sqrt" [trans_arg eool 0]
                      (* Conversions.  *)
                | "Pervasives.float_of_int" ->
                    mkCabs_simple_cast Tfloat (trans_arg eool 0)
                | "Pervasives.float" ->
                    mkCabs_simple_cast Tfloat (trans_arg eool 0)
                | "Pervasives.int_of_float" ->
                    mkCabs_simple_cast Tint (trans_arg eool 0)
                | "Pervasives.string_of_int" -> ns "Pervasives.string_of_int" 
                | "Pervasives.int_of_string" -> ns "Pervasives.int_of_string" 
                | "Pervasives.string_of_float" -> ns "Pervasives.string_of_float" 
                | "Pervasives.float_of_string" -> ns "Pervasives.float_of_string" 
                      (* References.  *)
                | "Pervasives.ref" -> (trans_arg eool 0)
                | "Pervasives.!" -> (trans_arg eool 0)
                | "Pervasives.:=" ->
                    ns "Assignment (ref) as an expression" 
                | "Pervasives.incr" ->
                    ns "Incr as an expression" 
                | "Pervasives.decr" ->
                    ns "Decr as an expression" 
                      (* Arrays.  *)
                | "Array.make" ->
                    ns "Declaring an array in an expression" 
                | "Array.create" ->
                    ns "Declaring an array in an expression" 
                | "Array.make_matrix" ->
                    ns "Declaring a matrix in an expression" 
                | "Array.set" ->
                    ns "Assignment (array) as an expression" 
                | "Array.get" ->
                    let a0 = (trans_arg eool 0) in
                    let a1 = (trans_arg eool 1) in
                    INDEX(a0, a1) 
                      (* In the case below, the string comparisons seem to
                         be a good way of doing this because:
                         1. We cannot get a pattern that gives us the names
                         Pervasves or Arrays. This is because these are
                         in the Ident module (in Ident.name), which is a
                         part of a structure whose contens are not visible
                         externally.
                       *)
                | _ ->
                    let idname = Path.name pp1 in
                    if (String.length idname > 11
                          && (String.sub idname 0 11) = "Pervasives.") then
                      ns idname;
                    if (String.length idname > 6
                          && (String.sub idname 0 6) = "Array.") then
                      ns idname;
                    if (List.length eool) = 0 then
                      mkCabs_call (Path.name pp1) []
                    else if (List.length eool) = 1 then
                      let arg = unSome (fst (List.nth eool 0)) in
                      match (arg.exp_desc) with
                        Texp_tuple(expl) ->
                          let xlate = (fun le -> trans_e le infor) in
                          let cexpl = (List.map xlate expl) in
                          mkCabs_call (Path.name pp1) cexpl 
                      | _ ->
                          let cexp = trans_e arg infor in
                          mkCabs_call (Path.name pp1) [cexp]
                    else 
                      ns "Texp_apply with multiple arguments"
              end
          | _ -> ns "Texp_apply with non-identifier" 
        end
    | Texp_match (je,pel,partial) ->
        ns "Match as expression (match of non-unit type)" 
    | Texp_try (je,pel) -> ns "Texp_try" 
    | Texp_tuple el -> ns "Texp_tuple" 
    | Texp_construct (cd,el,_) -> ns "Texp_construct" 
    | Texp_variant (label, eo) -> ns "Texp_variant" 
    | Texp_record (del, eo) -> ns "Texp_record" 
    | Texp_field (je,ld) -> ns "Texp_field" 
    | Texp_setfield (e1,ld,e2) -> ns "Texp_setfield" 
    | Texp_array el -> ns "Texp_array" 
    | Texp_ifthenelse (e1,e2,eo) ->
        begin
          match eo with
            Some (eelse) -> 
              Cabs.QUESTION((trans_e e1 infor),(trans_e e2 infor),(trans_e eelse infor))
          |   None -> ns "Texp_ifthenelse without else" 
        end
    | Texp_sequence _ ->
        ns "Sequence as expression" 
    | Texp_while _ ->
        ns "While statement as expression" 
    | Texp_for _ ->
        ns "For statement as expression" 
    | Texp_when _ -> ns "Texp_when" 
    | Texp_send _ -> ns "Texp_send" 
    | Texp_new _ -> ns "Texp_new" 
    | Texp_instvar _ -> ns "Texp_instvar" 
    | Texp_setinstvar _ -> ns "Texp_setinstvar" 
    | Texp_override _ -> ns "Texp_override" 
    | Texp_letmodule _ -> ns "Texp_letmodule" 
    | Texp_assert _ -> ns "Assert statement as expression" 
    | Texp_assertfalse -> ns "Assertfalse statement as expression" 
    | Texp_lazy _ -> ns "Texp_lazy" 
    | Texp_bracket _ -> ns "Texp_bracket" 
    | Texp_escape _ -> ns "Texp_escape" 
    | Texp_run _ -> ns "Texp_run" 
    | Texp_runoffshore _ -> ns "Texp_runoffshore" 
    | Texp_runoffshore_arg _ -> ns "Texp_runoffshore_arg" 
    | Texp_cspval  _ -> ns "Texp_cspval" 
    | Texp_destruct _ -> ns "Texp_destruct" 
    | Texp_etag  _ -> ns "Texp_etag" 
    | Texp_object _ -> ns "Texp_object" 


  let marshall alist function_name call_return_type curr_loc = 
    (* header C function creation - for marshalling / unmarshalling *)
    let arg_total = (List.length alist) in   (* total arguments *)
    let marshalling_defs = ref [] in         (* marshalling definitions*)
    let marshalling_stmts = ref [] in        (* marshalling statements*)
    let unmarshalling_stmts = ref [] in      (* unmarshalling *)

    let add_decl argType ident_name declarat =  
      marshalling_defs :=
      !marshalling_defs@
      [TYPEDEF(
         ([argType],
          [(ident_name, declarat, [], cabs_location)]), 
         cabs_location)] in 
    let typeSp_to_str cargty = 
      (match cargty with 
           Tint -> "int" 
         | Tdouble -> "double" 
         | Tchar -> "char" 
         | _ -> raise 
             (OffshoringError "Unfamiliar type specifier passed in case of function"))  in 
    let doarg_wrapper = fun argpat arg_counter  -> 
      let is_array =  is_array_type argpat.pat_type in
      let cargtype = 
        if (is_array) then get_array_base_type argpat.pat_type curr_loc
        else (xlate_basic_type argpat.pat_type  curr_loc) in
      let ident = match argpat.pat_desc with
          Tpat_var(id) -> id | _ -> raise (OffshoringError "unexpected pattern") in
      let current_arg = VARIABLE(Ident.name ident) in
      let get_arg =
        if(arg_total>1) (* check how many arguments are passed in *)
        then mkCabs_call ("Field") 
          [VARIABLE("arg_list");
           VARIABLE(string_of_int(arg_counter-1))]
        else VARIABLE("arg_list") in
        (if (is_array) then (
           (* Get array dimensions *)
           let num_dims = array_num_dims argpat.pat_type curr_loc  in
             (* declare the array *)
           let decla = (if (num_dims > 1) then 
			  PTR([],PTR([],JUSTBASE))
			else PTR([],JUSTBASE)) in 
             (* add array identifier to the call signature
                of function  *) 
             (* add array declaration to global structure *)
             add_decl (SpecType(cargtype)) (Ident.name ident) decla;
             let assign_int var value =
               COMPUTATION(
                 mkCabs_assignment (var ^ string_of_int(arg_counter)) value,
                 cabs_location) in
             let get_array_args index =
               if(arg_total>1) 
               then [mkCabs_call ("Field") 
                       [VARIABLE("arg_list");
                        VARIABLE(string_of_int (arg_counter-1))];
                     VARIABLE(index)]
               else [VARIABLE("arg_list");VARIABLE(index)] in
             let rec sequence stat_list =
               (match stat_list with
                    [] -> NOP(cabs_location)
                  | [x] -> x
                  | x::xs ->
                      let y = sequence xs in
                        SEQUENCE (x, y, cabs_location)) in
               (* ONE-DIMENSION ARRAY MARSHALLING AND UNMARSHALLING *)                 
               if (num_dims = 1) then (
                 let trans_base_type type_marshaller get_field =
                   mkCabs_call type_marshaller
                     [mkCabs_call get_field
                        (get_array_args "i") ] in
                 let make_for_loop computation = 
                   FOR ( 
                     (* i = 0 *)
                     FC_EXP(mkCabs_assignment "i" (mkCabs_iconst 0)),
                     (* i < size *)
                     BINARY(LT,VARIABLE("i"),VARIABLE("size"^string_of_int(arg_counter))),
                     (* i++ *)
                     UNARY(POSINCR,VARIABLE("i")),
                     computation, 
                     cabs_location) in 
                 let trans_base_type_unmarsh  get_field var_info =
                   BINARY(ASSIGN,
			 (UNARY(MEMOF,(mkCabs_call get_field (get_array_args "i")))),
			  VARIABLE(var_info ^ "("^(Ident.name ident)^"[" ^ "i" ^ "])")) in
                   (* get array size from OCaml value *)
                   add_decl (SpecType(Tint)) ("size"^string_of_int(arg_counter)) JUSTBASE;
                   (* initialize size *)
                   marshalling_stmts:=
                   !marshalling_stmts@
                   [assign_int "size" (mkCabs_call ("Wosize_val") [get_arg])] @ 
                   (match cargtype with 
                      | Tdouble -> 
                          [assign_int "size" 
                             (VARIABLE("size" ^ string_of_int(arg_counter)^ "/Double_wosize"))]
                      | _ -> []) @
                   (* malloc the array *)
                   [COMPUTATION (
                      (mkCabs_assignment (Ident.name ident)
                         (CAST(
                            ([SpecType(cargtype)], (* specifier *)
                             PTR([],JUSTBASE)), (* decl_type *)
                            SINGLE_INIT ((* init_expression *)
                              mkCabs_call (" malloc") 
					   [ (* case on base type *)
					     VARIABLE( "sizeof("^ (typeSp_to_str cargtype)^") * "^
						       "size"^ string_of_int(arg_counter))])))),
                      cabs_location);
                    (* copy from Ocaml to C - construct for loop *)
                    make_for_loop 
                      (COMPUTATION (
                         mkCabs_assignment 
				      ((Ident.name ident)^"[i]")
				      (match cargtype with 
					   Tint -> trans_base_type "Long_val" "Field"
					 | Tdouble -> trans_base_type "" "Double_field"
					 | Tchar -> mkCabs_call ("toascii") 
					     [trans_base_type "Long_val" "Field"]
					 | _ -> NOTHING (*should not be reached error*)),cabs_location))];
                   (* copy back elements - unmarshalling *)
                   unmarshalling_stmts:= !unmarshalling_stmts@
                   [make_for_loop
                      (COMPUTATION(
                         (match cargtype with 
                              Tint -> trans_base_type_unmarsh  "&Field" "Val_long"
                            | Tdouble ->  mkCabs_call 
                                ("Store_double_field") 
                                  [get_arg;VARIABLE("i"); VARIABLE(""^(Ident.name ident)^"[i]")]
                            | Tchar -> (* same as Tint *)
                                trans_base_type_unmarsh  "&Field" "Val_long"
                            | _ -> NOTHING), cabs_location));
                    (* free memory *)
                    COMPUTATION(
                      mkCabs_call ("free") 
				  [VARIABLE(Ident.name ident)],cabs_location)])
                 (* TWO-DIMENSION ARRAY MARSHALLING AND UNMARSHALLING *)
               else if (num_dims > 1) then
                 ((* get array sizes from OCaml value *)
                   add_decl (SpecType(Tint)) ("size_i_"^string_of_int(arg_counter)) JUSTBASE;
                   add_decl (SpecType(Tint)) ("size_j_"^string_of_int(arg_counter)) JUSTBASE;
                   (* other temps used in process - can be shared in the future*)
                   add_decl (SpecType(Tint)) ("temp_"^string_of_int(arg_counter)) JUSTBASE;
                   add_decl (SpecType(Tvalue)) ("tmp_"^string_of_int(arg_counter)) JUSTBASE;
                   (* initialize size *)
                   let make_for_loop index bound computation= 
                     FOR ( 
                       (* e.g. index i, bound = size,  i = 0 *)
                       FC_EXP(mkCabs_assignment index (mkCabs_iconst 0)),
                       (* i < size *)
                       BINARY(LT,VARIABLE(index ),VARIABLE(bound ^ string_of_int(arg_counter))),
                       (* i++ *)
                       UNARY(POSINCR,VARIABLE(index)),
                       computation, 
                       cabs_location) in
                   let if_condition = 
                     IF (BINARY(LT,VARIABLE("size_j_"^string_of_int(arg_counter)),
				VARIABLE( "temp_" ^string_of_int(arg_counter))),
                         assign_int "size_j_" 
                           (VARIABLE("temp_" ^ string_of_int(arg_counter))),
                           NOP(cabs_location), cabs_location) in 
                     (* copy from Ocaml to C - construct for loop *)
                   let copy_from_OCaml wosize_var inner_loop_assignment_call =
                     make_for_loop "i" "size_i_" 
                       (sequence 
                          [assign_int "tmp_" 
                             (mkCabs_call "Field" (get_array_args "i"));
                           assign_int "temp_"
                             (mkCabs_call ("Wosize_val") [VARIABLE(wosize_var)]);
                           make_for_loop "j" "temp_" 
                             (COMPUTATION
                                ((mkCabs_assignment
                                    ((Ident.name ident) ^ "[i][j]")
                                    inner_loop_assignment_call),
                                 cabs_location))]) in
                     marshalling_stmts:=
                     !marshalling_stmts@
                     [assign_int "size_i_" (mkCabs_call ("Wosize_val") [get_arg]);
                      assign_int "size_j_" (VARIABLE("0"));
                      assign_int "temp_" (VARIABLE("0"));
                      (* figure the second dimension out *)
                      make_for_loop "i" "size_i_" 
                        (sequence 
                           [assign_int "temp_" 
                              (mkCabs_call ("Wosize_val") 
                                 [mkCabs_call "Field" (get_array_args "i")]);
                            if_condition]);
                      (* malloc the array *)
                      COMPUTATION (
                        mkCabs_assignment (Ident.name ident)
				     (CAST (
					([SpecType (cargtype)],
					 PTR([], PTR ([], JUSTBASE))), 
					SINGLE_INIT (
					  mkCabs_call ("malloc") 
						       [BINARY (MUL, 
								(TYPE_SIZEOF 
								   ([SpecType (cargtype)], PTR([], JUSTBASE))),
								VARIABLE ("size_i_"^ string_of_int(arg_counter)))]))),
				     cabs_location);
                      make_for_loop "i" "size_i_"
                        (COMPUTATION (
                           mkCabs_assignment
					(Ident.name ident ^ "[" ^ "i" ^ "]")
					(CAST(
					   ([SpecType (cargtype)], PTR([], JUSTBASE)), 
					   SINGLE_INIT (
					     mkCabs_call ("malloc") 
							  [BINARY (MUL, 
								   (TYPE_SIZEOF ([SpecType (cargtype)], JUSTBASE)),
								   (VARIABLE ("size_j_"^ string_of_int(arg_counter))))]))),
					cabs_location));
                      (match cargtype with 
                           Tint ->       
                             copy_from_OCaml 
                             ("tmp_" ^ string_of_int(arg_counter))
                             (mkCabs_call "Long_val"
                                [mkCabs_call "Field" 
                                   [VARIABLE("tmp_" ^ string_of_int(arg_counter)); 
                                    VARIABLE("j")]])
			 | Tdouble ->  
                             make_for_loop "i" "size_i_" 
                               (sequence 
                                  [assign_int "tmp_" 
                                     (mkCabs_call "Field" (get_array_args "i"));
                                   assign_int "temp_"
                                     (BINARY (DIV,
					      (mkCabs_call ("Wosize_val")
						 [VARIABLE("tmp_" ^ string_of_int(arg_counter))]),
					      (VARIABLE "Double_wosize")));
                                   make_for_loop "j" "temp_" 
                                     (COMPUTATION
					((mkCabs_assignment
                                            (Ident.name ident ^ "[i][j]")
                                            (mkCabs_call "Double_field" 
                                               [VARIABLE("tmp_" ^ string_of_int(arg_counter));
						VARIABLE("j")])),
					 cabs_location))]) 
			 | Tchar -> 
                             copy_from_OCaml 
                               ("tmp_" ^ string_of_int(arg_counter))
                               (mkCabs_call ("toascii") 
                                  [mkCabs_call ("Long_val")
                                     [mkCabs_call "Field" 
					[VARIABLE("tmp_" ^ string_of_int(arg_counter))];
                                      VARIABLE("j")]])
			 | _ -> NOP(cabs_location))];
                     (* copy back elements *)
                     unmarshalling_stmts:= !unmarshalling_stmts@
                     [COMPUTATION(VARIABLE(
				    " " ^ 
				    match cargtype with 
					Tint -> " for (i = 0; i < (size_i_" ^ string_of_int(arg_counter) ^ "); i++) {
                               tmp_" ^ string_of_int(arg_counter) ^ 
					  ( if(arg_total>1) 
					    then  " = (Field((Field(arg_list,"^ string_of_int(arg_counter-1) ^")),i))"
					    else  " = Field(arg_list,i); " )
					  ^ "
                               ; temp_" ^ string_of_int(arg_counter) ^ " = Wosize_val(tmp_" ^ 
					  string_of_int(arg_counter) ^ ");
                               for (j = 0; j < temp_" ^ string_of_int(arg_counter) ^ " ; j++) {
                                  (Field(tmp_" ^ string_of_int(arg_counter) ^ ",j)) = 
                                   Val_long(" ^ (Ident.name ident) ^ "[i][j]);
                                   }
                                }
                                "
				      | Tdouble ->  "
                              for (i = 0; i < (size_i_" ^ string_of_int(arg_counter) ^ "); i++) {
                                tmp_" ^ string_of_int(arg_counter) ^ 
					  ( if(arg_total>1) 
					    then  " = (Field((Field(arg_list,"^ string_of_int(arg_counter-1) ^")),i))"
					    else  " = Field(arg_list,i); " )
					  ^ "
                                    ; temp_" ^ string_of_int(arg_counter) ^ " = Wosize_val(tmp_" ^ 
					  string_of_int(arg_counter) ^ 
					  ")/Double_wosize;
                                      for (j = 0; j < temp_" ^ string_of_int(arg_counter) ^ " ; j++) {
                                      Store_double_field(tmp_" ^ string_of_int(arg_counter) ^ ",j," ^ 
					  (Ident.name ident) ^ "[i][j]);
                                      }
                                      }
                                  "
				      | Tchar -> (* same as Tint case *) "
                          for (i = 0; i < (size_i_" ^ string_of_int(arg_counter) ^ "); i++) {
                            tmp_" ^ string_of_int(arg_counter) ^ 
					  ( if(arg_total>1) 
					    then  " = (Field((Field(arg_list,"^ string_of_int(arg_counter-1) ^")),i))"
					    else  " = Field(arg_list,i); " )
					  ^ "
                                ; temp_" ^ string_of_int(arg_counter) ^ " = Wosize_val(tmp_" ^ 
					  string_of_int(arg_counter) ^ ");
                                 for (j = 0; j < temp_" ^ string_of_int(arg_counter) ^ " ; j++) {
                                 (Field(tmp_" ^ string_of_int(arg_counter) ^ ",j) = 
                                 Val_long(" ^ (Ident.name ident) ^ "[i][j]);
                                 }
                                 }
                              "
				      | _ -> "NOTHING" ),cabs_location)];
                     (* free memory *) 
                     unmarshalling_stmts:= !unmarshalling_stmts@
                     [make_for_loop "i" "size_i_"
                        (COMPUTATION 
                           ((mkCabs_call "free"
                               [INDEX ((VARIABLE (Ident.name ident)),
                                       (VARIABLE "i"))]),
                            cabs_location));
                      COMPUTATION (
                        (mkCabs_call "free" [VARIABLE (Ident.name ident)]), 
                        cabs_location)];
                     
                 )) (*closes 2-dim case*) 
         else ((* BASE TYPE MARSHALLING *)
           (* add argument identifier to function call signature *) 
           marshalling_defs:=
               (!marshalling_defs @ 
                [DECDEF( 
                   (* init_name_group *)
                   ([SpecType(cargtype)],
                    (* init_name list *)
                    [((Ident.name ident,JUSTBASE,[],cabs_location),
                      (SINGLE_INIT (* init_expression *) 
                         (match cargtype with
                              Tint -> 
                                mkCabs_call ("Int_val") [get_arg]
                            | Tchar ->
                                mkCabs_call ("toascii") 
                                  [mkCabs_call ("Long_val") [get_arg]]
                            | Tdouble ->
                                if(arg_total>1)
                                then mkCabs_call "Double_field"
                                  [VARIABLE "arg_list";
                                   VARIABLE(string_of_int(arg_counter-1))]
                                else mkCabs_call "Double_val" 
                                  [VARIABLE("arg_list")]
                            | _ -> raise (OffshoringError "Can't marshall disallowed type"))))]), 
                   cabs_location)]))); 
        current_arg in (* end of doarg_wrapper function *)
    let deflist_wrapper = 
      (* argument list for the marshalling function definition *)
      let cabs_sglnm_list_wrapper = 
        [([SpecType(Tvalue)],
          ((Ident.name(Ident.create "arg_list")), 
           JUSTBASE, [], cabs_location))] in
        (* add a return declaration to the marshalling stmts *)
        add_decl
          (SpecType(xlate_basic_type call_return_type curr_loc))  (* fbody.exp_type *)
          "ret" JUSTBASE;
        (* traverse the function argument list and prepare marsh/unmarshalling *)
        let do_all_args l =
          let rec da l n =
            (match l with
                 x::xs -> (doarg_wrapper x n) :: da xs (n+1)
               | [] -> []) in
            da l 1 in 
          if (List.exists (fun x -> is_array_type x.pat_type) alist)
          then (add_decl (SpecType(Tint)) "i" JUSTBASE; 
                add_decl (SpecType(Tint)) "j" JUSTBASE);
          let all_arguments = do_all_args alist in
            (* generate the return initialization (which is function call)
               and stick at end of marshalling *)         
            marshalling_stmts:=
            (* function call *)
            !marshalling_stmts@
            [COMPUTATION(
               (mkCabs_assignment "ret" 
                  (mkCabs_call function_name all_arguments)),
               cabs_location)];
            (* prepare the wrapper body *)
            (*doubles require special return *) 
            (match (xlate_basic_type call_return_type curr_loc) with
                 Tdouble -> add_decl (SpecType(Tvalue)) 
                   "store = alloc(Double_wosize, Abstract_tag)" 
                   JUSTBASE;
                   unmarshalling_stmts:=
                   !unmarshalling_stmts@
                   [COMPUTATION(
                      (mkCabs_call "Store_double_val" 
                         [VARIABLE("store");VARIABLE("ret")]),
                      cabs_location)]
               | _ -> ());
            let combined_marshalling_stmts =
              !marshalling_stmts@
              !unmarshalling_stmts@
              (* return stored value *)
              [RETURN(
                 (mkCabs_call 
                    (match (xlate_basic_type call_return_type curr_loc) with
                         Tint -> "Val_int" 
                       | Tchar -> "Val_long" 
                       | Tdouble -> "" 
                       | _ -> raise (OffshoringError "Can't marshall disallowed type"))
                    [VARIABLE(
                       match (xlate_basic_type call_return_type curr_loc) with
                           Tdouble -> "store"
                         | _ -> "ret")]),
                 cabs_location)] in
              (* finally put the wrapper pieces together *)
              (* wrapper return type *)
              [mkCabs_fundef [SpecType(Tvalue)]
                 (* function name and argument list *)
                 (function_name^"_marshall")
                 cabs_sglnm_list_wrapper
                 (* make body (add call initializing function in the beginning ) *)
                 (mkCabs_block [] [COMPUTATION((mkCabs_call ("initializer") []),cabs_location);
				   BLOCK((mkCabs_block !marshalling_defs combined_marshalling_stmts),cabs_location)])]
    in deflist_wrapper

   (* Translations of statements *)
  let rec trans_s e infor = 
    let curr_loc = e.exp_loc in
    let ns s = notSupported s curr_loc in
     match e.exp_desc with
      Texp_ident (pp1,ll1) ->
        trans_e e infor
    | Texp_constant (jcon) ->
        trans_e e infor
    | Texp_let (f,pel,je) ->
        if (List.length pel) > 1 then
          ns "Texp_let with multiple patterns";
        let v = (List.nth pel 0) in  (* v is a (pattern*expression) *)
        let (pat,pex) = v in
        let retexpr = match pat.pat_desc with
          Tpat_any -> ns "let with Tpat_any" 
        | Tpat_var (ident) -> 
            let proc_ident () =
              let initinfo = ref { globs = []; fname = (Ident.name ident); defs = []; stmts = [] } in
              let _ = trans_s pex initinfo in
              let innerinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
              let letexp = trans_s je innerinfo in
              infor := {
                globs = (!infor.globs)@(!initinfo.globs)@(!innerinfo.globs);
                fname = "";
                defs = (!infor.defs)@(!innerinfo.defs);
                stmts = (!infor.stmts)@(!innerinfo.stmts) };
              letexp in
            if (is_array_type pex.exp_type) then
              proc_ident ()
            else if (is_function_type pex.exp_type) then
              let _ = xlate_basic_type (get_func_return_type pex.exp_type) curr_loc in
              proc_ident () 
            else (* neither a function nor an array *)
              let ctyp =
                if (is_simple_ref_type pex.exp_type) then 
                  (* it's a reference type *)
                  get_simple_ref_base_type pex.exp_type curr_loc 
                else  (* it's a basic type *)
                  xlate_basic_type pex.exp_type curr_loc in
              let initinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
              let initexp = trans_e pex initinfo in
              let letname = (Ident.name ident) in
              let letdecl = [(mkCabs_simple_decl ctyp letname  NOTHING false)] in
              let asg = mkCabs_assignment letname initexp in
              def_set := DefSet.add letname !def_set;
              let innerinfo = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
              let letexp = trans_s je innerinfo in
              let blkdefs = !innerinfo.defs in
              let blkstmts = [COMPUTATION(asg, cabs_location)]@(!innerinfo.stmts) in
              if (!initinfo.defs <> [] || !initinfo.stmts <> []) then
                ns "unsupported let initializer" ;
              let globalize = (DefSet.mem letname !glob_set) in
              infor := {
                globs = (!infor.globs)@(if globalize then letdecl else [])@(!initinfo.globs)@(!innerinfo.globs);
                fname = "";
                defs = !infor.defs@(if (not globalize) then letdecl else [])@blkdefs;
                stmts = !infor.stmts@blkstmts };
              letexp
        | Tpat_alias (_,_) -> ns "let with Tpat_alias" 
        | Tpat_constant (_) -> ns "let with Tpat_constant" 
        | Tpat_tuple (_) -> ns "let with Tpat_tuple" 
        | Tpat_construct (_,_) -> ns "let with Tpat_construct" 
        | Tpat_variant (_,_,_) -> ns "let with Tpat_variant" 
        | Tpat_record _ -> ns "let with Tpat_record" 
        | Tpat_array (_) -> ns "let with Tpat_array" 
        | Tpat_or (_,_,_) -> ns "let with Tpat_or" 
        in retexpr
    | Texp_function (pel, partial) ->
        let def_set_temp_copy = !def_set in
        def_set := DefSet.empty;
	if(!is_nested) then
          ns "No nested functions allowed"; 
        is_nested := true; 
	
        if (List.length pel) <> 1 then
          ns "Texp_function with multiple arguments" 
        else
          begin         
            (* if function is anonymous - must be main user procedure *)
              if !infor.fname = "" then
              infor:={!infor with fname= runC.main_function_name};
             (* get argument list *)
            let parg = (fst (List.nth pel 0)) in
            let alist = 
              match (parg.pat_desc) with
                Tpat_tuple(patl) ->
                  let ff =  (fun le -> match le.pat_desc with
                    Tpat_var(ident) -> le
                  | _ -> ns "non-Tpat_var in args" ) in
                  (List.map ff patl)
              | Tpat_var(ident) ->
                  [parg]
              | _ ->
                  notSupported ("Texp_function with arg pattern `"
                                ^ (Parmatch.top_pretty Format.str_formatter parg;
                                   flush_str_formatter ()) ^ "'") curr_loc
            in
            let fbody = (snd (List.nth pel 0)) in
            let binfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
            (* translate function body *)
            let cabs_body = trans_s fbody binfo in
            (* convert one argument to C cabs *)
            let doarg = fun argpat  -> 
              let is_array =  is_array_type argpat.pat_type in
              let cargtype = 
                if (is_array) 
                then get_array_base_type argpat.pat_type curr_loc
                else xlate_basic_type argpat.pat_type  curr_loc in
              (* base type of the argument *)
              let cabs_arg_type = [SpecType(cargtype)] in
              let ident = 
                (match argpat.pat_desc with
                  Tpat_var(id) -> id 
                | _ -> raise (OffshoringError "unexpected pattern")) in
              (* type modifier *)
              let decla = 
                if (is_array) then
                  (if ((array_num_dims argpat.pat_type curr_loc) > 1) then 
                    PTR([],PTR([],JUSTBASE))
                  else  PTR([],JUSTBASE))
                else JUSTBASE in
              (* name of the argument *)
              let cabs_arg_name = ((Ident.name ident), decla, [], cabs_location) in
              (cabs_arg_type, cabs_arg_name) in
            (* convert all arguments to C cabs *)
            let cabs_arg_list = List.map doarg alist in
            (* body of the function *)
            let newstmts = !binfo.stmts@[RETURN(cabs_body, cabs_location)] in
            (* create cabs for function definition *)
            let deflist = 
              [mkCabs_fundef [SpecType(xlate_basic_type fbody.exp_type curr_loc)]
                 !infor.fname cabs_arg_list
                 (mkCabs_block !binfo.defs newstmts) ] in 
	    (* marshalling *)
	    let marshall_function = 
	      if (!infor.fname = runC.main_function_name) 
	      then
		marshall alist runC.main_function_name fbody.exp_type curr_loc
	      else 
		[]
	    in
            infor := {!infor with globs =
		       !infor.globs @
                       !binfo.globs @
                       deflist @
                       [IFDEF("OCAML_COMPILE",cabs_location)] @
                       marshall_function @
                       [ENDIF(cabs_location)] };
            def_set := def_set_temp_copy;
	    is_nested:=false;
            Cabs.NOTHING
          end  
    | Texp_apply (ee,eool) -> 
        begin
		  let init_array name base_type dim size init_value = 
            (let rec  make_list size iv =
              if (size = 0) then [] else
              (NEXT_INIT, iv):: (make_list (size-1) iv) in
		    (match dim with
			  1 -> [(mkCabs_array_init_decl1
					   base_type 
					   name 
					   (List.hd size) 
					   cabs_location 
					   (COMPOUND_INIT (make_list (List.hd size) init_value)))] 
			| 2 -> 
				let name_gen decls r  = Printf.sprintf "%s_row_%d" name r in
				let rec f decls r current_row = 
				  if current_row = List.hd ( size) 
				  then (decls, (List.rev r))
				  else
					let new_name = (name_gen name current_row) in 
					let row_decl = 
					  (mkCabs_array_init_decl1
						 base_type 
						 (name_gen name current_row) 
						 (List.hd ( List.tl size)) 
						 cabs_location 
						 (COMPOUND_INIT (make_list  (List.hd (List.tl size)) init_value))) in
					f (row_decl::decls) ((NEXT_INIT,  SINGLE_INIT (VARIABLE new_name))::r) (current_row+1) in 
				let (row_decls, inits) = f [] [] 0 in  
				(List.rev 
				   ((  
					Cabs.DECDEF
					  (([Cabs.SpecType base_type],
						[((name, Cabs.PTR ([], Cabs.ARRAY (Cabs.JUSTBASE, [], Cabs.NOTHING)),
						   [],
						   cabs_location),
						  COMPOUND_INIT inits)]),cabs_location) )
					:: row_decls))
			| _ -> raise (OffshoringError "Internal error in array delcaration generator\n" ))) in 
		  match ee.exp_desc with
			Texp_ident (pp1,ll1) ->
					begin
					  match (Path.name pp1) with
						(* References.  *)
                  "Pervasives.:=" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                    let varname = (match a0 with
                      VARIABLE(nstr) -> nstr
                    | _ -> raise (OffshoringError "Expected VARIABLE in :=")) in
                    mkCabs_assignment varname a1
                | "Pervasives.incr" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    Cabs.UNARY(PREINCR, a0)
                | "Pervasives.decr" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    Cabs.UNARY(PREDECR, a0)
                      (* Arrays.  *)
                | "Array.make" ->
                    let arg0 = unSome (fst (List.nth eool 0)) in 
                    let arg1 = unSome (fst (List.nth eool 1)) in 
                    let sz = (match arg0.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> ns "non-constant array size" ) in
                    let init_val = (match arg1.exp_desc with
		      Texp_constant(x) -> SINGLE_INIT (trans_e arg1 infor)
                    | _ -> ns "non-constant array value" ) in
                    let ctyp = get_array_base_type e.exp_type curr_loc in
		    let init_decls = init_array (!infor.fname) ctyp 1  [sz] init_val in
                    (* let decl = mkCabs_array_init_decl1 ctyp  sz cabs_location init in *)
                    infor := { !infor with
                               globs = (!infor.globs)@init_decls};
                    NOTHING
                | "Array.create" ->
                    ns "deprecated Array.create (use Array.make)" 
                | "Array.make_matrix" ->
                    (* FIXME: For now, we ignore the third (initialization)
                       argument.  *)
                    let arg0 = unSome (fst (List.nth eool 0)) in 
                    let _ = unSome (fst (List.nth eool 1)) in 
                    let arg2 = unSome (fst (List.nth eool 2)) in 
                    let sz1 = (match arg0.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> ns "non-constant array size" ) in
                    let arg1 = unSome (fst (List.nth eool 1)) in 
                    let sz2 = (match arg1.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> ns "non-constant array size" ) in
		    let init_val = (match arg2.exp_desc with
		      Texp_constant(x) -> SINGLE_INIT (trans_e arg2 infor)
                    | _ -> ns "non-constant array value" ) in
                    let ctyp = get_array_base_type e.exp_type curr_loc in
		    let decls = init_array (!infor.fname) ctyp 2 [sz1;sz2] init_val in
                    (* let arrdecl = (mkCabs_array_init_decl2 ctyp !infor.fname sz1 sz2 cabs_location init ) in *)
                    infor := { !infor with
                               globs = (!infor.globs)@decls};
                    NOTHING
                | "Array.set" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                    let a2 = (trans_e (unSome (fst (List.nth eool 2))) infor) in
                    let idxexp = INDEX(a0, a1) in
                    Cabs.BINARY(ASSIGN, idxexp, a2)
                | "Array.get" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                    INDEX(a0, a1) 
                      (* A call of anything else.  *)
                | _ ->
                    trans_e e infor
              end
          | _ -> ns "Texp_apply with non-identifier" 
        end
    | Texp_match (je,pel,partial) ->
        if (is_unit_type e.exp_type)=false then
          ns "match of non-unit type" ;
        let need_default =  
          not (List.exists 
            (fun (x,_) -> 
		match x.pat_desc with
		   Tpat_any -> true
                 | _ -> false) pel) in
        let _ = (xlate_basic_type je.exp_type curr_loc) in
        let sexpinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
        let sexp = trans_e je sexpinfo in
        let ss = List.map (
          fun (pat,mex) ->
            let caseinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
            let caseexp = trans_s mex caseinfo in
            let casestmts = !caseinfo.stmts@([COMPUTATION(caseexp, cabs_location)]) in
              infor := {
                globs = (!infor.globs)@(!caseinfo.globs);
                fname = "";
                defs = (!infor.defs)@(!caseinfo.defs);
                stmts = !infor.stmts };
              let caseblk = BLOCK((mkCabs_block !caseinfo.defs
                                     (casestmts@[BREAK(cabs_location)])), cabs_location) in
            match pat.pat_desc with 
              Tpat_constant(mcon) ->
                CASE(texpcon_to_cabscon mcon, caseblk, cabs_location)
            | Tpat_any ->
                DEFAULT(caseblk, cabs_location)
            | _ -> ns "non-constant match pattern" 
         ) pel in
        (if need_default then
          set_hdr req_hdrs.assert_h);
        let call = mkCabs_call "assert" [mkCabs_iconst 0] in
        let deflt = DEFAULT(COMPUTATION(call, cabs_location), cabs_location) in
        let cases = (if need_default=true then (ss@[deflt]) else ss) in
        let swblk = BLOCK((mkCabs_block [] cases), cabs_location) in
        let switch = SWITCH(sexp, swblk, cabs_location) in
        infor := {
          globs = !infor.globs;
          fname = "";
          defs  = !infor.defs;
          stmts = !infor.stmts@[switch] };
        Cabs.NOTHING 
    | Texp_try (je,pel) -> ns "Texp_try" 
    | Texp_tuple el -> ns "Texp_tuple" 
    | Texp_construct (cd,el,_) -> ns "Texp_construct" 
    | Texp_variant (label, eo) -> ns "Texp_variant" 
    | Texp_record (del, eo) -> ns "Texp_record" 
    | Texp_field (je,ld) -> ns "Texp_field" 
    | Texp_setfield (e1,ld,e2) -> ns "Texp_setfield" 
    | Texp_array el -> ns "Texp_array" 
    | Texp_ifthenelse (e1,e2,eo) ->
        if not(is_unit_type e.exp_type) then
          trans_e e infor
        else 
          begin
            let e1info = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
            let e1exp = trans_e e1 e1info in
            let e2info = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
            let e2exp = trans_s e2 e2info in
            let e3info = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
            let e3exp = begin
              match eo with
                Some (eelse) -> trans_s eelse e3info
              | None -> NOTHING
            end in
            let e2stmts = !e2info.stmts@([COMPUTATION(e2exp, cabs_location)]) in
            let e3stmts = !e3info.stmts@([COMPUTATION(e3exp, cabs_location)]) in
            let blk2 = BLOCK((mkCabs_block !e2info.defs e2stmts), cabs_location) in
            let blk3 = BLOCK((mkCabs_block !e3info.defs e3stmts), cabs_location) in
            let ifstmt = IF(e1exp, blk2, blk3, cabs_location) in
            infor := {
              globs = (!infor.globs)@(!e2info.globs)@(!e3info.globs);
              fname = "";
              defs  = !infor.defs;
              stmts = !infor.stmts@[ifstmt] };
            NOTHING
          end
    | Texp_sequence (e1,e2) ->
        let e1info = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
        let e1exp = trans_s e1 e1info in
        let e2info = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
        let e2exp = trans_s e2 e2info in
        (* The e1 "statement" might be just an expression.*)
        let e1stmts = !e1info.stmts@([COMPUTATION(e1exp, cabs_location)]) in
        infor := {
          globs = (!infor.globs)@(!e1info.globs)@(!e2info.globs);
          fname = "";
          defs  = !infor.defs@(!e1info.defs)@(!e2info.defs);
          stmts = !infor.stmts@(e1stmts)@(!e2info.stmts) };
        e2exp
    | Texp_while (e1,e2) ->
        let cexpinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
        let cexp = trans_e e1 cexpinfo in
        let innerinfo = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
        let we = trans_s e2 innerinfo in
        let wbodyexp = COMPUTATION(we, cabs_location) in
        let blk = mkCabs_block !innerinfo.defs (!innerinfo.stmts@[wbodyexp]) in
        let wstmt = Cabs.WHILE(cexp, BLOCK(blk, cabs_location), cabs_location) in
        infor := {
          globs = (!infor.globs)@(!cexpinfo.globs)@(!innerinfo.globs);
          fname = "";
          defs  = !infor.defs;
          stmts = !infor.stmts@[wstmt] };
        Cabs.NOTHING
    | Texp_for (id,e1,e2,df,e3) ->
        (* The induction variable is always type int in Ocaml.  *)
        let initinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
        let initexp = trans_e e1 initinfo in
        let ivname = Ident.name id in
        let ivdecl = [(mkCabs_simple_decl Tint ivname NOTHING false)] in
        let ivasg = FC_EXP(mkCabs_assignment ivname initexp) in
        let ubexpinfo = ref { globs = []; fname = ""; defs = []; stmts = [] } in
        let ubexp = trans_e e2 ubexpinfo in
        let condexp = (match df with 
          Upto   -> BINARY(LE, VARIABLE(ivname), ubexp)
        | Downto -> BINARY(GE, VARIABLE(ivname), ubexp)) in
        let innerinfo = (ref { globs = []; fname = ""; defs = []; stmts = [] }) in
        let fe = trans_s e3 innerinfo in
        let fbodyexp = COMPUTATION(fe, cabs_location) in
        let blk = mkCabs_block !innerinfo.defs (!innerinfo.stmts@[fbodyexp]) in
        let ivupdate = (match df with 
          Upto   -> UNARY(POSINCR, VARIABLE(ivname))
        | Downto -> UNARY(POSDECR, VARIABLE(ivname))) in
        let fstmt = FOR(ivasg, condexp, ivupdate, BLOCK(blk, cabs_location), cabs_location) in
        infor := {
          globs = (!infor.globs)@(!initinfo.globs)@(!ubexpinfo.globs)@(!innerinfo.globs);
          fname = "";
          defs  = !infor.defs@ivdecl;
          stmts = !infor.stmts@[fstmt] };
        Cabs.NOTHING
    | Texp_when (e1,e2) -> ns "Texp_when"
    | Texp_send (je,m) ->  ns "Texp_send" 
    | Texp_new (p,d) ->    ns "Texp_new" 
    | Texp_instvar (p1,p2) -> ns "Texp_instvar" 
    | Texp_setinstvar (p1,p2,je) -> ns "Texp_setinstvar" 
    | Texp_override (p,pel) -> ns "Texp_override" 
    | Texp_letmodule (i,me,e) -> ns "Texp_letmodule" 
    | Texp_assert je -> 
        let a0 = trans_e je infor in 
        set_hdr req_hdrs.assert_h;
        let call = mkCabs_call "assert" [a0] in
        infor := { !infor with
                   stmts = !infor.stmts@[COMPUTATION(call, cabs_location)] };
        Cabs.NOTHING
    | Texp_assertfalse -> 
        set_hdr req_hdrs.assert_h;
        let call = mkCabs_call "assert" ([mkCabs_iconst 0]) in
        infor := { !infor with
                   stmts = !infor.stmts@[COMPUTATION(call, cabs_location)] };
        Cabs.NOTHING
    | Texp_lazy je -> ns "Texp_lazy" 
    | Texp_bracket je -> ns "Texp_bracket" 
    | Texp_escape je -> ns "Texp_escape" 
    | Texp_run je -> ns "Texp_run" 
    | Texp_runoffshore(je,s) -> ns "Texp_runoffshore" 
    | Texp_runoffshore_arg(e_rec,e) 
      -> ns "Texp_runoffshore_arg" 
    | Texp_cspval (v,li) -> ns "Texp_cspval" 
    | Texp_destruct(cd,je,_) -> ns "Texp_destruct" 
    | Texp_etag (a,je,e1,env_exp) -> ns "Texp_etag" 
    | Texp_object _ -> ns "Texp_object" 
          (***********************)
          (* The following functions allow one to isolate
             translation, pretty print + C compilation, and execution.  *)
  let toC x =  (* 'a code -> string*string *)
    let env = Env.empty in
    let texp = Typecore.type_expression env (Obj.magic x) in
    req_hdrs.math_h := false;
    req_hdrs.stdlib_h := false;
    req_hdrs.assert_h := false;
    req_hdrs.mlvalues_h := true;
    init_translation ();
    let info = ref { globs = []; fname = ""; defs = []; stmts = []; } in
    let cabsexp = trans_s texp info in
    let incs = deflist_of_reqhdrs req_hdrs in
    let newcabsexp = 
      (match cabsexp with NOTHING -> (mkCabs_iconst 0) | 
      _ -> cabsexp) in
    info := { globs = ([IFDEF("OCAML_COMPILE",cabs_location)])@
              (incs)@
              ([ENDIF(cabs_location)])@
              !info.globs;
              fname = "";
              defs = !info.defs;
              stmts = !info.stmts };
    let main_function = 
      ([IFDEF("OCAML_COMPILE",cabs_location)])@
      [mkCabs_fundef [SpecType(Tint)] "main" [] 
	 (mkCabs_block !info.defs (!info.stmts@[RETURN(newcabsexp, cabs_location)])) ]@ 
      [ENDIF(cabs_location)]
    in
    let initializer_function_proto = 
      mkCabs_simple_decl Tvoid ("initializer()") NOTHING false
    in
    let initializer_function = 
     [mkCabs_fundef [SpecType(Tvoid)] "initializer" [] 
         (mkCabs_block !info.defs !info.stmts)]
    in
    (* kedar begin - extract function headers *)
    let rec proc_globs (l) =
      (match l with
        FUNDEF (proto,_,_,_)::xs ->
          let emptyblock = {blabels = [];battrs = []; bdefs = []; bstmts = []} in
          let l' = FUNDEF (proto,emptyblock,cabs_location,cabs_location) in
          let s = prettyPrintCabsToString ("", [l']) in
          let sl = String.length s in
          let s' = ((String.sub s 0 (sl - 6)) ^ ";") in
          s':: proc_globs xs
      | _::xs -> proc_globs xs
      | [] -> []) in
    let all_proto l = String.concat "\n" (proc_globs l) in
    (* kedar end *)
    let c_program_ast = ("our program", 
			     [initializer_function_proto]
			   @ !info.globs
			   @ initializer_function
			   @ main_function) in
    ((all_proto (!info.globs)), 
     (prettyPrintCabsToString c_program_ast))
      (* no marshalling helpers; just run *)
  
(* XXX  *) 
let buildCexe cstr compiler compiler_flags working_dir file_name= 
  let command1 = (* Different stuff by defult on mac os x *)
	match (Config.architecture, Config.model, Config.system) with 
	| ("power","ppc","rhapsody") ->
		("cd " ^  working_dir ^
         " ; cat > " ^ file_name ^ ".c" ^ " << EOF\n" ^ 
         cstr ^ "\nEOF\n")
	| _ -> ("cd " ^  working_dir ^
            " ; cat > " ^ file_name ^ ".c" ^ " << EOF\n" ^ 
            cstr ^ "\nEOF\n") in
  let gcc_command = 
	match (Config.architecture, Config.model, Config.system) with 
	  (_,_,_) -> ("cd " ^  working_dir ^ 
                  " ; " ^ compiler  ^ " " ^ 
                  compiler_flags ^ " -lm -DRUNINC -DOCAML_COMPILE " ^
                  file_name ^ ".c") in
    let _ = Sys.command command1  in
  (* ed: RUNINC define added since config.h in installed in same
     directory as m.h & s.h. This way config.h knows whether
     it's being built in ocaml (in which case it looks for
     these headers in ../config/) or in runinc (where the
     headers are in the same directory (./). *)
  
  let res = Sys.command  gcc_command in
  if res <> 0 then 
    raise (OffshoringError "buildCexe in trx.ml: C compiler gave errors for temp.c")

let runCexe working_dir = 
  let a_out_name = 
	match Config.system with 
	  "cygwin" -> "a.exe"
	| _ -> "a.out" in

  Sys.command ("cd " ^  working_dir ^ " ; ./"^a_out_name)
      (* marshalling involved helpers *)
      (* add to code a file *)
  let addToLibrary some_code working_dir file_name =
    let str = open_out (working_dir ^ "/" ^ file_name ^ ".c") in
    let _ = output_string str some_code in 
    close_out str
      (* building the libraries.  *)
  let buildLibs cc compiler_flags working_dir file_name =
    (*    let picflags = "-O2 " ^ " -fPIC -DOCAML_COMPILE" in *)
    let picflags = compiler_flags ^ " -fPIC -DOCAML_COMPILE" in 
	let lib_file_name = 
	  match Config.system with 
		"cygwin" -> file_name^".dll"
	  | _        -> file_name^".so" in
	let gcc_command = (* Different stuff by defult on mac os x *)
	  match (Config.architecture, Config.model, Config.system) with 
	  | ("power","ppc","rhapsody") ->
		  ("cd " ^  working_dir ^ " ; " ^ 
           cc ^ " " ^ file_name ^ ".o " ^ "-bundle -flat_namespace -undefined suppress -o lib"
		   ^ lib_file_name ^ " ")
	  | _ -> ("cd " ^  working_dir ^ " ; " ^ 
			  cc ^ " -shared -o lib" ^ file_name ^ ".so " ^  
			  file_name ^ ".o  2>&1 > /dev/null") in
	let compile_command = ("cd " ^  working_dir ^ " ; " ^
                            cc ^ " " ^ picflags ^ 
                            " -c " ^ file_name ^ ".c  -o " ^ file_name ^ ".o"
                            ^ " 2>&1 > /dev/null") in
	let _ = if !Clflags.offshoring_show_gcc
		then Printf.printf "\n GCC invoked with %s \n" compile_command in 
    let res1 = Sys.command compile_command in 
	let _ = if !Clflags.offshoring_show_gcc
	        then Printf.printf "\n GCC invoked with %s \n" gcc_command in
	let res2 = Sys.command gcc_command in
    if res1 <> 0 then 
      raise (OffshoringError "buildLibs in trx.ml: Error in compiling .c file");
    if res2 <> 0 then 
      raise (OffshoringError "buildLibs in trx.ml: Error in dynamic library creation")
  let currentLib = ref (Dl.dl_dummy_library ())
      (* calls the generated marshaller *)
  let translate code_fun _marshall compiler compiler_flags 
      working_dir file_name main_function_name = 
    let (_,f) = (toC code_fun) in
    (*Printf.printf "%s\n" f;*) (* debugging *)
    addToLibrary f working_dir file_name;
    buildLibs compiler compiler_flags working_dir file_name;
    currentLib := Dl.dl_open (working_dir ^ "/lib" ^ file_name ^ ".so");
    let sym_fun = Dl.dl_sym !currentLib (runC.main_function_name
                                         ^ _marshall) in
    sym_fun
      (* translate to C, compile, and execute *)
  let runInCarg (x:('a,int) code) compiler compiler_flags working_dir file_name=
    let (_,f) =  (toC x) in 
    buildCexe f compiler compiler_flags working_dir file_name;
    runCexe working_dir
    
      (* translate to C, compile, and load to memory *)
  let runInCf_all_arg code_fun compiler compiler_flags working_dir file_name 
      main_function_name = 
    let sym_fun = translate code_fun "_marshall" 
        compiler compiler_flags working_dir 
        file_name main_function_name in
    let ret_fun = (Dl.call_all sym_fun: 'a -> 'b ) in
    ret_fun

  let closeCurrentLib () =
    Dl.dl_close (!currentLib)
end
    (* End of module C.  *)


(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(* This module contains the F90-specific offshoring functionality.     *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

module OffshoreF = struct

  open F90abs


  exception ErrorInRunInF of string;;

let error s = raise (ErrorInRunInF s)


type runF_record = { lang: string; compiler: string; 
                     compiler_flags:string; 
                     working_dir: string; f90_lib_path: string; file_name:string;
                     main_function_name: string}

let runF = {lang="F"; compiler = "ifort"; 
            compiler_flags="-O3 -xW"; 
            f90_lib_path ="/local/intel/lib";
            working_dir=".";file_name="test";
            main_function_name="procedure"}

let getDefaultArg s = 
  match s with 
    "lang" -> runF.lang
  | "compiler" -> runF.compiler
  | "compiler_flags" -> runF.compiler_flags
  | "f90_lib_path" -> runF.f90_lib_path
  | "working_dir" ->  runF.working_dir
  | "file_name" -> runF.file_name
  | "main_function_name" ->  runF.main_function_name
  | _ ->  fatal_error("Trx: F Unsupported option: " ^ s)

let curr_loc = ref Location.none

let print_loc loc =
  Location.print Format.std_formatter loc

let notSupported s loc = print_loc loc; error (s ^ " (unsupported subset)")

    (* Translation.  *)

type cinfo = 
    {
     globs: F90abs.fspecification list;        
     subprogs: F90abs.fsubprog_def list;       
     fname: string;                            
     defs: F90abs.fspecification list;         
     stmts: F90abs.fstatement list;            
   }

      (* set (no duplicates) to collect variables *)
module DefSet =
  Set.Make(struct
    type t = string
    let compare = Pervasives.compare
  end)

let glob_set = ref DefSet.empty
let def_set  = ref DefSet.empty

let init_translation _ =
  glob_set := DefSet.empty;
  def_set  := DefSet.empty

let let_isrec = ref false

let tmpcnt = ref 0
let get_tmp_name str =
  tmpcnt := !tmpcnt + 1;
  str ^ (string_of_int !tmpcnt) ^ "__" 

                                    (* Translate a type_expr into a F90abs type.  [type_expr -> fbasic_type].
                                       This is used when the caller expects only to translate base types
                                       (i.e., no references).  *)
let xlate_basic_type te curr_loc =
  match type_expr_to_string te with
    "<int>" -> Ftype_integer(None)
  | "<float>" -> Ftype_dbl_prec
  | "<bool>" -> Ftype_logical(None)
  | "<char>" -> Ftype_character(None)
  | "<string>" -> notSupported "xlate_basic_type: string" curr_loc
  | "<unit>" -> notSupported "xlate_basic_type: unit" curr_loc
  | _ -> notSupported ("xlate_basic_type: " ^ (type_expr_to_string te)) curr_loc

let get_simple_ref_base_type te curr_loc =
  let te_str = type_expr_to_string te in
  match te_str with
    "<int ref>" -> Ftype_integer(None)
  | "<float ref>" -> Ftype_dbl_prec
  | "<bool ref>" -> Ftype_logical(None)
  | "<char ref>" -> Ftype_character(None)
  | _ -> notSupported ("reference type " ^ te_str) curr_loc

let is_simple_ref_type te =
  let te_str = type_expr_to_string te in
  match te_str with
    "<int ref>" -> true
  | "<float ref>" -> true
  | "<bool ref>" -> true
  | "<char ref>" -> true
  | _ -> false

let get_array_base_type te curr_loc =
  let te_str = type_expr_to_string te in
  match te_str with
    "<int array>" -> Ftype_integer(None)
  | "<float array>" -> Ftype_dbl_prec
  | "<bool array>" -> Ftype_logical(None)
  | "<char array>" -> Ftype_character(None)
  | "<int array array>" -> Ftype_integer(None)
  | "<float array array>" -> Ftype_dbl_prec
  | "<bool array array>" -> Ftype_logical(None)
  | "<char array array>" -> Ftype_character(None)
  | _ -> notSupported ("array type " ^ te_str) curr_loc

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

let array_num_dims te  curr_loc=
  let te_str = type_expr_to_string te in
  match te_str with
    "<int array>" -> 1 
  | "<float array>" -> 1 
  | "<bool array>" -> 1
  | "<char array>" -> 1
  | "<int array array>" -> 2
  | "<float array array>" -> 2
  | "<bool array array>" -> 2
  | "<char array array>" -> 2
  | _ -> notSupported ("array type " ^ te_str) curr_loc

let is_unit_type te = 
  match type_expr_to_string te with "<unit>" -> true | _ -> false

let is_function_type te =
  match te.desc with
    Tarrow _ -> true
  | _ -> false

let get_func_return_type te =
  match te.desc with
    Tarrow(lab,te1,te2,com) ->
      let rec gfrt ttee =
        match ttee.desc with
          Tarrow(ilab,ite1,ite2,icom) -> gfrt ite2
        | _ -> te2 in gfrt te2
  | _ -> raise (OffshoringError "expected arrow type")

let mkF90abs_iconst n =
  Fexp_const(Fconst_int ((string_of_int n), None))

let mkF90abs_binop op trans_e eool info =
  Fexp_binary(op,
              (trans_e (unSome (fst (List.nth eool 0))) info),
              (trans_e (unSome (fst (List.nth eool 1))) info))

let mkF90abs_intrin2 intrin trans_e eool info =
  Fexp_intrinsic(intrin, 
                 [(trans_e (unSome (fst (List.nth eool 0))) info);
                  (trans_e (unSome (fst (List.nth eool 1))) info)])

let mkF90abs_intrin1 intrin trans_e eool info =
  Fexp_intrinsic(intrin, 
                 [(trans_e (unSome (fst (List.nth eool 0))) info)])

let mkF90abs_shift_intrin2 intrin trans_e eool info is_left =
  let a0 = (trans_e (unSome (fst (List.nth eool 0))) info) in
  let a1 = (trans_e (unSome (fst (List.nth eool 1))) info) in
  let sc = if is_left then a1 else Fexp_unary(Funop_minus, a1) in
  Fexp_intrinsic(intrin, [a0; sc])

let mkF90abs_simple_decl fabstype varname expr isconst =
  let attrlist = 
    if isconst = true then
      [Fattr_parameter]
    else
      []
  in
  let init_expr =
    match expr with 
      Fexp_nop -> None
    | _ -> Some(expr)
  in
  let initnmlist = [(varname, init_expr)] in
  Fspec_decl(fabstype, attrlist, initnmlist)

    (* A size of -1 means omit the upper bound (for "assumed shape")
       and -2 means make "assumed size".  *)
let mkF90abs_array_decl1 fabstype varname size =
  let fsub =
    if size = -1 then
      Fsub_triplet(Some(mkF90abs_iconst 0), None, None) 
    else if size = -2 then
      Fsub_triplet(Some(mkF90abs_iconst 0), Some(Fexp_const(Fconst_star)), 
                   None)
    else
      Fsub_triplet(Some(mkF90abs_iconst 0), Some(mkF90abs_iconst (size-1)), 
                   None) in
  let attrlist = [Fattr_dimension([fsub])] in
  let initnmlist = [(varname, None)] in
  Fspec_decl(fabstype, attrlist, initnmlist)

let mkF90abs_ptr_decl1 cabstype varname expr =
  notSupported "pointer declaration" Location.none

    (* A size of -1 means omit the upper bound (for "assumed shape").  *)
let mkF90abs_array_decl2 fabstype varname size1 size2 =
  let fsub1 =
    if size1 = -1 then
      Fsub_triplet(Some(mkF90abs_iconst 0), None, None)
    else
      Fsub_triplet(Some(mkF90abs_iconst 0), Some(mkF90abs_iconst (size1-1)), 
                   None) in
  let fsub2 =
    if size2 = -1 then
      Fsub_triplet(Some(mkF90abs_iconst 0), None, None)
    else
      Fsub_triplet(Some(mkF90abs_iconst 0), Some(mkF90abs_iconst (size2-1)), 
                   None) in
  let attrlist = [Fattr_dimension([fsub1; fsub2])] in
  let initnmlist = [(varname, None)] in
  Fspec_decl(fabstype, attrlist, initnmlist)

let mkF90abs_assignment varname expr =
  Fstmt_assign(Fvar_ident(varname), expr)

let mkF90abs_call namestr fabsexpl =
  Fexp_fcall(namestr, fabsexpl)

let mkF90abs_subprogbody defs bstmts =
  { specs = defs;
    fstmts = bstmts;
    contained = []; }

let mkF90abs_fundef rettype fname (args: string list) isrec fbody =
  let funtype_spec = if isrec then
    Fspec_decl(rettype, [], [((fname ^ "_res"), None)]) 
  else
    Fspec_decl(rettype, [], [(fname, None)]) in
  let pre_specs = [Fspec_use("globals", Some([(("loc" ^ fname), fname)])); Fspec_implicit_none; funtype_spec] in
  let body2 = { fbody with specs = pre_specs@fbody.specs; } in
  if isrec then
    Fsubprog(Fhdr_recfunction(fname, args, (fname ^ "_res")), body2)
  else
    Fsubprog(Fhdr_function(fname, args), body2)

let mkF90abs_fun_interface rettype fname (args: string list) isrec specl =
  let funtype_spec = if isrec then
    Fspec_decl(rettype, [], [((fname ^ "_res"), None)]) 
  else
    Fspec_decl(rettype, [], [(fname, None)]) in
  let pre_specs = [Fspec_implicit_none; funtype_spec] in
  let intfc_subprog = if isrec then
    Finterface_subprog(Fhdr_recfunction(fname, args, (fname ^ "_res")), pre_specs@specl)
  else
    Finterface_subprog(Fhdr_function(fname, args), pre_specs@specl) in
  Finterface_blk(None, [intfc_subprog], [])

let texpcon_to_fabscon con =
  match con with
    Const_int (jint) ->
      mkF90abs_iconst jint
  | Const_char (jchar) ->
      let cstr = Char.escaped jchar in
      Fexp_const(Fconst_char (cstr))
  | Const_string (jstr) ->
      Fexp_const(Fconst_char (jstr))
  | Const_float (jstr) ->
      Fexp_const(Fconst_realdbl (jstr))
        (* TEMPORARY CODE, not sure if this is an acceptable approximation.
           Roumen, Jason: Check/fix this.
           - Ed *)
  | Const_int32 (i) ->
      mkF90abs_iconst (Int32.to_int i)
  | Const_int64 (i) ->
      mkF90abs_iconst (Int64.to_int i)
  | Const_nativeint (i) ->
      mkF90abs_iconst (Nativeint.to_int i)


        (**************************************)
let rec trans_e e infor = 
  let curr_loc = e.exp_loc in
  match e.exp_desc with
    Texp_ident (pp1,ll1) ->
      if (DefSet.mem (Path.name pp1) !def_set) = false then
        glob_set := DefSet.add (Path.name pp1) !glob_set;
      Fexp_variable(Fvar_ident(Path.name pp1))
  | Texp_constant (jcon) ->
      texpcon_to_fabscon jcon 
  | Texp_let (f,pel,je) ->
      notSupported "let as expression" curr_loc
  | Texp_function (pel, partial) ->
      notSupported "function definition in expression" curr_loc
  | Texp_apply (ee,eool) -> 
      begin
        match ee.exp_desc with
          Texp_ident (pp1,ll1) ->
            begin
              match (Path.name pp1) with

                (* Binary operations.  *)

                "Pervasives.+" -> mkF90abs_binop Fbinop_add trans_e eool infor
              | "Pervasives.-" -> mkF90abs_binop Fbinop_sub trans_e eool infor
              | "Pervasives.*" -> mkF90abs_binop Fbinop_mul trans_e eool infor
              | "Pervasives./" -> mkF90abs_binop Fbinop_div trans_e eool infor
              | "Pervasives.mod" -> mkF90abs_intrin2 Fintrin_mod trans_e eool infor
              | "Pervasives.land" -> mkF90abs_intrin2 Fintrin_iand trans_e eool infor
              | "Pervasives.lor" -> mkF90abs_intrin2 Fintrin_ior trans_e eool infor
              | "Pervasives.lxor" -> mkF90abs_intrin2 Fintrin_ieor trans_e eool infor
              | "Pervasives.lsl" -> mkF90abs_shift_intrin2 Fintrin_ishft trans_e eool infor true
              | "Pervasives.lsr" -> mkF90abs_shift_intrin2 Fintrin_ishft trans_e eool infor false
              | "Pervasives.asr" -> mkF90abs_shift_intrin2 Fintrin_ishft trans_e eool infor false
              | "Pervasives.=" -> mkF90abs_binop Fbinop_eq trans_e eool infor
              | "Pervasives.<>" -> mkF90abs_binop Fbinop_ne trans_e eool infor
              | "Pervasives.<" -> mkF90abs_binop Fbinop_lt trans_e eool infor
              | "Pervasives.>" -> mkF90abs_binop Fbinop_gt trans_e eool infor
              | "Pervasives.<=" -> mkF90abs_binop Fbinop_le trans_e eool infor
              | "Pervasives.>=" -> mkF90abs_binop Fbinop_ge trans_e eool infor
              | "Pervasives.compare" -> notSupported "Pervasives.compare" curr_loc
              | "Pervasives.&&" -> mkF90abs_binop Fbinop_and trans_e eool infor
              | "Pervasives.&" -> notSupported "deprecated Pervasives.&" curr_loc 
              | "Pervasives.||" -> mkF90abs_binop Fbinop_or trans_e eool infor
              | "Pervasives.or" -> notSupported "deprecated Pervasives.or" curr_loc 
              | "Pervasives.min" -> mkF90abs_intrin2 Fintrin_min trans_e eool infor
              | "Pervasives.max" -> mkF90abs_intrin2 Fintrin_max trans_e eool infor
              | "Pervasives.+." -> mkF90abs_binop Fbinop_add trans_e eool infor
              | "Pervasives.-." -> mkF90abs_binop Fbinop_sub trans_e eool infor
              | "Pervasives./." -> mkF90abs_binop Fbinop_div trans_e eool infor
              | "Pervasives.*." -> mkF90abs_binop Fbinop_mul trans_e eool infor 
              | "Pervasives.**" -> mkF90abs_binop Fbinop_pow trans_e eool infor 
              | "Pervasives.==" -> notSupported "Pervasives.==" curr_loc
              | "Pervasives.!=" -> notSupported "Pervasives.!=" curr_loc

                    (* Unary.  *)

              | "Pervasives.not" -> notSupported "Pervasives.not as expression" curr_loc
              | "Pervasives.lnot" -> notSupported "Pervasives.lnot as expression" curr_loc
              | "Pervasives.~-" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                  Fexp_unary(Funop_minus, a0)
              | "Pervasives.~-." ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                  Fexp_unary(Funop_minus, a0)
              | "Pervasives.succ" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                  Fexp_binary(Fbinop_add, a0, (mkF90abs_iconst 1))
              | "Pervasives.pred" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                  Fexp_binary(Fbinop_sub, a0, (mkF90abs_iconst 1))

                    (* Floating-point functions.  *)

              | "Pervasives.cos" -> mkF90abs_intrin1 Fintrin_cos trans_e eool infor
              | "Pervasives.sin" -> mkF90abs_intrin1 Fintrin_sin trans_e eool infor
              | "Pervasives.sqrt" -> mkF90abs_intrin1 Fintrin_sqrt trans_e eool infor

                    (* Conversions.  *)

              | "Pervasives.float_of_int" -> mkF90abs_intrin1 Fintrin_dble trans_e eool infor
              | "Pervasives.float" -> mkF90abs_intrin1 Fintrin_dble trans_e eool infor
              | "Pervasives.int_of_float" -> mkF90abs_intrin1 Fintrin_int trans_e eool infor
              | "Pervasives.string_of_int" -> notSupported "Pervasives.string_of_int" curr_loc
              | "Pervasives.int_of_string" -> notSupported "Pervasives.int_of_string" curr_loc
              | "Pervasives.string_of_float" -> notSupported "Pervasives.string_of_float" curr_loc
              | "Pervasives.float_of_string" -> notSupported "Pervasives.float_of_string" curr_loc

                    (* References.  *)

              | "Pervasives.ref" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) 
                  in a0
              | "Pervasives.!" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) 
                  in a0
              | "Pervasives.:=" ->
                  notSupported "assignment (ref) as an expression" curr_loc
              | "Pervasives.incr" ->
                  notSupported "incr as an expression" curr_loc
              | "Pervasives.decr" ->
                  notSupported "decr as an expression" curr_loc

                    (* Arrays.  *)

              | "Array.make" ->
                  notSupported "declaring an array in an expression" curr_loc
              | "Array.create" ->
                  notSupported "declaring an array in an expression" curr_loc
              | "Array.make_matrix" ->
                  notSupported "declaring a matrix in an expression" curr_loc
              | "Array.set" ->
                  notSupported "assignment (array) as an expression" curr_loc
              | "Array.get" ->
                  let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                  let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                  begin
                    match a0 with 
                      Fexp_variable(Fvar_arrayref(strname, sublist)) ->
                        Fexp_variable(Fvar_arrayref(strname, (sublist@[Fsub_simple(a1)])))
                    | _ ->
                        match a0 with
                          Fexp_variable(Fvar_ident(str_n)) ->
                            Fexp_variable(Fvar_arrayref(str_n, [Fsub_simple(a1)])) 
                        | _ -> notSupported "non-identifier as array name" curr_loc
                  end

                    (* A call of some other identifier.  *)

              | _ ->
                  let idname = Path.name pp1 in
                  if (String.length idname > 11
                        && (String.sub idname 0 11) = "Pervasives.") then
                    notSupported idname curr_loc;
                  if (String.length idname > 6
                        && (String.sub idname 0 6) = "Array.") then
                    notSupported idname curr_loc;

                  if (List.length eool) = 0 then
                    mkF90abs_call (Path.name pp1) []
                  else if (List.length eool) = 1 then
                    let arg = unSome (fst (List.nth eool 0)) in
                    match (arg.exp_desc) with
                      Texp_tuple(expl) ->
                        let xlate = (fun le -> trans_e le infor) in
                        let cexpl = (List.map xlate expl) in
                        mkF90abs_call (Path.name pp1) cexpl 
                    | _ ->
                        let cexp = trans_e arg infor in
                        mkF90abs_call (Path.name pp1) [cexp]
                  else 
                    notSupported "Texp_apply with multiple arguments" curr_loc
            end
        | _ -> notSupported "Texp_apply with non-identifier" curr_loc
      end
  | Texp_match (je,pel,partial) ->
      notSupported "match as expression (match of non-unit type)" curr_loc
  | Texp_try (je,pel) -> notSupported "Texp_try" curr_loc
  | Texp_tuple el -> notSupported "Texp_tuple" curr_loc
  | Texp_construct (cd,el,_) -> notSupported "Texp_construct" curr_loc
  | Texp_variant (label, eo) -> notSupported "Texp_variant" curr_loc
  | Texp_record (del, eo) -> notSupported "Texp_record" curr_loc
  | Texp_field (je,ld) -> notSupported "Texp_field" curr_loc
  | Texp_setfield (e1,ld,e2) -> notSupported "Texp_setfield" curr_loc
  | Texp_array el -> notSupported "Texp_array" curr_loc
  | Texp_ifthenelse (e1,e2,eo) ->
      begin
        match eo with
          Some (eelse) ->
            let tmpname = get_tmp_name "iftmp" in
            let ftype = xlate_basic_type e.exp_type curr_loc in
            let tmpdecl = [(mkF90abs_simple_decl ftype tmpname Fexp_nop false)] in
            let e1info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e1exp = trans_e e1 e1info in
            let e2info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e2exp = trans_e e2 e2info in
            let asg2 = mkF90abs_assignment tmpname e2exp in 
            let e2stmts = (!e2info.stmts)@[asg2] in
            let e3info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e3exp = trans_e eelse e3info in
            let asg3 = mkF90abs_assignment tmpname e3exp in 
            let e3stmts = Some((!e3info.stmts)@[asg3]) in
            let ifstmt = Fstmt_ifthenelse(e1exp, e2stmts, e3stmts) in
            infor := {
              globs = (!infor.globs)@(!e2info.globs)@(!e3info.globs);
              subprogs = (!infor.subprogs)@(!e2info.subprogs)@(!e3info.subprogs);
              fname = "";
              defs = !infor.defs@tmpdecl@(!e2info.defs)@(!e3info.defs);
              stmts = !infor.stmts@[ifstmt] };
            Fexp_variable(Fvar_ident(tmpname))
        | None -> notSupported "Texp_ifthenelse without else" curr_loc
      end
  | Texp_sequence (e1,e2) ->
      notSupported "sequence as expression" curr_loc
  | Texp_while (e1,e2) ->
      notSupported "while statement as expression" curr_loc
  | Texp_for (id,e1,e2,df,e3) ->
      notSupported "for statement as expression" curr_loc
  | Texp_when (e1,e2) -> notSupported "Texp_when" curr_loc
  | Texp_send (je,m) -> notSupported "Texp_send" curr_loc
  | Texp_new (p,d) -> notSupported "Texp_new" curr_loc
  | Texp_instvar (p1,p2) -> notSupported "Texp_instvar" curr_loc
  | Texp_setinstvar (p1,p2,je) -> notSupported "Texp_setinstvar" curr_loc
  | Texp_override (p,pel) -> notSupported "Texp_override" curr_loc
  | Texp_letmodule (i,me,e) -> notSupported "Texp_letmodule" curr_loc
  | Texp_assert je -> 
      notSupported "assert statement as expression" curr_loc
  | Texp_assertfalse -> 
      notSupported "assertfalse statement as expression" curr_loc
  | Texp_lazy je -> notSupported "Texp_lazy" curr_loc
  | Texp_bracket je -> notSupported "Texp_bracket" curr_loc
  | Texp_escape je -> notSupported "Texp_escape" curr_loc
  | Texp_run je -> notSupported "Texp_run" curr_loc
  | Texp_runoffshore(je,s) -> notSupported "Texp_runoffshore" curr_loc
  | Texp_runoffshore_arg(e_rec,e) -> notSupported "Texp_runoffshore_arg" curr_loc
  | Texp_cspval (v,li) -> notSupported "Texp_cspval" curr_loc
  | Texp_destruct(cd,je,_) -> notSupported "Texp_destruct" curr_loc
  | Texp_etag (a,je,e1,env_exp) -> notSupported "Texp_etag" curr_loc
  | Texp_object _ -> notSupported "Texp_object" curr_loc;; 
  (**************************************)

  let rec trans_s e infor = 
    let curr_loc = e.exp_loc in
    match e.exp_desc with
      Texp_ident (pp1,ll1) ->
        trans_e e infor
    | Texp_constant (jcon) ->
        trans_e e infor
    | Texp_let (f,pel,je) ->
        if (List.length pel) > 1 then
          notSupported "Texp_let with multiple patterns" curr_loc;

        let v = (List.nth pel 0) in  (* v is a (pattern*expression) *)
        let (pat,pex) = v in
        let retexpr = match pat.pat_desc with
          Tpat_any -> notSupported "let with Tpat_any" curr_loc
        | Tpat_var (ident) -> 
            let is_array = is_array_type pex.exp_type in
            let pexisfunc = is_function_type pex.exp_type in
            if (is_array || pexisfunc) then
              let initinfo = 
                ref { globs = []; subprogs = []; fname = (Ident.name ident); defs = []; stmts = [] } in
              if (pexisfunc) then 
                let_isrec := (f = Recursive); 
              let _ = trans_s pex initinfo in
              if (pexisfunc) then 
                let_isrec := false;
              let innerinfo = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
              let letexp = trans_s je innerinfo in
              infor := {
                globs = (!infor.globs)@(!initinfo.globs)@(!innerinfo.globs);
                subprogs = (!infor.subprogs)@(!initinfo.subprogs)@(!innerinfo.subprogs);
                fname = "";
                defs = (!infor.defs)@(!innerinfo.defs);
                stmts = (!infor.stmts)@(!innerinfo.stmts) };
              letexp
            else
              let is_ref = (is_simple_ref_type pex.exp_type) in
              let ctyp =
                if is_ref=false then 
                  xlate_basic_type pex.exp_type curr_loc
                else
                  get_simple_ref_base_type pex.exp_type curr_loc in
              let initinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
              let initexp = trans_e pex initinfo in
              let letname = Ident.name ident in
              let letdecl = [(mkF90abs_simple_decl ctyp letname Fexp_nop false)] in
              let asg = mkF90abs_assignment letname initexp in
              def_set := DefSet.add letname !def_set;
              let innerinfo = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
              let letexp = trans_s je innerinfo in
              let blkdefs = !innerinfo.defs in
              let blkstmts = [asg]@(!innerinfo.stmts) in
              let globalize = (DefSet.mem letname !glob_set) in
              infor := {
                globs = (!infor.globs)@(if globalize = true then letdecl else [])@(!initinfo.globs)@(!innerinfo.globs);
                subprogs = (!infor.subprogs)@(!initinfo.subprogs)@(!innerinfo.subprogs);
                fname = "";
                defs = !infor.defs@(if globalize = false then letdecl else [])@(!initinfo.defs)@blkdefs;
                stmts = !infor.stmts@(!initinfo.stmts)@blkstmts };
              letexp
        | Tpat_alias (_,_) -> notSupported "let with Tpat_alias" curr_loc
        | Tpat_constant (_) -> notSupported "let with Tpat_constant" curr_loc
        | Tpat_tuple (_) -> notSupported "let with Tpat_tuple" curr_loc
        | Tpat_construct (_,_) -> notSupported "let with Tpat_construct" curr_loc
        | Tpat_variant (_,_,_) -> notSupported "let with Tpat_variant" curr_loc
        | Tpat_record _ -> notSupported "let with Tpat_record" curr_loc
        | Tpat_array (_) -> notSupported "let with Tpat_array" curr_loc
        | Tpat_or (_,_,_) -> notSupported "let with Tpat_or" curr_loc
        in retexpr
    | Texp_function (pel, partial) ->
        let def_set_temp_copy = !def_set in
        def_set := DefSet.empty;
        (* if !infor.fname = "" then
           notSupported "anonymous Texp_function" curr_loc
           else *)
        if (List.length pel) <> 1 then
          notSupported "Texp_function with multiple arguments" curr_loc
        else

          begin
            if !infor.fname = "" then
              (*ignore(infor:={!infor with fname=get_tmp_name("fun_def")});*)
              ignore(infor:={!infor with fname= runF.main_function_name});
            let parg = (fst (List.nth pel 0)) in
            let alist = 
              match (parg.pat_desc) with
                Tpat_tuple(patl) ->
                  let ff = (fun le -> match le.pat_desc with
                    Tpat_var(ident) -> le
                  | _ -> notSupported "non-Tpat_var in args" curr_loc) in
                  (List.map ff patl)
              | Tpat_var(ident) ->
                  [parg]
              | _ ->
                  notSupported ("Texp_function with arg pattern `"
                                ^ (Parmatch.top_pretty Format.str_formatter parg;
                                   flush_str_formatter ()) ^ "'") curr_loc
            in
            let fbody = (snd (List.nth pel 0)) in
            let binfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
            let cabs_body = trans_s fbody binfo in
            
            (* First, collect argument names for formal arg list.  *)
            let doarg = (fun argpat ->
              match argpat.pat_desc with
                Tpat_var(id) -> (Ident.name id)
              | _ -> raise (OffshoringError "unexpected pattern")) in 
            let formal_names = List.map doarg alist in

            (* Next, create the specifications for each arg.  *)
            let doarg = (fun argpat ->
              let ident = match argpat.pat_desc with
                Tpat_var(id) -> (Ident.name id)
              | _ -> raise (OffshoringError "unexpected pattern") in 
              if (is_array_type argpat.pat_type) then 
                let fargtype = get_array_base_type argpat.pat_type curr_loc in
                (* FIXME: 2D array passing.  *)
                (* notYetImplemented "passing arrays for F90 target"; *)
                if (array_num_dims argpat.pat_type curr_loc ) = 1 then
                  mkF90abs_array_decl1 fargtype ident (-2) 
                else 
                  ((* notYetImplemented "passing 2D arrays for F90 target"; *)
                   mkF90abs_array_decl2 fargtype ident (-1) (-1) )
              else
                let fargtype = xlate_basic_type argpat.pat_type curr_loc in
                mkF90abs_simple_decl fargtype ident Fexp_nop false)
            in 
            let formal_specs = List.map doarg alist in
            
            (* Functions in F90 return their value by assigning to the
               function's name (unless they are recursive, in which case
               we assign to the RESULT name).  *)
            let rslt_name = (!infor.fname) ^ (if !let_isrec then "_res" else "") in
            let retval_asg = mkF90abs_assignment rslt_name cabs_body in
            let newstmts = !binfo.stmts@[retval_asg]@[Fstmt_return(None)] in
            let funlist = 
              [mkF90abs_fundef (xlate_basic_type fbody.exp_type curr_loc)
                 !infor.fname formal_names !let_isrec
                 (mkF90abs_subprogbody (formal_specs@(!binfo.defs)) newstmts)] in
            let funinter =
              [mkF90abs_fun_interface (xlate_basic_type fbody.exp_type curr_loc)
                 !infor.fname formal_names !let_isrec formal_specs] in
            infor := {
              globs = (!infor.globs)@(!binfo.globs)@funinter;
              subprogs = (!infor.subprogs)@(!binfo.subprogs)@funlist;
              fname = "";
              defs = !infor.defs;
              stmts = !infor.stmts };
            def_set := def_set_temp_copy;
            Fexp_nop
          end  
    | Texp_apply (ee,eool) -> 
        begin
          match ee.exp_desc with
            Texp_ident (pp1,ll1) ->
              begin
                match (Path.name pp1) with

                  (* References.  *)

                  "Pervasives.:=" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                    let varname = (match a0 with
                      Fexp_variable(Fvar_ident(nstr)) -> nstr
                    | _ -> raise (OffshoringError "expected Fexp_variable")) in
                    let tasg = mkF90abs_assignment varname a1 in
                    infor := { !infor with
                               stmts = (!infor.stmts)@[tasg]};
                    Fexp_nop 
                | "Pervasives.incr" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let varname = (match a0 with
                      Fexp_variable(Fvar_ident(nstr)) -> nstr
                    | _ -> raise (OffshoringError "expected Fexp_variable")) in
                    let incr = Fexp_binary(Fbinop_add, a0, (mkF90abs_iconst 1)) in
                    let tasg = mkF90abs_assignment varname incr in
                    infor := { !infor with
                               stmts = (!infor.stmts)@[tasg]};
                    Fexp_nop 
                | "Pervasives.decr" ->
                    let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                    let varname = (match a0 with
                      Fexp_variable(Fvar_ident(nstr)) -> nstr
                    | _ -> raise (OffshoringError "expected Fexp_variable")) in
                    let incr = Fexp_binary(Fbinop_sub, a0, (mkF90abs_iconst 1)) in
                    let tasg = mkF90abs_assignment varname incr in
                    infor := { !infor with
                               stmts = (!infor.stmts)@[tasg]};
                    Fexp_nop 

                      (* Arrays.  *)

                | "Array.make" ->
                    (* FIXME: For now, we ignore the second (initialization)
                       argument.  *)
                    let arg0 = unSome (fst (List.nth eool 0)) in 
                    let sz = (match arg0.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> notSupported "non-constant array size" curr_loc) in
                    let ctyp = get_array_base_type e.exp_type curr_loc in
                    let decl = (if sz=1 then
                      (mkF90abs_ptr_decl1 ctyp !infor.fname (mkF90abs_iconst 0))
                    else 
                      (mkF90abs_array_decl1 ctyp !infor.fname sz)) in
                    infor := { !infor with
                               globs = (!infor.globs)@[decl]};
                    Fexp_nop
                | "Array.create" ->
                    notSupported "deprecated Array.create (use Array.make)" curr_loc
                | "Array.make_matrix" ->
                    (* FIXME: For now, we ignore the third (initialization)
                       argument.  *)
                    let arg0 = unSome (fst (List.nth eool 0)) in 
                    let sz1 = (match arg0.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> notSupported "non-constant array size" curr_loc) in
                    let arg1 = unSome (fst (List.nth eool 1)) in 
                    let sz2 = (match arg1.exp_desc with
                      Texp_constant(Const_int(jint)) -> jint
                    | _ -> notSupported "non-constant array size" curr_loc) in
                    let ctyp = get_array_base_type e.exp_type curr_loc in
                    let arrdecl = (mkF90abs_array_decl2 ctyp !infor.fname sz1 sz2) in
                    infor := { !infor with
                               globs = (!infor.globs)@[arrdecl]};
                    Fexp_nop
                | "Array.set" ->
                    begin
                      let a0 = (trans_e (unSome (fst (List.nth eool 0))) infor) in
                      let a1 = (trans_e (unSome (fst (List.nth eool 1))) infor) in
                      let a2 = (trans_e (unSome (fst (List.nth eool 2))) infor) in
                      let the_ref = match a0 with 
                        Fexp_variable(Fvar_arrayref(strname, sublist)) ->
                          Fvar_arrayref(strname, (sublist@[Fsub_simple(a1)]))
                      | _ ->
                          match a0 with
                            Fexp_variable(Fvar_ident(str_n)) ->
                              Fvar_arrayref(str_n, [Fsub_simple(a1)]) 
                          | _ -> notSupported "non-identifier as array name" curr_loc
                      in
                      let asg = Fstmt_assign(the_ref, a2) in
                      infor := { !infor with
                                 stmts = (!infor.stmts)@[asg]};
                    end;
                    Fexp_nop 

                | "Array.get" ->
                    (* Let trans_e do the Texp_apply.  Since this array ref is in
                       a statement context, we assign the result to a new temp
                       and return that.  *)
                    let arref = trans_e e infor in
                    let ftyp = xlate_basic_type e.exp_type curr_loc in
                    let str_tmpn = get_tmp_name "tmp" in
                    let decl = mkF90abs_simple_decl ftyp str_tmpn Fexp_nop false in
                    let asg = mkF90abs_assignment str_tmpn arref in
                    infor := { !infor with
                               defs = !infor.defs@[decl];
                               stmts = !infor.stmts@[asg] };
                    Fexp_variable(Fvar_ident(str_tmpn))

                      (* A call of anything else.  *)

                | _ ->
                    trans_e e infor
              end
          | _ -> notSupported "Texp_apply with non-identifier" curr_loc
        end
    | Texp_match (je,pel,partial) ->
        if (is_unit_type e.exp_type)=false then
          notSupported "match of non-unit type" curr_loc;
        let need_default =  
          (match partial with Partial -> true | Total -> false) in
        let _ = (xlate_basic_type je.exp_type) in
        let sexpinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
        let sexp = trans_e je sexpinfo in
        let ss = List.map (
          fun (pat,mex) ->
            match pat.pat_desc with 
              Tpat_constant(mcon) ->
                let caseinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
                let caseexp = trans_s mex caseinfo in
                if caseexp <> Fexp_nop then assert false;
                let casestmts = !caseinfo.stmts in
                infor := {
                  globs = (!infor.globs)@(!caseinfo.globs);
                  subprogs = (!infor.subprogs)@(!caseinfo.subprogs);
                  fname = "";
                  defs = (!infor.defs)@(!caseinfo.defs);
                  stmts = !infor.stmts };
                Fsel_case([texpcon_to_fabscon mcon], casestmts)
            | Tpat_any ->
                let caseinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
                let caseexp = trans_s mex caseinfo in
                if caseexp <> Fexp_nop then assert false;
                infor := {
                  globs = (!infor.globs)@(!caseinfo.globs);
                  subprogs = (!infor.subprogs)@(!caseinfo.subprogs);
                  fname = "";
                  defs = (!infor.defs)@(!caseinfo.defs);
                  stmts = !infor.stmts };
                let casestmts = !caseinfo.stmts in
                Fsel_default(casestmts)
            | _ -> notSupported "non-constant match pattern" curr_loc
         ) pel in
        let deflt = Fsel_default([Fstmt_stop]) in
        let cases = (if need_default=true then (ss@[deflt]) else ss) in
        let switch = Fstmt_select(sexp, cases) in
        infor := {
          globs = (!infor.globs);
          subprogs = (!infor.subprogs);
          fname = "";
          defs = !infor.defs;
          stmts = !infor.stmts@[switch] };
        Fexp_nop
    | Texp_try (je,pel) -> notSupported "Texp_try" curr_loc
    | Texp_tuple el -> notSupported "Texp_tuple" curr_loc
    | Texp_construct (cd,el,_) -> notSupported "Texp_construct" curr_loc
    | Texp_variant (label, eo) -> notSupported "Texp_variant" curr_loc
    | Texp_record (del, eo) -> notSupported "Texp_record" curr_loc
    | Texp_field (je,ld) -> notSupported "Texp_field" curr_loc
    | Texp_setfield (e1,ld,e2) -> notSupported "Texp_setfield" curr_loc
    | Texp_array el -> notSupported "Texp_array" curr_loc
    | Texp_ifthenelse (e1,e2,eo) ->
        if (is_unit_type e.exp_type)=false then
          trans_e e infor
        else 
          begin
            let e1info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e1exp = trans_e e1 e1info in
            let e2info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e2exp = trans_s e2 e2info in
            let e3info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
            let e3exp = begin
              match eo with
                Some (eelse) -> trans_s eelse e3info
              | None -> Fexp_nop
            end in
            (if e2exp <> Fexp_nop then assert false);
            (if e3exp <> Fexp_nop then assert false);
            let e2stmts = !e2info.stmts in
            let e3stmts =
              (if !e3info.stmts <> [] then Some(!e3info.stmts) else None) in
            let ifstmt = Fstmt_ifthenelse(e1exp, e2stmts, e3stmts) in
            infor := {
              globs = (!infor.globs)@(!e2info.globs)@(!e3info.globs);
              subprogs = (!infor.subprogs)@(!e2info.subprogs)@(!e3info.subprogs);
              fname = "";
              defs = !infor.defs@(!e2info.defs)@(!e3info.defs);
              stmts = !infor.stmts@[ifstmt] };
            Fexp_nop
          end
    | Texp_sequence (e1,e2) ->
        let e1info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
        let _ = trans_s e1 e1info in
        let e2info = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
        let e2exp = trans_s e2 e2info in
        (* e1exp might be a non-Fexp_nop, but it can be ignored. *)
        let e1stmts = !e1info.stmts in
        infor := {
          globs = (!infor.globs)@(!e1info.globs)@(!e2info.globs);
          subprogs = (!infor.subprogs)@(!e1info.subprogs)@(!e2info.subprogs);
          fname = "";
          defs = !infor.defs@(!e1info.defs)@(!e2info.defs);
          stmts = !infor.stmts@(e1stmts)@(!e2info.stmts) };
        e2exp
    | Texp_while (e1,e2) ->
        let cexpinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
        let cexp = trans_e e1 cexpinfo in
        let innerinfo = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
        let we = trans_s e2 innerinfo in
        (match we with Fexp_nop -> ()
        | _ -> Printf.printf "warning: value ignored\n");
        let wstmt = Fstmt_do_while(cexp, !innerinfo.stmts) in
        infor := {
          globs = (!infor.globs)@(!cexpinfo.globs)@(!innerinfo.globs);
          subprogs = (!infor.subprogs)@(!cexpinfo.subprogs)@(!innerinfo.subprogs);
          fname = "";
          defs = (!infor.defs)@(!innerinfo.defs);
          stmts = !infor.stmts@[wstmt] };
        Fexp_nop
    | Texp_for (id,e1,e2,df,e3) ->
        (* The induction variable is always type int in Ocaml.  *)
        let initinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
        let initexp = trans_e e1 initinfo in
        let ivname = Ident.name id in
        let ivdecl = [(mkF90abs_simple_decl (Ftype_integer(None)) ivname Fexp_nop false)] in
        let ubexpinfo = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] } in
        let ubexp = trans_e e2 ubexpinfo in
        let stepo = (match df with Upto -> None | Downto -> Some(mkF90abs_iconst (-1))) in
        let innerinfo = (ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = [] }) in
        let fe = trans_s e3 innerinfo in
        (match fe with Fexp_nop -> ()
        | _ -> Printf.printf "warning: useless expression\n");
        let fstmt = Fstmt_do(ivname, initexp, ubexp, stepo, !innerinfo.stmts) in
        infor := {
          globs = (!infor.globs)@(!initinfo.globs)@(!ubexpinfo.globs)@(!innerinfo.globs);
          subprogs = (!infor.subprogs)@(!initinfo.subprogs)@(!ubexpinfo.subprogs)@(!innerinfo.subprogs);
          fname = "";
          defs = (!infor.defs)@(!innerinfo.defs)@ivdecl;
          stmts = !infor.stmts@[fstmt] };
        Fexp_nop
    | Texp_when (e1,e2) -> notSupported "Texp_when" curr_loc
    | Texp_send (je,m) -> notSupported "Texp_send" curr_loc
    | Texp_new (p,d) -> notSupported "Texp_new" curr_loc
    | Texp_instvar (p1,p2) -> notSupported "Texp_instvar" curr_loc
    | Texp_setinstvar (p1,p2,je) -> notSupported "Texp_setinstvar" curr_loc
    | Texp_override (p,pel) -> notSupported "Texp_override" curr_loc
    | Texp_letmodule (i,me,e) -> notSupported "Texp_letmodule" curr_loc
    | Texp_assert je -> 
        let a0 = trans_e je infor in 
        let ifstmt = Fstmt_ifthenelse(a0, [Fstmt_stop], None) in
        infor := { !infor with
                   stmts = !infor.stmts@[ifstmt] };
        Fexp_nop
    | Texp_assertfalse -> 
        infor := { !infor with
                   stmts = !infor.stmts@[Fstmt_stop] };
        Fexp_nop
    | Texp_lazy je -> notSupported "Texp_lazy" curr_loc
    | Texp_bracket je -> notSupported "Texp_bracket" curr_loc
    | Texp_escape je -> notSupported "Texp_escape" curr_loc
    | Texp_run je -> notSupported "Texp_run" curr_loc
    | Texp_runoffshore(je,s) -> notSupported "Texp_runoffshore" curr_loc
    | Texp_runoffshore_arg(e_rec,e) -> notSupported "Texp_runoffshore_arg" curr_loc
    | Texp_cspval (v,li) -> notSupported "Texp_cspval" curr_loc
    | Texp_destruct(cd,je,_) -> notSupported "Texp_destruct" curr_loc
    | Texp_etag (a,je,e1,env_exp) -> notSupported "Texp_etag" curr_loc
    | Texp_object _ -> notSupported "Texp_object" curr_loc;; 


(***********************)

(* The following functions allow one to isolate
   translation, pretty print + F90 compilation, and execution.  *)

let toF x =  (* 'a code -> string *)
  let env = Env.empty in
  let texp = Typecore.type_expression env (Obj.magic x) in
  (* dumptexp texp 0; *)
  init_translation ();
  let info = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = []; } in
  let fabsexp = trans_s texp info in
  let newfabsexp =
    (match fabsexp with Fexp_nop -> (mkF90abs_iconst 0) | _ -> fabsexp) in
  (* let retval_asg = mkF90abs_assignment "f90main" newfabsexp in *)
  (* Copy return value into a new tmp, and give that to exit.  *)
  let g95decl = [(mkF90abs_simple_decl (Ftype_integer(None)) "f90mainret" Fexp_nop false)] in
  let g95asg = mkF90abs_assignment "f90mainret" newfabsexp in 
  let retval_asg = [g95asg]@[Fstmt_call("exit", [Fexp_variable(Fvar_ident("f90mainret"))])] in
  info := { globs = !info.globs;
            subprogs = !info.subprogs;
            fname = "";
            defs = [Fspec_use("globals", None); Fspec_implicit_none]@(!info.defs@g95decl); 
            stmts = !info.stmts@retval_asg (* @[Fstmt_return(None)] *) };
  (* This module will hold all the global variables.  *)
  let globmod =
    [Fsubprog(Fhdr_module("globals"), (mkF90abs_subprogbody !info.globs []))] in
  let maindef = 
    (* [mkF90abs_fundef Ftype_integer(None) "f90main" []  *)
    [Fsubprog(Fhdr_program("f90main"),
              (mkF90abs_subprogbody !info.defs !info.stmts))] in
  let pu = { topdefs = globmod@(!info.subprogs)@maindef } in
  fpp_fcompilation_unit pu 


let toF_fun_only x =  (* 'a code -> string  * string *)
  let env = Env.empty in
  let texp = Typecore.type_expression env (Obj.magic x) in
  (* dumptexp texp 0; *)
  init_translation ();
  let info = ref { globs = []; subprogs = []; fname = ""; defs = []; stmts = []; } in
  let fabsexp = trans_s texp info in
  let _ =
    (match fabsexp with Fexp_nop -> (mkF90abs_iconst 0) | _ -> fabsexp) in
  info := { globs = !info.globs;
            subprogs = !info.subprogs;
            fname = "";
            defs = [Fspec_use("globals", None); Fspec_implicit_none]@(!info.defs); 
            stmts = !info.stmts; };
  (* This module will hold all the global variables.  *)
  let globmod =
    [Fsubprog(Fhdr_module("globals"), (mkF90abs_subprogbody (!info.globs) []))] in
  let pu = { topdefs = globmod@(!info.subprogs); } in
  let pstr = (fpp_fcompilation_unit pu) in
  (pstr, (runF.main_function_name) ^ "_")  
    (* Add an underscore for extern symbol.  *)


    (* no marshalling helpers; just run *)

let buildFexe fstr compiler compiler_flags working_dir file_name=  
  let _ = Sys.command ("cd " ^  working_dir ^
                       " ; cat > " ^ file_name ^ ".f90" ^ " << EOF\n" ^ 
                       fstr ^ "\nEOF\n") in 
  let exstub = "#include <stdlib.h>\nvoid exit_(int *n) { exit(*n); }" in
  let _ = Sys.command ("cd " ^  working_dir ^
                       " ; cat > exstub.c << EOF\n" ^ exstub ^ "\nEOF\n") in
  let _ = Sys.command ("cd " ^  working_dir ^
                       " ; gcc -c exstub.c") in
  let sysret = Sys.command ("cd " ^  working_dir ^ 
                            " ; " ^ compiler ^ " " ^ file_name ^ ".f90 " 
                            ^ compiler_flags  ^ " exstub.o >& /dev/null") in
  if sysret <> 0 then 
    raise (OffshoringError "F90 compiler gave errors for temp.f90")

let runFexe working_dir = 
  match Config.system with 
	"cygwin" -> Sys.command ("cd " ^  working_dir ^ " ; a.exe")
  | _ ->  Sys.command ("cd " ^  working_dir ^ " ; a.out")
  

    (* marshalling involved helpers *)

let addToLibrary some_code working_dir file_name =
  let str = open_out (working_dir ^ "/" ^ file_name ^ ".f90") in
  let _ = Pervasives.output_string str some_code in 
  close_out str

    
    (* Code for building the libraries.   *)
let buildLibs fc compiler_flags f90_lib_path working_dir file_name =
  (*    let picflags = "-O2 " ^ " -fPIC -DOCAML_COMPILE" in *)
  let cc = "gcc" 
  and picflags = compiler_flags ^ " -fPIC " 
  and f90libs = "-lcprts -lcxa -lguide -lguide_stats" ^ 
    " -limf -lifcore -lirc -lircmt -lompstub -lsvml -lunwind" 
  in
  let res = Sys.command ("cd " ^  working_dir ^ " ; " ^ 
                         fc ^ " " ^ picflags ^ " -c " ^ file_name ^ 
                         ".f90  -o " ^ file_name ^ ".o ; " ^
                         cc ^ " -shared -o lib" ^ file_name ^ "f90.so " ^  
                         file_name ^ ".o " ^ "-L" ^ f90_lib_path ^ " " ^ f90libs
                         ^ " >& /dev/null") in
  if res <> 0 then 
    raise (OffshoringError "buildLibs in trx.ml: Error in dynamic library creation")

let currentLib = ref (Dl.dl_dummy_library ())

    (* calls the generated marshaller *)
let translate code_fun _marshall compiler compiler_flags f90_lib_path 
    working_dir file_name main_function_name = 
  let (f,s) = (toF_fun_only code_fun) in
  addToLibrary f working_dir file_name;
  buildLibs compiler compiler_flags f90_lib_path working_dir file_name;
  currentLib := Dl.dl_open (working_dir ^ "/lib" ^ file_name ^ "f90.so");
  let sym_fun = Dl.dl_sym !currentLib s in
  sym_fun


let runInF x compiler compiler_flags working_dir file_name  =
  buildFexe (toF x) compiler compiler_flags working_dir file_name;
  runFexe working_dir

let sym_fun_temp code_fun = translate code_fun "_" 
    (runF.compiler )
    (runF.compiler_flags)
    (runF.f90_lib_path )
    (runF.working_dir)
    (runF.file_name )
    (runF.main_function_name)
    
let runInFf code_fun = 
(* leave this for when runInFf is wired with auto marshalling
   let sym_fun = translate code_fun "_" compiler
   compiler_flags f90_lib_path working_dir file_name 
   main_function_name in 
 *)
  let sym_fun = sym_fun_temp code_fun
  in
  let ret_fun = (Dl.f90call_i sym_fun: int -> int) in
  ret_fun

let runInFf_array_i code_fun = 
  let sym_fun = sym_fun_temp code_fun 
  in
  let ret_fun = (Dl.f90call_array_i sym_fun: int array -> int) in
  ret_fun
    
let runInFf_array_f code_fun = 
  let sym_fun = sym_fun_temp code_fun
  in
  let ret_fun = (Dl.f90call_array_f sym_fun: float array -> int) in
  ret_fun
    
let runInFf_array_c_c code_fun = 
  let sym_fun = sym_fun_temp code_fun
  in 
  let ret_fun = (Dl.f90call_array_c_c sym_fun: char array array -> int) in
  ret_fun

let runInFf_array_f_f code_fun = 
  let sym_fun = sym_fun_temp code_fun
  in
  let ret_fun = (Dl.f90call_array_f_f sym_fun: float array array -> int) in
  ret_fun

    (*
       let runInFf_array_b code_fun = 
       let sym_fun = lib_helper code_fun in
       let ret_fun = (Dl.f90call_array_b sym_fun: bool array -> int) in
       ret_fun

       let runInFf_array_c code_fun = 
       let sym_fun = lib_helper code_fun in
       let ret_fun = (Dl.f90call_array_c sym_fun: char array -> int) in
       ret_fun

       let runInFf_array_i_i code_fun = 
       let sym_fun = lib_helper code_fun in
       let ret_fun = (Dl.f90call_array_i_i sym_fun: int array array -> int) in
       ret_fun

       let runInFf_array_b_b code_fun = 
       let sym_fun = lib_helper code_fun in
       let ret_fun = (Dl.f90call_array_b_b sym_fun: bool array array -> int) in
       ret_fun
     *)

let closeCurrentLib () =
  Dl.dl_close (!currentLib)

end
  (* End of module F.  *)

(* based on code taken from typing/parmatch.ml *)
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 =
  match lid with
    Longident.Lident _ -> Longident.Lident name
  | Longident.Ldot (p,_) -> Longident.Ldot (p,name)
  | _ -> fatal_error("Trx.update_lid")

(* Walid: Emir should remove the messages guarded by Clflags.debug_messages *)
let get_type_descr ty tenv =
  let ty2 = Ctype.repr (Ctype.expand_head tenv ty) in
  match ty2.desc with
  | Tconstr (path,_,_) -> Env.find_type path tenv
  | Tvar -> 
      (if !Clflags.debug_messages 
      then Format.fprintf Format.std_formatter
          "Error in get_type_descr called with %a (case TVar)\n"
          Printtyp.type_expr ty;
       fatal_error "Trx.get_type_descr")
  | typ -> 
      (if !Clflags.debug_messages
      then Format.fprintf Format.std_formatter
          "Error in get_type_descr called with %a\n"
          Printtyp.type_expr ty;         
       fatal_error "Trx.get_type_descr (case typ)" )

let get_type_path ty tenv =
  let ty = Ctype.repr (Ctype.expand_head tenv ty) in
  match ty.desc with
  | Tconstr (path,_,_) -> path
  | _ -> fatal_error "Trx.get_type_path"

let find_label lbl lbls =
  try
    let name,_,_ = List.nth lbls lbl.lbl_pos in
    name
  with Failure "nth" -> "*Unkown label*"

(* XXO: get the constructor lid by getting the path of
   the type and updating it with the constructor name.
   For example, Parsetree.Ppat_any is reconstructed from
   type: Parsetree.pattern_desc
   name: Ppat_any                                *)
let get_constr_lid tag ty tenv = match tag with
| Cstr_exception path -> path_to_lid path
| _ -> let name,_ =
    begin
      match get_type_descr ty tenv with
      | {type_kind=Type_variant (constr_list,pf)} ->
          Datarepr.find_constr_by_tag tag constr_list
      | _ -> fatal_error "Trx.get_constr_lid"
    end
and type_path = get_type_path ty tenv
in update_lid (path_to_lid type_path) name

let get_record_lids ty tenv =
  match get_type_descr ty tenv with
  | {type_kind = Type_record(lbls, rep, pf)} ->
      let type_lid = path_to_lid (get_type_path ty tenv) in
      let label_lid (name,_,_) = update_lid type_lid name
      in List.map label_lid lbls
  | _ -> fatal_error "Trx.get_record_lids"



let quote_csp_integers = true
let quote_csp_doubles = true

let mkcsp v eo li =
  let rdesc = ref (Pexp_cspval (Obj.magic v, li)) in
  let _ = match eo with
  | None -> ()
  | Some exp ->
      match Obj.is_int v with
      | true ->
          begin
            if quote_csp_integers && (Typeopt.has_base_type exp Predef.path_int) 
            then rdesc := Pexp_constant (Const_int (Obj.magic v));
            if quote_csp_integers && (Typeopt.has_base_type exp Predef.path_char) 
            then rdesc := Pexp_constant (Const_char (Obj.magic v));
            if quote_csp_integers && (Typeopt.has_base_type exp Predef.path_bool)
            then rdesc := (let b = if (Obj.magic v) then "true" else "false"
            in Pexp_construct (Longident.Lident b, None, false,Parsetree.Keep))
          end
      | false ->
          begin
            if (Obj.tag v) = Obj.double_tag && quote_csp_doubles
            then rdesc := Pexp_constant (Const_float (string_of_float (Obj.magic v)))
          end in
  let ext = if Obj.is_int v then None else match eo with
    None -> None
  | Some exp ->
      match exp.exp_desc with
      | Texp_ident (i,_) when Printtyp.ident_can_be_quoted i ->
          (rdesc := Pexp_ident (path_to_lid i);
           Some (Obj.repr exp))
      | _ -> Some (Obj.repr exp)
  in {pexp_desc = !rdesc;
      pexp_loc = Location.none;
      pexp_ext = ext}

let map_option f o =
  match o with
    None -> None
  | Some x -> Some (f x) 

let rec map_strict f l =
  match l with
    [] -> []
  | (None::xs) -> map_strict f xs
  | ((Some a):: xs) -> (f a)::(map_strict f xs)
                                
let map_pi2 f p =
  match p with
    (x,y) -> (x, f y)

let map_pi1 f p =
  match p with
    (x,y) -> (f x, y)

let add_ifnew x l =
  if List.exists (fun y -> y=x) l then l else x::l

let env0 = Env.initial

let find_type name =
  try
    let lid = Longident.parse name in
    let (path, decl) = Env.lookup_type lid env0 in
    newty (Tconstr(path, [], ref Mnil))
  with Not_found ->
    fatal_error ("Trx.find_type: " ^ name)
let find_constr name =
  try
    let lid = Longident.parse name in
    Env.lookup_constructor lid env0
  with Not_found ->
    fatal_error ("Trx.find_constr: " ^ name)
let find_label name =
  try
    let lid = Longident.parse name in
    Env.lookup_label lid env0
  with Not_found ->
    fatal_error ("Trx.find_label: " ^ name)
let find_value name =
  try
    let lid = Longident.parse name in
    Env.lookup_value lid env0
  with Not_found ->
    fatal_error ("Trx.find_value: " ^ name)

let type_string = lazy (find_type "string")
let type_bool = lazy (find_type "bool")
let type_int = lazy (find_type "int")
let type_location = lazy (find_type "Location.t")
let pathval_location_none = lazy (find_value "Location.none")
let type_constant = lazy (find_type "Asttypes.constant")
let constr_const_int = lazy (find_constr "Asttypes.Const_int")
let constr_const_char = lazy (find_constr "Asttypes.Const_char")
let constr_const_string = lazy (find_constr "Asttypes.Const_string")
let constr_const_float = lazy (find_constr "Asttypes.Const_float")
let constr_const_int32 = lazy (find_constr "Asttypes.Const_int32")
let constr_const_int64 = lazy (find_constr "Asttypes.Const_int64")
let constr_const_nativeint = lazy (find_constr "Asttypes.Const_nativeint")
let constr_cons = lazy (find_constr "::")
let constr_nil = lazy (find_constr "[]")
let constr_none = lazy (find_constr "None")
let constr_some = lazy (find_constr "Some")
let constr_false = lazy (find_constr "false")
let constr_true = lazy (find_constr "true")
let constr_nonrecursive = lazy (find_constr "Asttypes.Nonrecursive")
let constr_recursive = lazy (find_constr "Asttypes.Recursive")
let constr_default = lazy (find_constr "Asttypes.Default")
let constr_upto = lazy (find_constr "Asttypes.Upto")
let constr_downto = lazy (find_constr "Asttypes.Downto")
    
let type_longident_t = lazy (find_type "Longident.t")
let type_parsetree_expression = lazy (find_type "Parsetree.expression")
let type_parsetree_pattern = lazy (find_type "Parsetree.pattern")
let type_parsetree_structure_item = lazy (find_type "Parsetree.structure_item")
let type_parsetree_module_expr = lazy (find_type "Parsetree.module_expr")
let type_parsetree_core_type = lazy (find_type "Parsetree.core_type")
let label_pexp_desc = lazy (find_label "Parsetree.pexp_desc")
let label_pexp_loc  = lazy (find_label "Parsetree.pexp_loc")
let label_pexp_ext  = lazy (find_label "Parsetree.pexp_ext")
let label_ppat_desc = lazy (find_label "Parsetree.ppat_desc")
let label_ppat_loc  = lazy (find_label "Parsetree.ppat_loc")
let label_ppat_ext  = lazy (find_label "Parsetree.ppat_ext")
let label_ptyp_desc = lazy (find_label "Parsetree.ptyp_desc")
let label_ptyp_loc  = lazy (find_label "Parsetree.ptyp_loc")
let label_pstr_desc = lazy (find_label "Parsetree.pstr_desc")
let label_pstr_loc  = lazy (find_label "Parsetree.pstr_loc")
let label_pmod_desc = lazy (find_label "Parsetree.pmod_desc")
let label_pmod_loc  = lazy (find_label "Parsetree.pmod_loc")
let label_loc_start = lazy (find_label "Location.loc_start")
let label_loc_end   = lazy (find_label "Location.loc_end")
let label_loc_ghost = lazy (find_label "Location.loc_ghost")
let label_pos_fname = lazy (find_label "Lexing.pos_fname")
let label_pos_lnum = lazy (find_label "Lexing.pos_lnum")
let label_pos_bol = lazy (find_label "Lexing.pos_bol")
let label_pos_cnum = lazy (find_label "Lexing.pos_cnum")
let type_parsetree_expression_desc = lazy (find_type "Parsetree.expression_desc")
let type_parsetree_pattern_desc = lazy (find_type "Parsetree.pattern_desc")
let type_parsetree_structure_item_desc = lazy (find_type "Parsetree.structure_item_desc")
let type_parsetree_module_expr_desc = lazy (find_type "Parsetree.module_expr_desc")
let type_core_type_desc = lazy (find_type "Parsetree.core_type_desc")
let type_list       = lazy (find_type "int")  (* XXO bad hack.  Walid. *)
let type_exp_option = lazy (find_type "int")  (* XXO bad hack.  Walid. *)
let type_rec_flag   = lazy (find_type "Asttypes.rec_flag")
let type_label      = lazy (find_type "string")

let constr_pexp_constant      = lazy (find_constr "Parsetree.Pexp_constant")
let constr_pexp_ident         = lazy (find_constr "Parsetree.Pexp_ident")
let constr_pexp_apply         = lazy (find_constr "Parsetree.Pexp_apply")
let constr_pexp_function      = lazy (find_constr "Parsetree.Pexp_function")
let constr_pexp_match         = lazy (find_constr "Parsetree.Pexp_match")
let constr_pexp_try           = lazy (find_constr "Parsetree.Pexp_try")
let constr_pexp_ifthenelse    = lazy (find_constr "Parsetree.Pexp_ifthenelse")
let constr_pexp_record        = lazy (find_constr "Parsetree.Pexp_record")
let constr_pexp_field         = lazy (find_constr "Parsetree.Pexp_field")
let constr_pexp_setfield      = lazy (find_constr "Parsetree.Pexp_setfield")
let constr_pexp_array         = lazy (find_constr "Parsetree.Pexp_array")
let constr_pexp_sequence      = lazy (find_constr "Parsetree.Pexp_sequence")
let constr_pexp_while         = lazy (find_constr "Parsetree.Pexp_while")
let constr_pexp_for           = lazy (find_constr "Parsetree.Pexp_for")
let constr_pexp_when          = lazy (find_constr "Parsetree.Pexp_when")
let constr_pexp_send          = lazy (find_constr "Parsetree.Pexp_send")
let constr_pexp_new           = lazy (find_constr "Parsetree.Pexp_new")
let constr_pexp_let           = lazy (find_constr "Parsetree.Pexp_let")
let constr_pexp_bracket       = lazy (find_constr "Parsetree.Pexp_bracket")
let constr_pexp_escape        = lazy (find_constr "Parsetree.Pexp_escape")
let constr_pexp_run           = lazy (find_constr "Parsetree.Pexp_run")
let constr_pexp_runoffshore   = lazy (find_constr "Parsetree.Pexp_runoffshore")
let constr_pexp_runoffshore_arg   
    = lazy (find_constr "Parsetree.Pexp_runoffshore_arg")
let constr_pexp_assert        = lazy (find_constr "Parsetree.Pexp_assert")
let constr_pexp_assertfalse   = lazy (find_constr "Parsetree.Pexp_assertfalse")
let constr_pexp_lazy      = lazy (find_constr "Parsetree.Pexp_lazy")
let constr_pexp_tuple         = lazy (find_constr "Parsetree.Pexp_tuple")
let constr_pexp_variant       = lazy (find_constr "Parsetree.Pexp_variant")
let constr_pexp_construct     = lazy (find_constr "Parsetree.Pexp_construct")
let constr_pexp_destruct      = lazy (find_constr "Parsetree.Pexp_destruct")
let constr_pexp_cspval        = lazy (find_constr "Parsetree.Pexp_cspval")
let constr_pexp_etag          = lazy (find_constr "Parsetree.Pexp_etag")
let constr_pexp_letmodule     = lazy (find_constr "Parsetree.Pexp_letmodule")
let constr_ppat_construct     = lazy (find_constr "Parsetree.Ppat_construct")
let constr_ppat_record        = lazy (find_constr "Parsetree.Ppat_record")
let constr_ppat_or            = lazy (find_constr "Parsetree.Ppat_or")
let constr_ppat_array         = lazy (find_constr "Parsetree.Ppat_array")
let constr_ppat_var           = lazy (find_constr "Parsetree.Ppat_var")
let constr_ppat_any           = lazy (find_constr "Parsetree.Ppat_any")
let constr_ppat_constant      = lazy (find_constr "Parsetree.Ppat_constant")
let constr_ppat_alias         = lazy (find_constr "Parsetree.Ppat_alias")
let constr_ppat_variant       = lazy (find_constr "Parsetree.Ppat_variant")
let constr_ppat_tuple         = lazy (find_constr "Parsetree.Ppat_tuple")
let constr_longident_lident   = lazy (find_constr "Longident.Lident")
let constr_longident_ldot     = lazy (find_constr "Longident.Ldot")
let constr_longident_lapply   = lazy (find_constr "Longident.Lapply")
let constr_ptyp_constr        = lazy (find_constr "Parsetree.Ptyp_constr")
let constr_ptyp_annotation    = lazy (find_constr "Parsetree.Ptyp_annotation")
let constr_ptyp_arrow         = lazy (find_constr "Parsetree.Ptyp_arrow")
let constr_ptyp_tuple         = lazy (find_constr "Parsetree.Ptyp_tuple")
let constr_ptyp_subst         = lazy (find_constr "Parsetree.Ptyp_subst")
let constr_ptyp_object        = lazy (find_constr "Parsetree.Ptyp_object")
let constr_ptyp_class         = lazy (find_constr "Parsetree.Ptyp_class")
let constr_ptyp_alias         = lazy (find_constr "Parsetree.Ptyp_alias")
let constr_ptyp_variant       = lazy (find_constr "Parsetree.Ptyp_variant")
let constr_ptyp_pvar          = lazy (find_constr "Parsetree.Ptyp_var")
let constr_ptyp_any           = lazy (find_constr "Parsetree.Ptyp_any")
let constr_pstr_value         = lazy (find_constr "Parsetree.Pstr_value")
let constr_pmod_structure     = lazy (find_constr "Parsetree.Pmod_structure")

let pathval_toploop_execute_expression = lazy (find_value "Toploop.execute_expression")
let pathval_trx_execute_expression = lazy (find_value "Trx.execute_expression")
let pathval_trx_etag = lazy (find_value "Trx.etag")
let pathval_trx_longidenttostring = lazy (find_value "Trx.longidenttostring")
let pathval_trx_gensymlongident = lazy (find_value "Trx.gensymlongident")
let pathval_trx_mkcsp = lazy (find_value "Trx.mkcsp")
let pathval_trx_trx_e = lazy(find_value "Trx.trx_expression")
let pathval_trx_get_csp_value = lazy(find_value "Trx.get_csp_value")
let pathval_array_get = lazy(find_value "Array.get")

let type_parsetree_elimination_tag = lazy (find_type "Parsetree.elimination_tag")

let constr_keep  = lazy (find_constr "Parsetree.Keep")
let constr_erase = lazy (find_constr "Parsetree.Erase")
let pathval_trx_runInC = lazy (find_value "Trx.OffshoreC.runInC")
let pathval_trx_runInCarg = lazy (find_value "Trx.OffshoreC.runInCarg")
let pathval_trx_runInCf_all = lazy (find_value "Trx.OffshoreC.runInCf_all")
let pathval_trx_runInCf_all_arg = lazy (find_value "Trx.OffshoreC.runInCf_all_arg")
(*
   let pathval_trx_runInC_new = lazy (find_value "Trx.OffshoreC.runInC_new")
 *)
let pathval_trxfor_runInF = lazy (find_value "Trx.OffshoreF.runInF")


let toploop_execute_expression exp =
  let (p, v) = Lazy.force pathval_toploop_execute_expression in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
let trx_runInC exp =
  let (p, v) = Lazy.force pathval_trx_runInC in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
let trx_runInCarg exp =
  let (p, v) = Lazy.force pathval_trx_runInCarg in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
let trx_runInCf_all exp =
  let (p, v) = Lazy.force pathval_trx_runInCf_all in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
let trx_runInCf_all_arg exp =
  let (p, v) = Lazy.force pathval_trx_runInCf_all_arg in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
(*
   let trx_runInC_new exp =
   let (p, v) = Lazy.force pathval_trx_runInC_new in
   { exp with exp_type = instance v.val_type;
   exp_desc = Texp_ident(p, v) }
 *)
let trxfor_runInF exp =
  let (p, v) = Lazy.force pathval_trxfor_runInF in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_execute_expression exp =
  let (p, v) = Lazy.force pathval_trx_execute_expression in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }
    
let trx_etag exp =
  let (p, v) = Lazy.force pathval_trx_etag in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_longidenttostring exp =
  let (p, v) = Lazy.force pathval_trx_longidenttostring in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_gensymlongident exp =
  let (p, v) = Lazy.force pathval_trx_gensymlongident in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_mkcsp exp =
  let (p, v) = Lazy.force pathval_trx_mkcsp in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_trx_e exp =
  let (p, v) = Lazy.force pathval_trx_trx_e in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_get_csp_value exp =
  let (p, v) = Lazy.force pathval_trx_get_csp_value in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let trx_array_get exp =
  let (p, v) = Lazy.force pathval_array_get in
  { exp with exp_type = instance v.val_type;
    exp_desc = Texp_ident(p, v) }

let mkString exp s =
  { exp with 
    exp_type = Lazy.force type_string;
    exp_desc = Texp_constant(Const_string (s)) }

let mkInt exp i =
  { exp with
    exp_type = Lazy.force type_int;
    exp_desc = Texp_constant(Const_int (i))}

let quote_constant exp cst =
  let (constr,e) =
    match cst with
    | Const_int _ -> (Lazy.force constr_const_int, exp)
    | Const_char _ -> (Lazy.force constr_const_char, exp)
    | Const_string s -> (Lazy.force constr_const_string, mkString exp s)
    | Const_float s -> (Lazy.force constr_const_float, mkString exp s)
    | Const_int32 _ -> (Lazy.force constr_const_int32, exp)
    | Const_int64 _ -> (Lazy.force constr_const_int64, exp)
    | Const_nativeint _ -> (Lazy.force constr_const_nativeint, exp)
  in {exp with exp_type = Lazy.force type_constant;
      exp_desc = Texp_construct(constr, [e],Parsetree.Keep) } 

(* Walid: We should factor out the 'mk' functionality. *)

let mkNone exp =
  { exp with exp_type = Lazy.force type_exp_option;
    exp_desc = Texp_construct(Lazy.force constr_none, [],Parsetree.Keep) }
    
let mkSome exp e =
  { exp with exp_type = Lazy.force type_exp_option;
    exp_desc = Texp_construct(Lazy.force constr_some, [e],Parsetree.Keep) }

let mkPexpOption exp eo = match eo with
  None -> mkNone exp
| Some e -> mkSome exp e

let quote_rec_flag rf exp =
  let cst = match rf with
    Nonrecursive -> constr_nonrecursive
  | Recursive -> constr_recursive
  | Default -> constr_default
  in { exp with 
       exp_type = Lazy.force type_rec_flag;
       exp_desc = Texp_construct(Lazy.force cst, [],Parsetree.Keep) } 

let quote_direction_flag df exp =
  let cst = match df with
    Upto -> constr_upto
  | Downto -> constr_downto
  in { exp with exp_type = Lazy.force type_rec_flag;
       exp_desc = Texp_construct(Lazy.force cst, [], Parsetree.Keep) }

let mkfalse exp =
  { exp with exp_type = Lazy.force type_bool;
    exp_desc = Texp_construct(Lazy.force constr_false, [], Parsetree.Keep) }

let mktrue exp =
  { exp with exp_type = Lazy.force type_bool;
    exp_desc = Texp_construct(Lazy.force constr_true, [],Parsetree.Keep) } 

let mkKeep exp =
  { exp with exp_type = Lazy.force type_parsetree_elimination_tag;
    exp_desc = Texp_construct(Lazy.force constr_keep, [],Parsetree.Keep) } 
let mkErase exp =
  { exp with exp_type = Lazy.force type_parsetree_elimination_tag;
    exp_desc = Texp_construct(Lazy.force constr_erase, [],Parsetree.Keep) } 


let quote_position exp p =
  {exp with exp_desc =
   Texp_record([Lazy.force label_pos_fname,
                mkString exp p.Lexing.pos_fname;
                Lazy.force label_pos_lnum,
                {exp with exp_desc = Texp_constant (Const_int p.Lexing.pos_lnum)};
                Lazy.force label_pos_bol,
                {exp with exp_desc = Texp_constant (Const_int p.Lexing.pos_bol)};
                Lazy.force label_pos_cnum,
                {exp with exp_desc = Texp_constant (Const_int p.Lexing.pos_cnum)}
              ],
               None)}

let quote_location exp =
  let make_absolute file =
    if Filename.is_relative file
    then Filename.concat (Sys.getcwd()) file
    else file in
  let _  = if String.length !Location.input_name = 0
  then ""
  else make_absolute !Location.input_name 
  in {exp with exp_desc =
      Texp_record([Lazy.force label_loc_start,
                   quote_position exp exp.exp_loc.Location.loc_start;
                   Lazy.force label_loc_end,
                   quote_position exp exp.exp_loc.Location.loc_end;
                   Lazy.force label_loc_ghost,
                   if exp.exp_loc.Location.loc_ghost then mktrue exp else mkfalse exp;
                 ],
                  None)}

let mkExp exp t d = 
  { exp with exp_type = Lazy.force t;
    exp_desc = d}

let mkPat exp t d =
  { exp with pat_type = Lazy.force t;
    pat_desc = d}


let rec quote_longident exp li =
  match li with
    Longident.Lident s ->
      mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_lident, 
                        [mkString exp s],Parsetree.Keep))
  | Longident.Ldot (li',s) ->
      mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_ldot,
                        [quote_longident exp li';
                         mkString exp s],Parsetree.Keep))
  | Longident.Lapply (li1,li2) ->
      mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_lapply,
                        [quote_longident exp li1;
                         quote_longident exp li2],Parsetree.Keep))

let quote_label exp l =
  { exp with 
    exp_type = Lazy.force type_label;
    exp_desc = Texp_constant(Const_string (l)) }

let rec mkIdent exp id =
  match id with
    Longident.Lident s ->
      mkExp exp type_longident_t
        (Texp_construct(Lazy.force constr_longident_lident,
                        [mkString exp s],Parsetree.Keep))
  |  Longident.Ldot (id', s) ->
      let exp' = mkIdent exp id' in
      mkExp exp type_longident_t
        (Texp_construct(Lazy.force constr_longident_ldot,
                        [exp'; mkString exp s],Parsetree.Keep))
  |  Longident.Lapply (id1, id2) ->
      let exp1 = mkIdent exp id1 in
      let exp2 = mkIdent exp id2 in
      mkExp exp type_longident_t
        (Texp_construct(Lazy.force constr_longident_lapply,
                        [exp1;exp2],Parsetree.Keep))

let rec quote_ident exp path =
  match path with
    Path.Pident i -> mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_lident, 
                        [mkString exp (Ident.name i)],Parsetree.Keep))
  | Path.Pdot (path',s,k) ->
      mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_ldot,
                        [quote_ident exp path';
                         mkString exp s],Parsetree.Keep))
  | Path.Papply (path1,path2) ->
      mkExp exp
        type_longident_t
        (Texp_construct(Lazy.force constr_longident_lapply,
                        [quote_ident exp path1;
                         quote_ident exp path2],Parsetree.Keep))

(* support for native code *)
let native_mode = ref false
let initial_native_compilation = ref false
let execute_expression_hook = ref (fun _ -> assert false)
let load_compiled_code_hook = ref (fun n -> ())
let execute_expression_result = ref (Obj.repr 7)
let execute_expression e = !execute_expression_hook e
let empty_csp_array = Array.create 1000 (Obj.repr ())
let csp_array = ref (Array.copy empty_csp_array)
let csp_index = ref 0
let reset_csp_array () =
  csp_array := Array.copy empty_csp_array;
  csp_index := 0
let csp_arr_filename = "saved_csp_array"
let get_csp_value  n = !csp_array.(n)
let save_csp_array () = if !csp_index <> 0 then
  let outchan = open_out csp_arr_filename in
  let v = (!csp_index, !csp_array)
  in Marshal.to_channel outchan v []; close_out outchan
let load_csp_array () =
  let inchan = open_in csp_arr_filename in
  let (len,a) = Marshal.from_channel inchan
  in csp_index := len; csp_array := a;
  close_in inchan
let add_csp_value (v,l) =
  begin
    if (!csp_index >= (Array.length !csp_array))
    then csp_array := Array.append !csp_array empty_csp_array
  end;
  !csp_array.(!csp_index) <- v;
  incr csp_index;
  !csp_index - 1

let local_csp_arr_texp = ref (Obj.magic ())

let remove_texp_cspval exp =
  if !native_mode = false then exp else
  match exp.exp_desc with
  | Texp_cspval (v,l) ->
      let i = add_csp_value (v,l) in
      let exp' = {exp with exp_desc = Texp_constant (Const_int i)} in
      let desc = if !initial_native_compilation
        then (Texp_apply (trx_array_get exp, [(Some !local_csp_arr_texp, Required);(Some exp', Required)]))
	else (Texp_apply (trx_get_csp_value exp, [(Some exp', Required)])) in
      {exp with exp_desc = desc}
  | _ -> assert false

let mkParseTree_ext vo exp d =
  let eo = match vo with
  | None -> None
  | Some exp' ->
      Env.make_env_pure exp'.exp_env;
      Env.update_ident_timestamp exp'.exp_env;
      Some (remove_texp_cspval {exp with exp_desc = Texp_cspval (Obj.magic exp', Longident.parse "")})
  in
  {exp with
   exp_desc =
   Texp_record([Lazy.force label_pexp_desc,
                mkExp exp type_parsetree_expression_desc d;
                Lazy.force label_pexp_loc,
                quote_location exp;
                Lazy.force label_pexp_ext,
                mkPexpOption exp eo],
               None) }


let emtyexp_with_timestamp =
  let e = { exp_desc = Texp_assertfalse;  (* dummy exp filled with random values *)
            exp_loc = Location.none;
            exp_type = Btype.newgenvar ();
            exp_env = Env.empty }
  in fun () -> {e with exp_env = Env.empty_with_timestamp () }

let mkParseTree exp d =
  mkParseTree_ext (Some (emtyexp_with_timestamp ())) exp d

let mkParsePattern_ext vo exp d =
  let eo = match vo with
  | None -> None
  | Some p ->
      Env.make_env_pure p.pat_env;
      Env.update_ident_timestamp p.pat_env;
      Some (remove_texp_cspval {exp with exp_desc = Texp_cspval (Obj.magic p, Longident.parse "")})
  in
  mkExp exp
    type_parsetree_pattern
    (Texp_record([Lazy.force label_ppat_desc, mkExp exp type_parsetree_pattern_desc d;
                  Lazy.force label_ppat_loc, quote_location exp;
                  Lazy.force label_ppat_ext, mkPexpOption exp eo],
                 None))
    
let mkParsePattern exp d = 
  mkParsePattern_ext None exp d


(* @@@@@ *)
let mkParseStructureItem exp d =
  mkExp exp
    type_parsetree_structure_item
    (Texp_record([Lazy.force label_pstr_desc,
                  mkExp exp type_parsetree_structure_item_desc d;
                  Lazy.force label_pstr_loc, quote_location exp],
                 None))

let mkParseModuleExpr exp d =
  mkExp exp
    type_parsetree_module_expr
    (Texp_record([Lazy.force label_pmod_desc,
                  mkExp exp type_parsetree_module_expr_desc d;
                  Lazy.force label_pmod_loc, quote_location exp],
                 None))


let rec mkPexpList exp l =
  match l with
    [] ->    mkExp exp
        type_list
        (Texp_construct(Lazy.force constr_nil, 
                        [],Parsetree.Keep))
  | x::xs -> mkExp exp
        type_list
        (Texp_construct(Lazy.force constr_cons, 
                        [x;mkPexpList exp xs],Parsetree.Keep))

let mkPexpTuple exp exps = 
  mkExp exp
    type_parsetree_expression_desc
    (Texp_construct(Lazy.force constr_pexp_tuple, exps,Parsetree.Keep))

let mkPpatTuple exp exps =
  mkExp exp
    type_parsetree_pattern_desc
    (Texp_construct(Lazy.force constr_ppat_tuple, 
                    [mkPexpList exp exps],Parsetree.Keep))

let rec quote_list_as_expopt_forexps exp el =
  match el with
    [] -> mkNone exp
  | [e] -> mkSome exp e
  | _ -> mkSome exp
        (mkParseTree exp
           (texp_construct_keep(Lazy.force constr_pexp_tuple,
                                [mkPexpList exp el])))

let rec quote_list_as_expopt_forpats exp el =
  match el with
    [] -> mkNone exp
  | [e] -> mkSome exp e
  | _ -> mkSome exp
        (mkParsePattern exp
           (texp_construct_keep(Lazy.force constr_ppat_tuple,
                                [mkPexpList exp el])))

let mkParseAtyp exp d =
(*  let eo = match vo with
   | None -> None
   | Some v -> Some {exp with exp_desc = Texp_cspval v}
   in *)
  {exp with
   exp_desc =
   Texp_record([Lazy.force label_ptyp_desc,
                mkExp exp type_core_type_desc d;
                Lazy.force label_ptyp_loc,
                quote_location exp],
               None) }

(* Walid: TVar and TAny cases should looked at.  
   Also need to do Nil, Tlink, Variant, Object, Field *)
let rec mkAtyp exp atye =
  match atye.desc with
    Tlink typ -> mkAtyp exp typ
  | tdesc ->
      begin
        let ast = match tdesc with
          Tconstr(p, tlist, amemo) ->
            texp_construct_keep(Lazy.force constr_ptyp_constr,
                                [quote_ident exp p; 
                                 mkPexpList exp (List.map (mkAtyp exp) tlist)])
        | Tannotation(id, atyp', atyp) ->
            texp_construct_keep(Lazy.force constr_ptyp_annotation,
                                [quote_longident exp id; 
                                 mkPexpList exp(List.map (mkAtyp exp) atyp')]) 
              (* temp change, the annotated type is limited now *)
        | Tarrow(l, atyps, atypr, com)  ->
            texp_construct_keep(Lazy.force constr_ptyp_arrow,
                                [mkString exp l; mkAtyp exp atyps; mkAtyp exp atypr])
        | Ttuple tlist ->
            texp_construct_keep(Lazy.force constr_ptyp_tuple,
                                [mkPexpList exp (List.map (mkAtyp exp) tlist)])
        | Tsubst t -> texp_construct_keep (Lazy.force constr_ptyp_subst, [(mkAtyp exp t)])
        | Tvar -> 
            let name = Printf.sprintf "a%d" (atye.id) in
            let str  = mkString exp name in
            texp_construct_keep  
              (Lazy.force constr_ptyp_pvar, [str]) 
        | _ -> 
            (if !Clflags.debug_messages
            then Format.fprintf Format.std_formatter "Trx.mkAtyp undefined for %a\n" 
                Printtyp.type_expr atye;  
             fatal_error "Trx.mkAtyp") 
        in mkParseAtyp exp ast
      end

let gensymstring_count = ref 0 (* OXX scope expanded to allow for resetting *)

(* generates a fresh identifier *)
let gensymstring s =
  incr gensymstring_count;
  s ^ "_" ^ string_of_int !gensymstring_count

(* OXX resets the counter used to ensure unique identifiers.
   this behavior is supressed by the -noreset command. *)
let reset_gensymstring_counter () = gensymstring_count := 0

let gensymlongident li =
  match li with
    Longident.Lident s -> Longident.Lident (gensymstring s)
  | _ -> fatal_error ("Trx.gensymstring: not a simple id")

let longidenttostring li =
  match li with
    Longident.Lident s -> s
  | _ -> fatal_error ("Trx.longidenttostring: li is not a simple id")

let rec boundinpattern p l = (* extend list l with ids bound in pattern p *)
  match p.pat_desc with
    Tpat_any -> l
  | Tpat_var i -> add_ifnew i l
  | Tpat_alias (p,i) -> boundinpattern p (add_ifnew i l)
  | Tpat_constant c -> l
  | Tpat_tuple pl -> List.fold_right boundinpattern pl l
  | Tpat_construct (cd,pl) -> 
      List.fold_right boundinpattern pl l
  | Tpat_variant (_,po,_) -> (match po with
      None -> l
    | Some p -> boundinpattern p l)
  | Tpat_record dpl -> List.fold_right (fun (d,p) -> boundinpattern p) dpl l
  | Tpat_array pl -> List.fold_right boundinpattern pl l
  | Tpat_or (p1,p2,_) -> boundinpattern p2 (boundinpattern p1 l)

let rec mkPattern exp p =
  let idexp id = mkExp exp type_longident_t
      (Texp_ident (Path.Pident id,
                   {val_type = Lazy.force type_longident_t;
                    val_level = [];
                    val_kind = Val_reg}))
  in let strexp id = mkExp exp type_string
      (Texp_apply (trx_longidenttostring exp, [(Some (idexp id),
                                                Required)]))
  in match p.pat_desc with 
    Tpat_any -> mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_any, 
                             []))
  | Tpat_var id -> mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_var, 
                             [strexp id]))
  | Tpat_alias (p,i) ->
      mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_alias,
                             [mkPattern exp p;
                              strexp i]))
  | Tpat_constant cst ->
      mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_constant, 
                             [quote_constant
                                {
                                 exp_desc = Texp_constant cst;
                                 exp_loc  = p.pat_loc;
                                 exp_type = p.pat_type;
                                 exp_env  = p.pat_env
                               } 
                                cst]))
  | Tpat_tuple pl ->
      let el = List.map (mkPattern exp) pl
      in mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_tuple, 
                             [mkPexpList exp el]))
  | Tpat_construct ({cstr_tag=tag},pl) ->
      let lid = get_constr_lid tag p.pat_type p.pat_env in
      mkParsePattern_ext (Some p) exp
        (texp_construct_keep(Lazy.force constr_ppat_construct,
                             [quote_longident exp lid;
                              quote_list_as_expopt_forpats exp
                                (List.map (mkPattern exp) pl);
                              mkfalse exp ])) 
  | Tpat_variant (l,po,rd) ->
      mkParsePattern exp
        (texp_construct_keep(Lazy.force constr_ppat_variant,
                             [mkString exp l;
                              mkPexpOption exp
                                (map_option (mkPattern exp) po)]))
  | Tpat_record dpil ->
      let lids = get_record_lids p.pat_type p.pat_env in
      let dpil = List.map
          (fun (d,p) -> (d,p,List.nth lids d.lbl_pos))
          dpil in
      let get_idpat =
        fun (d,p,lid) ->
          mkPexpTuple exp [quote_longident exp lid;
                           mkPattern exp p]
      in
      mkParsePattern_ext (Some p) exp
        (texp_construct_keep(Lazy.force constr_ppat_record,
                             [mkPexpList exp
                                (List.map get_idpat dpil)
                            ])) 
  | Tpat_array pl ->
      mkParsePattern exp 
        (texp_construct_keep(Lazy.force constr_ppat_array,
                             [mkPexpList exp
                                (List.map (mkPattern exp) pl)]))
  | Tpat_or (p1,p2,_) ->
      mkParsePattern exp 
        (texp_construct_keep(Lazy.force constr_ppat_or,
                             [mkPattern exp p1;
                              mkPattern exp p2]))

let mkNewPEL exp pEl = 
  List.map (fun (p,e) -> mkPexpTuple exp [mkPattern exp p;e]) pEl


(* The preprocessing transformation proper *)

let call_trx_mkcsp exp v li =
  let exp' = remove_texp_cspval {exp with exp_desc = Texp_cspval (Obj.magic v, Longident.parse "")}
  and expli = remove_texp_cspval {exp with exp_desc = Texp_cspval (Obj.magic li, Longident.parse "")}
  in {exp with exp_desc = 
      (Texp_apply (trx_mkcsp exp, [(Some exp, Required);
                                   (Some exp',Required);
                                   (Some expli,Required)]))}

let rec trx_e n exp =

(* generates the appropriate translator function call *)
  let rec mkOffshoreCall_helper_fun_or_base t translator_call_function 
      translator_call_nonfunction = 
    match t.desc with
      Tlink te -> mkOffshoreCall_helper_fun_or_base te 
          translator_call_function translator_call_nonfunction
    |  Tarrow(_,_,_,_) -> translator_call_function
    | _ ->   translator_call_nonfunction
  in
  let mkOffshoreCall_helper e translator_call_function translator_call_nonfunction =
    match e.exp_desc with
      Texp_bracket d -> (match d.exp_desc with 
        Texp_function(_, _) -> 
          translator_call_function
      | _ -> 
		  (mkOffshoreCall_helper_fun_or_base d.exp_type
                 translator_call_function
                 translator_call_nonfunction)
                        )
    | Texp_ident (_,v) -> 
        let rec callApprFunction te_desc = 
          (match te_desc with 
            Tlink te  -> callApprFunction te.desc
          | Tconstr(_,[t],_) -> 
              (mkOffshoreCall_helper_fun_or_base t
                 translator_call_function 
                 translator_call_nonfunction)
          | Tconstr(_,[_;t],_) -> 
              (mkOffshoreCall_helper_fun_or_base t
                 translator_call_function
                 translator_call_nonfunction)
          | _ ->  
              fatal_error ("Trx: Non-code or bad identifier given to offshore")
          )
        in
        callApprFunction v.val_type.desc 
    | _ ->  fatal_error ("Trx: Neither code or identifier given to offshore")
  in
  let mkOffshoreCall defLang args e exp= 
    let rec lookup_def key default 
        = function [] -> default
          | ((k,v)::t) -> if k = key then v else lookup_def key default t
    in
    let lang = lookup_def "lang" defLang args 
    in 
    match lang with 
      "C" -> (
        let getArg d =  
          let def = (OffshoreC.getDefaultArg d)
          in lookup_def d def args
        in
        let compiler  =  getArg "compiler"
        and compiler_flags  = getArg "compiler_flags" 
        and working_dir  = getArg "working_dir" 
        and file_name  =  getArg  "file_name" 
        and main_function_name = getArg "main_function_name" in
        let arg0 = { exp  with 
                     exp_desc = Texp_constant( 
                     Const_string(compiler)) }
        and arg1 = { exp  with 
                     exp_desc = Texp_constant( 
                     Const_string(compiler_flags)) } 
        and arg2 = { exp with 
                     exp_desc = Texp_constant( 
                     Const_string(working_dir)) } 
        and arg3 = { exp with 
                     exp_desc = Texp_constant( 
                     Const_string(file_name)) } 
        and arg4 = { exp with 
                     exp_desc = Texp_constant(
                     Const_string(main_function_name)) }
        in
        let translator_call_function = 
          {exp with
           exp_desc = Texp_apply(trx_runInCf_all_arg exp,
                                 [
                                  (Some (trx_e n e), Required);
                                  (Some (arg0), Required);
                                  (Some (arg1), Required);
                                  (Some (arg2), Required);
                                  (Some (arg3), Required);
                                  (Some (arg4), Required)
                                ])}
        and translator_call_nonfunction = 
          {exp with
           exp_desc = Texp_apply(trx_runInCarg exp,
                                 [
                                  (Some (trx_e n e), Required);
                                  (Some (arg0), Required);
                                  (Some (arg1), Required);
                                  (Some (arg2), Required);
                                  (Some (arg3), Required)
                                ])}
        in mkOffshoreCall_helper e translator_call_function translator_call_nonfunction
       )
    | "F" -> (
        let getArg d =  
          let def = (OffshoreF.getDefaultArg d)
          in lookup_def d def args
        in
        let compiler  = getArg "compiler" 
        and compiler_flags  = getArg "compiler_flags" 
        and f90_lib_path  = getArg "f90_lib_path" 
        and working_dir  = getArg "working_dir" 
        and file_name  =  getArg "file_name" 
        and main_function_name = getArg "main_function_name" in 
        let arg0 = { exp  with 
                     exp_desc = Texp_constant( 
                     Const_string(compiler)) }
        and arg1 = { exp  with 
                     exp_desc = Texp_constant( 
                     Const_string(compiler_flags)) } 
        and _  = { exp  with 
                     exp_desc = Texp_constant( 
                     Const_string(f90_lib_path)) } 
        and arg3 = { exp with 
                     exp_desc = Texp_constant( 
                     Const_string(working_dir)) } 
        and arg4 = { exp with 
                     exp_desc = Texp_constant( 
                     Const_string(file_name)) } 
        and _ = { exp with 
                     exp_desc = Texp_constant(
                     Const_string(main_function_name)) }
        in
        (* replace this by call to runInFf when marshalling ready *)
        let translator_call_function = 
          {exp with
           exp_desc = Texp_apply(trxfor_runInF exp,
                                 [
                                  (Some (trx_e n e), Required);
                                  (Some (arg0), Required);
                                  (Some (arg1), Required);
                                  (Some (arg3), Required);
                                  (Some (arg4), Required)
                                ])}
        and translator_call_nonfunction = 
          {exp with
           exp_desc = Texp_apply(trxfor_runInF exp,
                                 [
                                  (Some (trx_e n e), Required);
                                  (Some (arg0), Required);
                                  (Some (arg1), Required);
                                  (Some (arg3), Required);
                                  (Some (arg4), Required)
                                ])}
        in mkOffshoreCall_helper e translator_call_function translator_call_nonfunction
       )
    | _ -> raise (OffshoringError ("Unsupported language: " ^ lang))
(*
   in 
   let csp_carry = {exp with exp_desc = Texp_cspval (Obj.magic e)}
   in
   let csp_carry_only_type = {exp with exp_desc = 
   Texp_cspval (Obj.magic e.exp_type)}
   in 
   {exp with
   exp_desc = Texp_apply(func exp,
   [ 
   (Some (csp_carry_only_type), Required);
   (Some (csp_carry), Required);
   (Some (trx_e n e), Required)])}
 *)
  in
  if n = 0 then begin               (*  level 0  *)
    match exp.exp_desc with
      Texp_ident _ -> exp
    | Texp_constant _ -> exp
    | Texp_let (f,pel,e) ->
        { exp with exp_desc =
          Texp_let (f,
                    List.map (map_pi2 (trx_e n)) pel, 
                    trx_e n e) }
    | Texp_function (pel, partial) ->
        { exp with exp_desc =
          Texp_function (List.map (map_pi2 (trx_e n)) pel, partial) }
    | Texp_apply (e,eool) ->
        { exp with exp_desc =
          Texp_apply (trx_e n e,
                      List.map (map_pi1 (map_option (trx_e n))) eool) }
    | Texp_match (e,pel,partial) ->
        { exp with exp_desc =
          Texp_match(trx_e n e,
                     List.map (map_pi2 (trx_e n)) pel,
                     partial) }
    | Texp_try (e,pel) ->
        { exp with exp_desc =
          Texp_try(trx_e n e,
                   List.map (map_pi2 (trx_e n)) pel) }
    | Texp_tuple el ->
        { exp with exp_desc =
          Texp_tuple (List.map (trx_e n) el)}
    | Texp_construct (cd,el,erasure) ->
        { exp with exp_desc = 
          Texp_construct (cd, List.map (trx_e n) el,erasure)}
    | Texp_variant (label, eo) ->
        { exp with exp_desc =
          Texp_variant (label, map_option (trx_e n) eo) }
    | Texp_record (del, eo) ->
        { exp with exp_desc =
          Texp_record (List.map (map_pi2 (trx_e n)) del,
                       map_option (trx_e n) eo) }
    | Texp_field (e,ld) ->
        { exp with exp_desc =
          Texp_field(trx_e n e, ld)}
    | Texp_setfield (e1,ld,e2) ->
        { exp with exp_desc =
          Texp_setfield(trx_e n e1, ld, trx_e n e2) }
    | Texp_array el ->
        { exp with exp_desc =
          Texp_array (List.map (trx_e n) el) }
    | Texp_ifthenelse (e1,e2,eo) ->
        { exp with exp_desc =
          Texp_ifthenelse (trx_e n e1,
                           trx_e n e2,
                           map_option (trx_e n) eo) }
    | Texp_sequence (e1,e2) ->
        { exp with exp_desc =
          Texp_sequence(trx_e n e1, trx_e n e2) }
    | Texp_while (e1,e2) ->
        { exp with exp_desc =
          Texp_while(trx_e n e1, trx_e n e2) }
    | Texp_for (id,e1,e2,df,e3) ->
        { exp with exp_desc = 
          Texp_for (id,
                    trx_e n e1,
                    trx_e n e2,
                    df,
                    trx_e n e3) }
    | Texp_when (e1,e2) ->
        { exp with exp_desc =
          Texp_when(trx_e n e1, trx_e n e2) }
    | Texp_send (e,m) ->
        { exp with exp_desc =
          Texp_send (trx_e n e, m)
        }
    | Texp_new (p,d) -> exp
    | Texp_instvar (p1,p2) -> exp
    | Texp_setinstvar (p1,p2,e) ->
        { exp with exp_desc =
          Texp_setinstvar(p1,p2, trx_e n e)
        }
    | Texp_override (p,pel) ->
        { exp with exp_desc =
          Texp_override(p, List.map (fun (p,e) -> (p, trx_e n e)) pel)
        }
    | Texp_letmodule (i,me,e) ->
        { exp with exp_desc =
          Texp_letmodule(i, trx_me me, trx_e n e) }
    | Texp_assert e ->
        {exp with exp_desc = Texp_assert (trx_e n e)}
    | Texp_assertfalse -> exp
    | Texp_lazy e ->
        {exp with exp_desc = Texp_lazy (trx_e n e)}
    | Texp_object ({ cl_field = cfl; cl_meths = ms },csig,sl) ->
        let cs = { cl_field = List.map trx_cf cfl; cl_meths = ms }
        in {exp with exp_desc =  Texp_object (cs,csig,sl)}
    | Texp_bracket e -> 
        let e' = trx_e (n+1) e
        in {exp with exp_desc = e'.exp_desc} 
    | Texp_escape e -> assert false
    | Texp_run e ->
        let exec = if !native_mode then trx_execute_expression 
        else toploop_execute_expression in
        {exp with
         exp_desc = Texp_apply(exec exp,
                               [(Some (trx_e n e), Required)])}
    | Texp_runoffshore(e, lang) ->
        mkOffshoreCall "lang" [("lang", lang)] e exp
    | Texp_runoffshore_arg(s_list, e) ->
        mkOffshoreCall "language should always be specified" s_list e exp
    | Texp_cspval (v,li) -> remove_texp_cspval exp
    | Texp_destruct(cd, e,erase) ->
        let e' = trx_e n e in
        let lid = get_constr_lid (cd.cstr_tag) e.exp_type exp.exp_env in
        let m = Typecore.build_destr_match e' cd lid exp.exp_env erase exp.exp_loc in
        trx_e n m
    | Texp_etag (a, e, e1, env_exp) ->
        let a' =  mkAtyp exp a in
        let e' = trx_e n e in
        let e1' = trx_e n e1 in 
        {exp with
         exp_desc = Texp_apply(trx_etag exp, 
                               [(Some a',Required);
                                (Some e',Required);
                                (Some e1',Required);
                                (Some (remove_texp_cspval env_exp),Required)])}
(*  | _ -> fatal_error ("Trx.trx_e level 0: case not implemented yet") *)

  end else begin                           (* level n+1 *)
    match exp.exp_desc with
      (* function is called at run time,so it gets compiled, if we can keep the information at this point *)
      Texp_ident (i,vd) ->
        begin match vd.val_level with
        | [] ->
            let _ = Env.make_env_pure exp.exp_env in
            let _ = Env.update_ident_timestamp exp.exp_env in
            let v = (Some {exp with exp_type = instance vd.val_type})
            in call_trx_mkcsp exp v (path_to_lid i)
        | _ ->
            mkParseTree exp   (* construct VAR x *)
              (texp_construct_keep(Lazy.force constr_pexp_ident, 
                                   [{exp with exp_type = Lazy.force type_longident_t}]))
        end
          
    | Texp_constant cst ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_constant, 
                               [quote_constant exp cst]))

    | Texp_let (rf, pel, e1) ->
        begin
          match rf with
            Recursive ->
              let idlist = List.fold_right (fun (p,e) -> boundinpattern p) pel []
              and gensymexp id =  (* (gensym "x") *)
                mkExp exp
                  type_longident_t
                  (Texp_apply
                     (trx_gensymlongident exp,
                      [(Some (quote_ident exp (Path.Pident id)),
                        Required)]))
              and idpat id =
                {pat_desc = Tpat_var id;
                 pat_loc = exp.exp_loc;
                 pat_type = Lazy.force type_longident_t;
                 pat_env = exp.exp_env}
              and translet =
                mkParseTree exp
                  (texp_construct_keep
                     (Lazy.force constr_pexp_let, 
                      [quote_rec_flag rf exp;
                       mkPexpList exp 
                         (mkNewPEL exp
                            (List.map (map_pi2 (trx_e n)) pel));
                       trx_e n e1
                     ]
                     )
                  )
              in let pel' = List.map (fun id -> (idpat id, gensymexp id)) idlist
              in mkExp exp
                type_parsetree_expression
                (Texp_let
                   (Nonrecursive,
                    pel', 
                    translet))


          | _ ->
              let idlist = List.fold_right (fun (p,e) -> boundinpattern p) pel []
              and peil = let genid () = Ident.create (gensymstring "fresh")
              in List.map (fun (p,e) -> (p,e, genid())) pel
              and gensymexp id =  (* (gensym "x") *)
                mkExp exp
                  type_longident_t
                  (Texp_apply
                     (trx_gensymlongident exp,
                      [(Some (quote_ident exp (Path.Pident id)),
                        Required)]))
              in let idpat_t id t =
                {pat_desc = Tpat_var id;
                 pat_loc = exp.exp_loc;
                 pat_type = Lazy.force t;
                 pat_env = exp.exp_env}
              in let idpat id = idpat_t id type_longident_t
              in let idexp e id =
                {e with exp_desc =
                 (Texp_ident (Path.Pident id,
                              {val_type = e.exp_type;
                               val_level = [];
                               val_kind = Val_reg}))}
              in let pel' = List.map (fun (p,e,i) -> (p, idexp e i)) peil
              in let translet =
                mkParseTree exp
                  (texp_construct_keep
                     (Lazy.force constr_pexp_let, 
                      [quote_rec_flag rf exp;
                       mkPexpList exp (mkNewPEL exp pel');
                       trx_e n e1
                     ]
                     )
                  )
              in let pel1 = List.map (fun id -> (idpat id, gensymexp id)) idlist
              in let pel2 = List.map
                  (fun (p,e,i) -> (idpat_t i type_parsetree_expression,
                                   trx_e n e))
                  peil
              in mkExp exp
                type_parsetree_expression
                (Texp_let
                   (Nonrecursive,
                    List.append pel1 pel2, 
                    translet))
        end

    | Texp_function (pel, partial) ->
        (* XXO implement the translation
           trans(\x.e)  --->  let x = gensym "x" in LAM x trans(e) *)
        let idlist =
          List.fold_right (fun (p,e) -> boundinpattern p) pel []  
        and gensymexp id =  (* (gensym "x") *)
          mkExp exp
            type_longident_t
            (Texp_apply
               (trx_gensymlongident exp,
                [(Some (quote_ident exp (Path.Pident id)),
                  Required)]))
        and idpat id =
          {pat_desc = Tpat_var id;
           pat_loc = exp.exp_loc;
           pat_type = Lazy.force type_longident_t;
           pat_env = exp.exp_env}
        and transfunction =   (* LAM x trans(e) *)
          mkParseTree exp
            (texp_construct_keep
               (Lazy.force constr_pexp_function, 
                [mkString exp "";
                 mkNone exp;
                 mkPexpList exp 
                   (mkNewPEL exp
                      (List.map (map_pi2 (trx_e n)) pel))
               ]
               )
            )
        in let pel' = List.map (fun id -> (idpat id, gensymexp id)) idlist
        in mkExp exp
          type_parsetree_expression
          (Texp_let
             (Nonrecursive,
              pel', 
              transfunction))
          
(* XXO the following is a bit hoky.  We also don't really put
   the real type for lists right now.  We need to ask a higher
   power.  Walid.  *)
    | Texp_apply (e,eool) ->
        let eol = List.map fst eool in
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_apply, 
                               [trx_e n e;
                                mkPexpList exp (map_strict (fun x -> mkPexpTuple exp
                                    [mkString exp "";
                                     trx_e n x]) 
                                                  eol)]))
    | Texp_match (e,pel,partial) ->
        let idlist =
          List.fold_right (fun (p,e) -> boundinpattern p) pel []  
        and gensymexp id =  (* (gensym "x") *)
          mkExp exp
            type_longident_t
            (Texp_apply
               (trx_gensymlongident exp,
                [(Some (quote_ident exp (Path.Pident id)),
                  Required)]))
        and idpat id =
          {pat_desc = Tpat_var id;
           pat_loc = exp.exp_loc;
           pat_type = Lazy.force type_longident_t;
           pat_env = exp.exp_env}
        and transmatch =
          mkParseTree exp
            (texp_construct_keep
               (Lazy.force constr_pexp_match, 
                [trx_e n e;
                 mkPexpList exp 
                   (mkNewPEL exp
                      (List.map (map_pi2 (trx_e n)) pel))
               ]
               )
            )
        in let pel' = List.map (fun id -> (idpat id, gensymexp id)) idlist
        in mkExp exp
          type_parsetree_expression
          (Texp_let
             (Nonrecursive,
              pel', 
              transmatch))
          
    | Texp_try (e,pel) ->
        let idlist =
          List.fold_right (fun (p,e) -> boundinpattern p) pel []  
        and gensymexp id =  (* (gensym "x") *)
          mkExp exp
            type_longident_t
            (Texp_apply
               (trx_gensymlongident exp,
                [(Some (quote_ident exp (Path.Pident id)),
                  Required)]))
        and idpat id =
          {pat_desc = Tpat_var id;
           pat_loc = exp.exp_loc;
           pat_type = Lazy.force type_longident_t;
           pat_env = exp.exp_env}
        and transtry =
          mkParseTree exp
            (texp_construct_keep
               (Lazy.force constr_pexp_try, 
                [trx_e n e;
                 mkPexpList exp 
                   (mkNewPEL exp
                      (List.map (map_pi2 (trx_e n)) pel))
               ]
               )
            )
        in let pel' = List.map (fun id -> (idpat id, gensymexp id)) idlist
        in mkExp exp
          type_parsetree_expression
          (Texp_let
             (Nonrecursive,
              pel', 
              transtry))

    | Texp_tuple el ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_tuple,
                               [mkPexpList exp (List.map (trx_e n) el)]))
    | Texp_destruct ({cstr_tag=tag}, e,erase) ->
        let lid = get_constr_lid tag e.exp_type exp.exp_env in
        mkParseTree_ext (Some exp) exp 
          (texp_construct_keep(Lazy.force constr_pexp_destruct,
                               [quote_longident exp lid;
                                trx_e n e; if erase==Parsetree.Keep then mkKeep exp else mkErase exp]))
    | Texp_construct ({cstr_tag=tag}, el,erasure) ->
        let lid = get_constr_lid tag exp.exp_type exp.exp_env in
        mkParseTree_ext (Some exp) exp
          (Texp_construct(Lazy.force constr_pexp_construct,
                          [quote_longident exp lid;
                           quote_list_as_expopt_forexps exp
                             (List.map (trx_e n) el);
                           mkfalse exp;
                           if erasure==Parsetree.Keep then mkKeep exp else mkErase exp],Parsetree.Keep)) 
    | Texp_variant (label, eo) ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_variant,
                               [mkString exp label;
                                mkPexpOption exp (map_option (trx_e n) eo)]))      
    | Texp_record (del, eo) ->
        let lids = get_record_lids exp.exp_type exp.exp_env in
        let idel = List.map (fun (d,e) -> (List.nth lids d.lbl_pos, d, e)) del in
(* Walid: why "mkPexpTuple exp" instead of "mkPexpTuple e" *)
        let mklidexp (lid,d,e) =
          mkPexpTuple exp 
            [quote_longident exp lid;
             trx_e n e]
        in let iel = List.map mklidexp idel
        in mkParseTree_ext (Some exp) exp 
          (texp_construct_keep(Lazy.force constr_pexp_record,
                               [mkPexpList exp iel;
                                mkPexpOption exp (map_option (trx_e n) eo)]))
    | Texp_field (e,ld) ->
        let lids = get_record_lids e.exp_type e.exp_env in
        let lid = List.nth lids ld.lbl_pos in
        mkParseTree_ext (Some exp) exp
          (texp_construct_keep(Lazy.force constr_pexp_field,
                               [trx_e n e;
                                quote_longident exp lid]))

    | Texp_setfield (e1,ld,e2) ->
        let lids = get_record_lids e1.exp_type e1.exp_env in
        let lid = List.nth lids ld.lbl_pos in
        mkParseTree_ext (Some exp) exp
          (texp_construct_keep(Lazy.force constr_pexp_setfield,
                               [trx_e n e1;
                                quote_longident exp lid;
                                trx_e n e2]))
    | Texp_array el ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_array,
                               [mkPexpList exp (List.map (trx_e n) el)]))
    | Texp_ifthenelse (e1,e2,eo) ->
        mkParseTree  exp
          (texp_construct_keep(Lazy.force constr_pexp_ifthenelse,
                               [trx_e n e1;
                                trx_e n e2;
                                mkPexpOption exp (map_option (trx_e n) eo)]))
    | Texp_sequence (e1,e2) ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_sequence,
                               [trx_e n e1;
                                trx_e n e2]))
    | Texp_while (e1,e2) ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_while,
                               [trx_e n e1;
                                trx_e n e2]))
    | Texp_for (id,e1,e2,df,e3) ->
        let gensymexp id =  (* (gensym "x") *)
          mkExp exp
            type_longident_t
            (Texp_apply
               (trx_gensymlongident exp,
                [(Some (quote_ident exp (Path.Pident id)),
                  Required)]))
        and idpat id =
          {pat_desc = Tpat_var id;
           pat_loc = exp.exp_loc;
           pat_type = Lazy.force type_longident_t;
           pat_env = exp.exp_env}
        and idexp id =
          mkExp exp
            type_longident_t
            (Texp_ident (Path.Pident id,
                         {val_type = Lazy.force type_longident_t;
                          val_level = [];
                          val_kind = Val_reg}))
        in let strexp id =
          mkExp exp
            type_string
            (Texp_apply (trx_longidenttostring exp, [(Some (idexp id),
                                                      Required)]))
        in let transfor =
          mkParseTree exp
            (texp_construct_keep(Lazy.force constr_pexp_for, 
                                 [strexp id;
                                  trx_e n e1;
                                  trx_e n e2; 
                                  quote_direction_flag df exp;
                                  trx_e n e3;]))
        in mkExp exp
          type_parsetree_expression
          (Texp_let
             (Nonrecursive,
              [(idpat id, gensymexp id)], 
              transfor))

    | Texp_when (e1,e2) ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_when,
            [trx_e n e1;
             trx_e n e2]))
    | Texp_send (e,m) ->
        let s = match m with
        |  Tmeth_name s -> s
        |  Tmeth_val i -> Ident.name i in
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_send,
                               [trx_e n e;
                                mkString exp s]))
    | Texp_new (p,cd) ->
        mkParseTree_ext (Some exp) exp
          (texp_construct_keep(Lazy.force constr_pexp_new,
                               [quote_ident exp p]))
    | Texp_instvar (p1,p2) ->
        (* instance variables are always bound at level 0 (for now)
           so this is like a csp variable *)
        call_trx_mkcsp exp None (path_to_lid p2)
    | Texp_setinstvar _ -> fatal_error ("Trx.trx_e: setinstvar should be ruled out during type checking")
    | Texp_override  _ -> fatal_error ("Trx.trx_e: override should be ruled out during type checking")
    | Texp_letmodule (id,me,e) ->
        fatal_error ("Trx.trx_e: let module inside .<...>. not implemented yet")
          (* similar to Texp_for *)
(* 
   let gensymexp id =  (* (gensym "x") *)
   mkExp exp
   type_longident_t
   (Texp_apply
   (trx_gensymlongident exp,
   [(Some (quote_ident exp (Path.Pident id)),
   Required)]))
   and idpat id =
   {pat_desc = Tpat_var id;
   pat_loc = exp.exp_loc;
   pat_type = Lazy.force type_longident_t;
   pat_env = exp.exp_env}
   and idexp id =
   mkExp exp
   type_longident_t
   (Texp_ident (Path.Pident id,
   {val_type = Lazy.force type_longident_t;
   val_level = [];
   val_kind = Val_reg}))
   in let strexp id =
   mkExp exp
   type_string
   (Texp_apply (trx_longidenttostring exp, [(Some (idexp id),
   Required)]))
   in let transletmodule =
   mkParseTree exp
   (texp_construct_keep(Lazy.force constr_pexp_letmodule, 
   [strexp id;
   quote_me n exp me;
   trx_e n e]))
   in mkExp exp
   type_parsetree_expression
   (Texp_let
   (Nonrecursive,
   [(idpat id, gensymexp id)], 
   transletmodule))
 *)
    | Texp_assert e ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_assert, 
                               [trx_e n e]))
    | Texp_assertfalse ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_assertfalse, 
                               []))
    | Texp_lazy e ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_lazy, 
                               [trx_e n e]))

    | Texp_object (id,me,e) ->
        fatal_error ("Trx.trx_e: object ... inside .<...>. not implemented yet")

    | Texp_bracket e ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_bracket, 
                               [trx_e (n+1) e]))

    | Texp_escape e ->
        if n=1 then
          trx_e (n-1) e
        else
          mkParseTree exp
            (texp_construct_keep(Lazy.force constr_pexp_escape, 
                                 [trx_e (n-1) e]))
    | Texp_run e ->
        mkParseTree exp
          (texp_construct_keep(Lazy.force constr_pexp_run, 
                               [trx_e n e]))
    | Texp_runoffshore(e, s) ->
        fatal_error ("Trx.trx_e: .!{C}/.!{F} inside .<...>. not implemented yet")
    | Texp_runoffshore_arg(e_rec,e) ->
        fatal_error ("Trx.trx_e: .!{C}/.!{F} inside .<...>. not implemented yet")
    | Texp_etag (a, e, e1, env_exp) ->
        let a' =  mkAtyp exp a in
        let e' = trx_e n e in
        mkParseTree exp 
          (texp_construct_keep(Lazy.force constr_pexp_etag,
                               [a';e']))
    | Texp_cspval (m,li) ->
        call_trx_mkcsp exp None li
  end

and trx_me me = match me.mod_desc with
| Tmod_ident i -> me
| Tmod_structure str ->
    {me with mod_desc =
     Tmod_structure (trx_structure str)}
| Tmod_functor (i,t,me1) ->
    {me with mod_desc =
     Tmod_functor (i,t, trx_me me1)}
| Tmod_apply (me1,me2,mc) ->
    {me with mod_desc =
     Tmod_apply (trx_me me1, trx_me me2, mc)}
| Tmod_constraint (me,mt,mc) ->
    {me with mod_desc =
     Tmod_constraint (trx_me me, mt, mc)}

and quote_me n exp me = match me.mod_desc with
| Tmod_structure str -> (* @@@@ *)
    mkParseModuleExpr exp
      (texp_construct_keep(Lazy.force constr_pmod_structure,
                           [quote_structure n exp str]))
| _ -> fatal_error "Trx.quote_me: case not implemented yet"

and trx_ce ce = match ce.cl_desc with
| Tclass_ident p -> ce
| Tclass_structure { cl_field = cfl; cl_meths = ms } ->
    {ce with cl_desc =
     Tclass_structure { cl_field = List.map trx_cf cfl;
                        cl_meths = ms }
   }
| Tclass_fun (p,iel,ce,pt) ->
    {ce with cl_desc =
     Tclass_fun (p,iel, trx_ce ce, pt)
   }
| Tclass_apply (ce,eool) ->
    {ce with cl_desc =
     Tclass_apply (trx_ce ce,
                   List.map (fun (eo,o) -> (map_option (fun e -> trx_e 0 e) eo, o)) eool)
   }
| Tclass_let (rf,pel,iel,ce) ->
    let pel' = List.map (fun (p,e) -> (p, trx_e 0 e)) pel in
    let iel' = List.map (fun (i,e) -> (i, trx_e 0 e)) iel in
    let ce' = trx_ce ce in
    {ce with cl_desc = 
     Tclass_let (rf,pel',iel',ce')
   }
| Tclass_constraint (ce,sl1,sl2,c) ->
    {ce with cl_desc = 
     Tclass_constraint (trx_ce ce, sl1, sl2, c)
   }

and trx_cf = function
  | Cf_inher (ce,sil1,sil2) -> Cf_inher(trx_ce ce, sil1, sil2)
  | Cf_val (s,i,e) -> Cf_val(s,i, trx_e 0 e)
  | Cf_meth (s,e) -> Cf_meth(s, trx_e 0 e)
  | Cf_let (rf,pel,iel) ->
      let pel' = List.map (fun (p,e) -> (p, trx_e 0 e)) pel in
      let iel' = List.map (fun (i,e) -> (i, trx_e 0 e)) iel
      in Cf_let(rf, pel', iel')
  | Cf_init e -> Cf_init (trx_e 0 e)
        
(* propagate trx_e 0 - to structures *)
and trx_structure_item si = match si with
  Tstr_eval e -> Tstr_eval (trx_e 0 e)
| Tstr_value (rf,pel) ->
    Tstr_value(rf, List.map (fun (p,e) -> (p, trx_e 0 e)) pel)
| Tstr_primitive (i,vd) -> si
| Tstr_type idl -> si
| Tstr_exception (i,ed) -> si
| Tstr_exn_rebind (i,p) -> si
| Tstr_module (i,me) ->
    Tstr_module (i, trx_me me)
| Tstr_modtype (i,mt) -> si
| Tstr_open p -> si
| Tstr_class l ->
    Tstr_class (List.map (fun (i,n,sl,ce) -> (i,n,sl, trx_ce ce)) l)
| Tstr_cltype idl -> si
| Tstr_include (me,il) -> Tstr_include (trx_me me, il)
| Tstr_recmodule imel ->
    let f (i,me) = (i, trx_me me)
    in Tstr_recmodule (List.map f imel)

and quote_structure_item n exp si = match si with
| Tstr_value (rf,pel) ->  (* similar to texp_let *)
    begin
      match rf with
        Recursive ->
          let idlist = List.fold_right (fun (p,e) -> boundinpattern p) pel []
          and gensymexp id =  (* (gensym "x") *)
            mkExp exp
              type_longident_t
              (Texp_apply
                 (trx_gensymlongident exp,
                  [(Some (quote_ident exp (Path.Pident id)),
                    Required)]))
          and idpat id =
            {pat_desc = Tpat_var id;
             pat_loc = exp.exp_loc;
             pat_type = Lazy.force type_longident_t;
             pat_env = exp.exp_env}
          and translet =
            mkParseStructureItem exp
              (texp_construct_keep
                 (Lazy.force constr_pstr_value, 
                  [quote_rec_flag rf exp;
                   mkPexpList exp 
                     (mkNewPEL exp
                        (List.map (map_pi2 (trx_e n)) pel))
                 ]
                 )
              )
          in let pel' = List.map (fun id -> (idpat id, gensymexp id)) idlist
          in mkExp exp
            type_parsetree_expression
            (Texp_let
               (Nonrecursive,
                pel', 
                translet))
      | _ ->
          let idlist = List.fold_right (fun (p,e) -> boundinpattern p) pel []
          and peil = let genid () = Ident.create (gensymstring "fresh")
          in List.map (fun (p,e) -> (p,e, genid())) pel
          and gensymexp id =  (* (gensym "x") *)
            mkExp exp
              type_longident_t
              (Texp_apply
                 (trx_gensymlongident exp,
                  [(Some (quote_ident exp (Path.Pident id)),
                    Required)]))
          in let idpat_t id t =
            {pat_desc = Tpat_var id;
             pat_loc = exp.exp_loc;
             pat_type = Lazy.force t;
             pat_env = exp.exp_env}
          in let idpat id = idpat_t id type_longident_t
          in let idexp e id =
            {e with exp_desc =
             (Texp_ident (Path.Pident id,
                          {val_type = e.exp_type;
                           val_level = [];
                           val_kind = Val_reg}))}
          in let pel' = List.map (fun (p,e,i) -> (p, idexp e i)) peil
          in let translet =
            mkParseStructureItem exp
              (texp_construct_keep
                 (Lazy.force constr_pstr_value, 
                  [quote_rec_flag rf exp;
                   mkPexpList exp (mkNewPEL exp pel')
                 ]
                 )
              )
          in let pel1 = List.map (fun id -> (idpat id, gensymexp id)) idlist
          in let pel2 = List.map
              (fun (p,e,i) -> (idpat_t i type_parsetree_expression,
                               trx_e n e))
              peil
          in mkExp exp
            type_parsetree_expression
            (Texp_let
               (Nonrecursive,
                List.append pel1 pel2, 
                translet))
    end
| _ -> fatal_error "Trx.quote_structure_item: case not implemented yet"

and trx_structure str =
  List.map trx_structure_item str

and quote_structure n exp str =
  mkPexpList exp (List.map (quote_structure_item n exp) str)

let trx_expression n exp = trx_e n exp

(* OXX *)
let npc x =
  Printast.inpc Format.std_formatter ((Obj.magic x) : Parsetree.expression) ;
  Format.pp_print_newline Format.std_formatter ()

let npcF formatter x =
  Printast.inpc formatter ((Obj.magic x) : Parsetree.expression) ;
  Format.pp_print_newline formatter ()


let printcode x =
  Printast.expr Format.std_formatter ((Obj.magic x) : Parsetree.expression)
(* XXO Tag Elimination **)

let suppress_warnings f =
  let state = Warnings.get_state ()
  in Warnings.parse_options false "a";
  let res = f ()
  in Warnings.set_state state; res
    
let etag atyp sexp unwrap_sexp env =
  if !Clflags.debug_messages 
  then Format.fprintf Format.std_formatter 
      "Running etag handler from trx. Unwrapped expression: \n @ %a @ \n" 
      Printast.inpc   unwrap_sexp ; 
  let t = Env.get_ident_timestamp env in
  Ident.set_current_time t;
  Ctype.init_def(Ident.current_time());
  try
    let _ = te_success := false in
    let pexp = 
      (suppress_warnings 
         (fun () -> Typecore.etag_handler sexp atyp unwrap_sexp env)) in
    (te_success := true; pexp) (* unwrap_sexp Just for test unwrap *)
  with
    Typecore.Error (_,err) -> 
      Typecore.report_error Format.std_formatter err;
      Format.pp_print_newline Format.std_formatter ();
      te_success := false; 
      raise TypeCheckingError
  | Typetexp.Error(_,err) -> (
      te_success := false;
      if !Clflags.debug_messages then (
        Format.fprintf Format.std_formatter 
          "\n\nSomething wrong!!!\n";
        Typetexp.report_error Format.std_formatter err); 
      unwrap_sexp)
