(***********************************************************************)
(*                                                                     *)
(*                             Efuns                                   *)
(*                                                                     *)
(*       Fabrice Le Fessant, projet Para/SOR, INRIA Rocquencourt       *)
(*                                                                     *)
(*  Copyright 1999 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

module My_Obj = struct  
    type t = A of int | B of float | C of string
    
    external repr : 'a -> t = "%identity"
    external obj : t -> 'a = "%identity"
    external magic : 'a -> 'b = "%identity"
    external is_block : t -> bool = "obj_is_block"
    external tag : t -> int = "obj_tag"
    external size : t -> int = "%obj_size"
    external field : t -> int -> t = "%obj_field"
    external set_field : t -> int -> t -> unit = "%obj_set_field"
    external new_block : int -> int -> t = "obj_block"
    external dup : t -> t = "obj_dup"
    external truncate : t -> int -> unit = "obj_truncate"
  end

open My_Obj

let not_implemented prim_name =
  fun _ ->
    failwith ("Primitive not implemented "^prim_name)
    
  module Externals = struct  

external alloc_dummy : int -> 'a = "alloc_dummy"
external update_dummy : 'a -> 'b -> 'c = "update_dummy"
external make_vect: int -> 'a -> 'a array = "make_vect"
external make_vect: int -> 'a -> 'a array = "make_vect"
external md5_chan: in_channel -> int -> t = "md5_chan"
external gc_stat: unit -> t = "gc_stat"
external gc_get: unit -> t = "gc_get"
external gc_set: t -> unit = "gc_set"
external gc_minor: unit -> unit = "gc_minor"
external gc_major: unit -> unit = "gc_major"
external gc_full_major: unit -> unit = "gc_full_major"
external gc_compaction: unit -> unit = "gc_compaction";;
external hash_univ_param: int -> int -> 'a -> int = "hash_univ_param" "noalloc"
external lex_engine: t -> int -> t -> int = "lex_engine"
external input_value: in_channel -> 'a = "input_value"
external obj_is_block: t -> bool = "obj_is_block"
external obj_tag: t -> int = "obj_tag"
external obj_block: int -> int -> t = "obj_block"
external obj_dup: t -> t = "obj_dup"
external obj_truncate: t -> int -> unit = "obj_truncate"
external compare: 'a -> 'a -> int = "compare" "noalloc"
external power_float: float -> float -> float = "power_float" "pow" "float"
external sqrt_float: float -> float = "sqrt_float" "sqrt" "float"
external exp_float: float -> float = "exp_float" "exp" "float"
external log_float: float -> float = "log_float" "log" "float"
external log10_float: float -> float = "log10_float" "log10" "float"
external cos_float: float -> float = "cos_float" "cos" "float"
external sin_float: float -> float = "sin_float" "sin" "float"
external tan_float: float -> float = "tan_float" "tan" "float"
external acos_float: float -> float = "acos_float" "acos" "float"
external asin_float: float -> float = "asin_float" "asin" "float"
external atan_float: float -> float = "atan_float" "atan" "float"
external atan2_float: float -> float -> float = "atan2_float" "atan2" "float"
external cosh_float: float -> float = "cosh_float" "cosh" "float"
external sinh_float: float -> float = "sinh_float" "sinh" "float"
external tanh_float: float -> float = "tanh_float" "tanh" "float"
external ceil_float: float -> float = "ceil_float" "ceil" "float"
external floor_float: float -> float = "floor_float" "floor" "float"
external fmod_float: float -> float -> float = "fmod_float" "fmod" "float"
external frexp_float: float -> float * int = "frexp_float"
external ldexp_float: float -> int -> float = "ldexp_float"
external modf_float: float -> float * float = "modf_float" "modf"
external int_of_string: string -> int = "int_of_string"
external float_of_string: string -> float = "float_of_string"
external create_string: int -> string = "create_string"
external sys_file_exists: string -> bool = "sys_file_exists"
external sys_remove: string -> unit = "sys_remove"
external sys_rename: string -> string -> unit = "sys_rename"
external sys_getenv: string -> string = "sys_getenv"
external sys_system_command: string -> int = "sys_system_command"
external sys_time: unit -> float = "sys_time"
external sys_chdir: string -> unit = "sys_chdir"
external sys_getcwd: unit -> string = "sys_getcwd"
external add_float : float -> float -> float = "add_float"

external setup : out_channel -> t = "terminfo_setup";;
external backup : int -> unit = "terminfo_backup";;
external standout : bool -> unit = "terminfo_standout";;
external resume : int -> unit = "terminfo_resume";;

external array_get_float : t -> float -> t = "array_get_float"
external array_set_float : t -> float -> t -> unit = "array_set_float"
external array_get : t -> int -> t = "array_get"
external array_set : t -> int -> t -> unit = "array_set"
external array_unsafe_get : t -> int -> t = "array_unsafe_get"
external array_unsafe_set : t -> int -> t -> unit = "array_unsafe_set"
external lessthan : t -> t -> bool = "lessthan"
external lessequal : t -> t -> bool = "lessequal"
external string_equal: string -> string -> bool = "string_equal"
external equal: string -> string -> bool = "equal"
external notequal: string -> string -> bool = "notequal"
external bitvect_test: string -> string -> bool = "bitvect_test"
external string_notequal: string -> string -> bool = "string_notequal"
external array_get_addr: 'a array -> int -> 'a = "array_get_addr"
external array_set_addr: 'a array -> int -> 'a -> unit = "array_set_addr"
external blit_string : string -> int -> string -> int -> int -> unit
= "blit_string" "noalloc"
external output_value : t -> 'a -> t -> unit = "output_value"
external output_value_to_string: 'a -> t -> string = "output_value_to_string"
external input_value : t -> 'a = "input_value"
external greaterthan : t -> t -> bool = "greaterthan"
external greaterequal : t -> t -> bool = "greaterequal"

external mul_float: float -> float -> float = "mul_float"
external div_float: float -> float -> float = "div_float"
external eq_float: float -> float -> bool = "eq_float"
external neq_float: float -> float -> bool = "neq_float"
external le_float: float -> float -> bool = "le_float"
external lt_float: float -> float -> bool = "lt_float"
external ge_float: float -> float -> bool = "ge_float"
external gt_float: float -> float -> bool = "gt_float"
external input_value_from_string: string -> int -> 'a = "input_value_from_string"
external marshal_data_size: string -> int -> int = "marshal_data_size"
external format_int: string -> int -> string = "format_int"
external caml_open_descriptor: int -> out_channel = "caml_open_descriptor"
external channel_descriptor: in_channel -> Unix.file_descr = "channel_descriptor"
external caml_close_channel: out_channel -> unit = "caml_close_channel"
external caml_channel_size:  out_channel -> int = "caml_channel_size"
external caml_set_binary_mode: out_channel -> bool -> unit = "caml_set_binary_mode"
external caml_flush_partial: out_channel -> bool = "caml_flush_partial"
external caml_flush: out_channel -> unit = "caml_flush"
external caml_output_char: out_channel -> char -> unit = "caml_output_char"
external caml_output_int: out_channel -> int -> unit = "caml_output_int"
external caml_output_partial: out_channel -> string -> int -> int -> int = "caml_output_partial"
external caml_output:  out_channel -> string -> int -> int -> unit = "caml_output"
external caml_seek_out: out_channel -> int -> unit = "caml_seek_out"
external caml_pos_out: out_channel -> int = "caml_pos_out"
external caml_input_char: in_channel -> char = "caml_input_char"
external caml_input_int: in_channel -> int = "caml_input_int"
external caml_input: in_channel -> string -> int -> int -> int = "caml_input"
external caml_seek_in: in_channel -> int -> unit = "caml_seek_in"
external caml_pos_in: in_channel -> int = "caml_pos_in"
external caml_input_scan_line: in_channel -> int = "caml_input_scan_line"
external md5_string: string -> int -> int -> t = "md5_string"
let get_current_environment () = not_implemented "get_current_environment"
external parse_engine: Parsing.parse_tables -> Parsing.parser_env -> 'a -> Obj.t -> 'b = "parse_engine"
external install_signal_handler: int -> Sys.signal_behavior -> Sys.signal_behavior = "install_signal_handler"
external fill_string: string -> int -> int -> char -> unit = "fill_string"
external is_printable: char -> bool = "is_printable"
external sys_exit: int -> 'a = "sys_exit"
external sys_open: string -> open_flag list -> int -> int = "sys_open"
external sys_close: int -> unit = "sys_close"
external sys_get_argv: unit -> string array = "sys_get_argv"
external sys_get_config: unit -> string * int = "sys_get_config"
external register_named_value: string -> Obj.t -> unit = "register_named_value"
external weak_create: int -> 'a Weak.t = "weak_create"
external weak_set: 'a Weak.t -> int -> 'a option -> unit = "weak_set";;
external weak_get: 'a Weak.t -> int -> 'a option = "weak_get"
external weak_check: 'a Weak.t -> int -> bool = "weak_check"
external array_unsafe_get_float: float array -> int -> float = "array_unsafe_get_float"
external array_unsafe_set_addr: 'a array -> int -> 'a -> unit= "array_unsafe_set_addr"
external array_unsafe_set_float: float array -> int -> float -> unit= "array_unsafe_set_float"
external make_array: 'a array -> 'a array = "make_array"
external output_value_to_buffer: string -> int -> int -> 'a -> int list -> int = "output_value_to_buffer"
external format_float:  string -> float -> string = "format_float"
external int_of_float: float -> int = "int_of_float"
external float_of_int: int -> float = "float_of_int"
external neg_float: float -> float = "neg_float"
external abs_float: float -> float = "abs_float"
external sub_float: float -> float -> float = "sub_float"
external sys_random_seed: unit -> int = "sys_random_seed"

let caml_primitives =
  [
    "ml_string_length", repr String.length;
    "string_set", repr String.set;
    "string_get", repr String.get;
    "make_vect", repr make_vect;
    "make_vect", repr make_vect;
    "md5_chan", repr md5_chan;
    "gc_stat", repr gc_stat;
    "gc_get", repr gc_get;
    "gc_set", repr gc_set;
    "gc_minor", repr gc_minor;
    "gc_major", repr gc_major;
    "gc_full_major", repr gc_full_major;
    "gc_compaction", repr gc_compaction;
    "hash_univ_param", repr hash_univ_param;
    "lex_engine", repr lex_engine;
    "input_value", repr input_value;
    "obj_is_block", repr obj_is_block;
    "obj_tag", repr obj_tag;
    "obj_block", repr obj_block;
    "obj_dup", repr obj_dup;
    "obj_truncate", repr obj_truncate;
    "compare", repr compare;
    "power_float", repr power_float;
    "sqrt_float", repr sqrt_float;
    "exp_float", repr exp_float;
    "log_float", repr log_float;
    "log10_float", repr log10_float;
    "cos_float", repr cos_float;
    "sin_float", repr sin_float;
    "tan_float", repr tan_float;
    "acos_float", repr acos_float;
    "asin_float", repr asin_float;
    "atan_float", repr atan_float;
    "atan2_float", repr atan2_float;
    "cosh_float", repr cosh_float;
    "sinh_float", repr sinh_float;
    "tanh_float", repr tanh_float;
    "ceil_float", repr ceil_float;
    "floor_float", repr floor_float;
    "fmod_float", repr fmod_float;
    "frexp_float", repr frexp_float;
    "ldexp_float", repr ldexp_float;
    "modf_float", repr modf_float;
    "int_of_string", repr int_of_string;
    "float_of_string", repr float_of_string;
    "create_string", repr create_string;
    "sys_file_exists", repr sys_file_exists;
    "sys_remove", repr sys_remove;
    "sys_rename", repr sys_rename;
    "sys_getenv", repr sys_getenv;
    "sys_system_command", repr sys_system_command;
    "sys_time", repr sys_time;
    "sys_chdir", repr sys_chdir;
    "sys_getcwd", repr sys_getcwd;
    "string_equal", repr string_equal;
    "equal", repr equal;
    "notequal", repr notequal;
    "lessthan", repr lessthan;
    "lessequal", repr lessequal;
    "array_set", repr array_set;
    "array_get", repr array_get;
    "array_set_float", repr array_set_float;
    "array_get_float", repr array_get_float;
    "add_float", repr add_float;
    "array_unsafe_set", repr array_unsafe_set;
    "array_unsafe_get", repr array_unsafe_get;
    "blit_string", repr blit_string;
    
    "bitvect_test", repr bitvect_test;
    "string_notequal", repr string_notequal;
    "array_get_addr", repr array_get_addr;
    "array_set_addr", repr array_set_addr;
    "terminfo_setup", repr setup ;
    "terminfo_backup", repr backup ;
    "terminfo_standout", repr standout ;
    "terminfo_resume", repr resume ;
    
    "get_global_data", repr (not_implemented "get_global_data");
    "realloc_global", repr (not_implemented "realloc_global", repr );
    "static_alloc", repr (not_implemented "static_alloc");
    "static_free", repr (not_implemented "static_free");
    "static_resize", repr (not_implemented "static_resize", repr );
    "reify_bytecode", repr (not_implemented "reify_bytecode");
    "available_primitives", repr (not_implemented "available_primitives", repr );
    "invoke_traced_function", repr (not_implemented "invoke_traced_function");
    
    
    "output_value_to_string", repr output_value_to_string;
    "output_value", repr output_value;
    "input_value", repr input_value;
    
    "alloc_dummy", repr alloc_dummy;
    "update_dummy", repr update_dummy;
    "greaterthan", repr greaterthan;
    "greaterequal", repr greaterequal;
    
    "mul_float", repr mul_float;
    "div_float", repr div_float;
    "eq_float", repr eq_float;
    "neq_float", repr neq_float;
    "le_float", repr le_float;
    "lt_float", repr lt_float;
    "ge_float", repr ge_float;
    "gt_float", repr gt_float;
    "input_value_from_string", repr input_value_from_string;
    "marshal_data_size", repr marshal_data_size;
    "format_int", repr format_int;
    "caml_open_descriptor", repr caml_open_descriptor;
    "channel_descriptor", repr channel_descriptor;
    "caml_close_channel", repr caml_close_channel;
    "caml_channel_size", repr caml_channel_size;
    "caml_set_binary_mode", repr caml_set_binary_mode;
    "caml_flush_partial", repr caml_flush_partial;
    "caml_flush", repr caml_flush;
    "caml_output_char", repr caml_output_char;
    "caml_output_int", repr caml_output_int;
    "caml_output_partial", repr caml_output_partial;
    "caml_output", repr caml_output;
    "caml_seek_out", repr caml_seek_out;
    "caml_pos_out", repr caml_pos_out;
    "caml_input_char", repr caml_input_char;
    "caml_input_int", repr caml_input_int;
    "caml_input", repr caml_input;
    "caml_seek_in", repr caml_seek_in;
    "caml_pos_in", repr caml_pos_in;
    "caml_input_scan_line", repr caml_input_scan_line;
    "md5_string", repr md5_string;
    "get_current_environment", repr get_current_environment;
    "parse_engine", repr parse_engine;
    "install_signal_handler", repr install_signal_handler;
    "fill_string", repr fill_string;
    "is_printable", repr is_printable;
    "sys_exit", repr sys_exit;
    "sys_open", repr sys_open;
    "sys_close", repr sys_close;
    "sys_get_argv", repr sys_get_argv;
    "sys_get_config", repr sys_get_config;
    "register_named_value", repr register_named_value;
    "weak_create", repr weak_create;
    "weak_set", repr weak_set;
    "weak_get", repr weak_get;
    "weak_check", repr weak_check;
    "array_unsafe_get_float", repr array_unsafe_get_float;
    "array_unsafe_set_addr", repr array_unsafe_set_addr;
    "array_unsafe_set_float", repr array_unsafe_set_float;
    "make_array", repr make_array;
    "output_value_to_buffer", repr output_value_to_buffer;
    "format_float", repr format_float;
    "int_of_float", repr int_of_float;
    "float_of_int", repr float_of_int;
    "neg_float", repr neg_float;
    "abs_float", repr abs_float;
    "sub_float", repr sub_float;
    "sys_random_seed", repr sys_random_seed;
  ]

end

  (* BYTECODE MODIFIER: translate bytecode from 2.0 format to 3.0.
  For now, only add the ISINT instruction.
  *)
  
  
let translate op = 
  match op with
    129 -> 130
  | 130 -> 131
  | 131 -> 132
  | 132 -> 133
  | _ -> op
      
let isint a = (Obj.magic a) land 0 = 0
  
  
(* from utils/config.ml *)
module My_Config = struct
    let exec_magic_number = "Caml1999X004"
    and cmi_magic_number = "Caml1999I004"
    and cmo_magic_number = "Caml1999O004"
    and cma_magic_number = "Caml1999A004"
    and cmx_magic_number = "Caml1999Y006"
    and cmxa_magic_number = "Caml1999Z006"
    and ast_impl_magic_number = "Caml1999M005"
    and ast_intf_magic_number = "Caml1999N005"
  end

  
(* from typing/ident.ml *)
module My_Ident = struct
    type t = { stamp: int; name: string; mutable global: bool }
    let name i = (Obj.magic i).name
  end

(* from parsing/asttypes.mli 
module Asttypes = struct
    type constant =
      Const_int of int
    | Const_char of char
    | Const_string of string
    | Const_float of string
  end

(* from bytecomp/lambda.ml *)
module Lambda = struct
    open Asttypes
    
    type structured_constant =
      Const_base of constant
    | Const_pointer of int
    | Const_block of int * structured_constant list
    | Const_float_array of string list
  end
*)

module Dumpobj = struct
    let inputu ic =
      let b1 = input_byte ic in
      let b2 = input_byte ic in
      let b3 = input_byte ic in
      let b4 = input_byte ic in
      (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1
  end

(* Translate structured constants *)

module My_Emitcode = struct 
(* from bytecomp/emitcode.ml *)
    open Lambda
    open Asttypes
    open Emitcode
      (*
    type reloc_info =
      Reloc_literal of structured_constant    (* structured constant *)
    | Reloc_getglobal of Ident.t             (* reference to a global *)
    | Reloc_setglobal of Ident.t             (* definition of a global *)
| Reloc_primitive of string               (* C primitive number *)
  
    type compilation_unit =
      { cu_name: string;                    (* Name of compilation unit *)
        mutable cu_pos: int;                (* Absolute position in file *)
        cu_codesize: int;                   (* Size of code block *)
        cu_reloc: (reloc_info * int) list;  (* Relocation information *)
        cu_imports: (string * Digest.t) list;
                 (* Names and CRC of intfs imported *)
        cu_primitives: string list;    (* Primitives declared inside *)
        mutable cu_force_link: bool;   (* Must be linked even if unref'ed *)
        mutable cu_debug: int;         (* Position of debugging info, or 0 *)
        cu_debugsize: int }            (* Length of debugging info *)
*)    
    
    let rec transl_const = function
        Const_base(Const_int i) -> My_Obj.repr i
      | Const_base(Const_char c) -> My_Obj.repr c
      | Const_base(Const_string s) -> My_Obj.repr s
      | Const_base(Const_float f) -> My_Obj.repr(float_of_string f)
      | Const_pointer i -> My_Obj.repr i
      | Const_block(tag, fields) ->
          let block = My_Obj.new_block tag (List.length fields) in
          let pos = ref 0 in
          List.iter
            (fun c -> My_Obj.set_field block !pos (transl_const c); incr pos)
          fields;
          block
      | Const_float_array fields ->
          My_Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
          
          (*
          type library =
  { lib_units: compilation_unit list;   (* List of compilation units *)
    lib_custom: bool;                   (* Requires custom mode linking? *)
    lib_ccobjs: string list;            (* C object files needed *)
    lib_ccopts: string list }           (* Extra opts to C compiler *)
*)
  end

(* from tools/objinfo.ml *)

module Objinfo = struct
    open Emitcode
    
    let print_digest d =
      for i = 0 to String.length d - 1 do
        Printf.printf "%02x" (Char.code d.[i])
      done
    
    let print_info cu =
      print_string "  Unit name: "; print_string cu.cu_name; print_newline();
      print_string "  Interfaces imported:"; print_newline();
      List.iter
        (fun (name, digest) ->
          print_string "\t"; print_digest digest; print_string "\t";
          print_string name; print_newline())
      cu.cu_imports;
      print_string "  Uses unsafe features: ";
      begin match cu.cu_primitives with
          [] -> print_string "no"; print_newline()
        | l  -> print_string "YES"; print_newline();
            print_string "  Primitives declared in this module:";
            print_newline();
            List.iter
              (fun name -> print_string "\t"; print_string name; print_newline())
            l
      end
  end

(* from utils/misc.ml *)
module Misc = struct
    let find_in_path path name =
      if not (Filename.is_implicit name) then
        if Sys.file_exists name then name else raise Not_found
      else begin
          let rec try_dir = function
              [] -> raise Not_found
            | dir::rem ->
                let fullname = Filename.concat dir name in
                if Sys.file_exists fullname then fullname else try_dir rem
          in try_dir path
        end
        
        
  end

open Emitcode
  
let input_library_units ic =
  (input_value ic : Emitcode.compilation_unit list)
          
