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

(* $Id: optcompile.ml,v 1.17 2005/11/25 17:53:56 pasalic Exp $ *)

(* The batch compiler *)

open Misc
open Config
open Format
open Typedtree

(* Initialize the search path.
   The current directory is always searched first,
   then the directories specified with the -I option (in command-line order),
   then the standard library directory. *)

let init_path () =
  let dirs =
    if !Clflags.use_threads
    then "+threads" :: !Clflags.include_dirs
    else !Clflags.include_dirs in
  let exp_dirs =
    List.map (expand_directory Config.standard_library) dirs in
  load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
  Env.reset_cache ()

(* Return the initial environment in which compilation proceeds. *)

let initial_env () =
  Ident.reinit();
  try
    if !Clflags.nopervasives
    then Env.initial
    else Env.open_pers_signature "Pervasives" Env.initial
  with Not_found ->
    fatal_error "cannot open Pervasives.cmi"

(* Compile a .mli file *)

let interface ppf sourcefile outputprefix =
  init_path ();
  let modulename =
    String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
  Env.set_unit_name modulename;
  let inputfile = Pparse.preprocess sourcefile in
  try
    let ast =
      Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
    if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
    let sg = Typemod.transl_signature (initial_env()) ast in
    if !Clflags.print_types then
      fprintf std_formatter "%a@." Printtyp.signature
                                   (Typemod.simplify_signature sg);
    Warnings.check_fatal ();
    if not !Clflags.print_types then
      Env.save_signature sg modulename (outputprefix ^ ".cmi");
    Pparse.remove_preprocessed inputfile
  with e ->
    Pparse.remove_preprocessed_if_ast inputfile;
    raise e

(* Compile a .ml file *)

let print_if ppf flag printer arg =
  if !flag then fprintf ppf "%a@." printer arg;
  arg

let (++) x f = f x
let (+++) (x, y) f = (x, f y)

(* XXO from here *)
open Parsetree
let local_csp_arr_name = "local_csp_arr_hwrrekjhj"
let local_csp_arr_str () =
  let exp = {pexp_desc = Obj.magic ();
             pexp_loc = Location.none;
             pexp_ext = None }
  and pat = {ppat_desc = Obj.magic ();
             ppat_loc = Location.none;
             ppat_ext = None } in
  let exp1 = {exp with pexp_desc = Pexp_ident (Longident.Ldot (Longident.Lident "Marshal", "from_string"))}
  and exp2 = {exp with pexp_desc = Pexp_constant (Asttypes.Const_string "blaaaaah!")}
  and exp0 = {exp with pexp_desc = Pexp_constant (Asttypes.Const_int 0)} in
  let exp3 = {exp with pexp_desc = Pexp_apply ( exp1, [("",exp2);("",exp0)])} in
  let pat1 = {pat with ppat_desc = Ppat_var local_csp_arr_name} in
  let str1 = {pstr_desc = Pstr_value (Asttypes.Nonrecursive,[pat1,exp3]);
              pstr_loc = Location.none} in
  let pat2 = {pat with ppat_desc = Ppat_any} in
  let exp4 = {exp with pexp_desc = Pexp_ident (Longident.Lident local_csp_arr_name)} in
  let str2 = {pstr_desc = Pstr_value (Asttypes.Nonrecursive,[pat2,exp4]);
              pstr_loc = Location.none} in
  let _ = Trx.reset_csp_array ()
  in [str1;str2]

let find_local_csp_arr_texp =
  function | Tstr_value (_,[p,e]) -> e
           | _ -> assert false

let hack_csp_arr_str = function
  | Tstr_value (rf,[p,e]) ->
    Tstr_value (rf,[p,{e with exp_desc =
      begin
      match e.exp_desc with
      | Texp_apply (e,[(Some e1,o);a]) ->
        Texp_apply (e,[(Some {e1 with exp_desc =
          begin
	  match e1.exp_desc with
	  | Texp_constant (Asttypes.Const_string "blaaaaah!") ->
	      let s = Marshal.to_string !Trx.csp_array []
	      in Texp_constant (Asttypes.Const_string s)	      
	  | _ -> assert false
          end}, o);a])
      | _ -> assert false
      end}])
  | _ -> assert false

let process_str str =
  Trx.initial_native_compilation := true;
  if !Clflags.plain_ocaml then str
  else let str2 = List.hd(List.tl str)
       in Trx.local_csp_arr_texp := (find_local_csp_arr_texp str2);
       let str' = Trx.trx_structure str
       in (hack_csp_arr_str (List.hd str'))::(List.tl str')

(* XXO to here *)

let implementation ppf sourcefile outputprefix =
  init_path ();
  let modulename =
    String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
  Env.set_unit_name modulename;
  let inputfile = Pparse.preprocess sourcefile in
  let env = initial_env() in
  Compilenv.reset ?packname:!Clflags.for_package modulename;
  try
    if !Clflags.print_types then ignore(
      Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
      ++ print_if ppf Clflags.dump_parsetree Printast.implementation
      ++ Unused_var.warn ppf
      ++ Typemod.type_implementation sourcefile outputprefix modulename env)
    else begin
      Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
      ++ print_if ppf Clflags.dump_parsetree Printast.implementation
      ++ (fun str ->(if !Clflags.plain_ocaml then str else (local_csp_arr_str ()@str))) (* XXO *)
      ++ Unused_var.warn ppf
      ++ Typemod.type_implementation sourcefile outputprefix modulename env
      ++ (fun (str,coe) -> (process_str str, coe)) (* XXO *)
      ++ Translmod.transl_store_implementation modulename
      +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
      +++ Simplif.simplify_lambda
      +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
      ++ Asmgen.compile_implementation outputprefix ppf;
      Compilenv.save_unit_info (outputprefix ^ ".cmx");
    end;
    Warnings.check_fatal ();
    Pparse.remove_preprocessed inputfile
  with x ->
    Pparse.remove_preprocessed_if_ast inputfile;
    raise x

(* XXO the whole function *)
let plugin_count = ref 0
let execute_expression_native exp =
  init_path ();
  begin (* Update the global ident timestamp *)
    match exp.pexp_ext with
    | Some v -> let t = Env.get_ident_timestamp (Obj.magic v).exp_env
                in Ident.set_current_time t
    | None -> ()
  end;
  Ctype.init_def(Ident.current_time());
  let exp1 = { exp with pexp_desc = Pexp_ident (Longident.Ldot
     (Longident.Lident "Trx", "execute_expression_result")) } in
  let exp2 = { exp with pexp_desc = Pexp_ident (Longident.Lident ":=") } in
  let exp3 = { exp with pexp_desc = Pexp_ident (Longident.Ldot
     (Longident.Lident "Obj", "magic")) } in
  let exp4 = { exp with pexp_desc = Pexp_apply ( exp3, [("",exp)]) } in
  let exp5 = { exp with pexp_desc = Pexp_apply ( exp2,
        [("",exp1);("",exp4)]) } in
  let ppf = Format.std_formatter in
  let sourcefile = begin
	             incr plugin_count;
		     "plugin" ^ (string_of_int !plugin_count) ^ ".ml"
		   end in
  let prefixname = Misc.chop_extension_if_any sourcefile in
  let modulename = String.capitalize(Filename.basename prefixname) in
  let inputfile = Pparse.preprocess sourcefile in
  let env = initial_env() in
  Compilenv.reset modulename;
  (* Clflags.keep_asm_file := true; *)
  try
    [{ Parsetree.pstr_desc = Parsetree.Pstr_eval exp5;
       Parsetree.pstr_loc = Location.none }]
    ++ Typemod.type_implementation sourcefile prefixname modulename env
    ++ (fun (str,coe) -> (Trx.trx_structure str, coe)) (* XXO *)
    ++ Translmod.transl_store_implementation modulename
    +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
    +++ Simplif.simplify_lambda
    +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
    ++ Asmgen.compile_implementation prefixname ppf;
    Compilenv.save_unit_info (prefixname ^ ".cmx");
    Warnings.check_fatal ();
    Pparse.remove_preprocessed inputfile;
    !Trx.load_compiled_code_hook !plugin_count;
    !Trx.execute_expression_result
  with x ->
    Pparse.remove_preprocessed_if_ast inputfile;
    raise x
(* XXO up to here *)

let _ = Trx.native_mode := true                                   (* XXO *)
let _ = Trx.execute_expression_hook := execute_expression_native  (* XXO *)

let c_file name =
  if Ccomp.compile_file name <> 0 then exit 2
