let print_keyword =
 function
  | Extracted.Joint_printer.KwCOMMENT      -> "COMMENT"
  | Extracted.Joint_printer.KwMOVE         -> "MOVE"
  | Extracted.Joint_printer.KwPOP          -> "POP"
  | Extracted.Joint_printer.KwPUSH         -> "PUSH"
  | Extracted.Joint_printer.KwADDRESS      -> "ADDRESS"
  | Extracted.Joint_printer.KwOPACCS       -> "OPACCS"
  | Extracted.Joint_printer.KwOP1          -> "OP1"
  | Extracted.Joint_printer.KwOP2          -> "OP2"
  | Extracted.Joint_printer.KwCLEAR_CARRY  -> "CLEAR_CARRY"
  | Extracted.Joint_printer.KwSET_CARRY    -> "SET_CARRY"
  | Extracted.Joint_printer.KwLOAD         -> "LOAD"
  | Extracted.Joint_printer.KwSTORE        -> "STORE"
  | Extracted.Joint_printer.KwCOST_LABEL   -> "COST_LABEL"
  | Extracted.Joint_printer.KwCOND         -> "COND"
  | Extracted.Joint_printer.KwCALL         -> "CALL"
  | Extracted.Joint_printer.KwGOTO         -> "GOTO"
  | Extracted.Joint_printer.KwRETURN       -> "RETURN"
  | Extracted.Joint_printer.KwTAILCALL     -> "TAILCALL"
  | Extracted.Joint_printer.KwFCOND        -> "FCOND"

let print_opAccs =
 function
  | Extracted.BackEndOps.Mul -> "Mul"
  | Extracted.BackEndOps.DivuModu -> "DivModu"

let print_op1 =
 function
  | Extracted.BackEndOps.Cmpl -> "Cmpl"
  | Extracted.BackEndOps.Inc -> "Inc"
  | Extracted.BackEndOps.Rl -> "Rl"

let print_op2 =
 function
  | Extracted.BackEndOps.Add -> "Add"
  | Extracted.BackEndOps.Addc -> "Addc"
  | Extracted.BackEndOps.Sub -> "Sub"
  | Extracted.BackEndOps.And -> "And"
  | Extracted.BackEndOps.Or -> "Or"
  | Extracted.BackEndOps.Xor -> "Xor"

(* Duplicated, also in cerco.ml! *)
let string_of_pos n = string_of_int (Extracted.Glue.int_of_matitapos n)

let print_ident n = "fun_" ^ string_of_pos n

let printing_pass_independent_params =
 { Extracted.Joint_printer.print_String =
    (fun Extracted.String.EmptyString -> "EmptyString")
 ; print_keyword = print_keyword
 ; print_concat = (fun s1 s2 -> s1 ^ " " ^ s2)
 ; print_empty = ""
 ; print_ident = print_ident
 ; print_costlabel = (fun n -> "k_" ^ string_of_pos n)
 ; print_label = (fun n -> "l_" ^ string_of_pos n)
 ; print_OpAccs = print_opAccs
 ; print_Op1 = print_op1
 ; print_Op2 = print_op2
 ; print_nat = (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n))
 ; print_bitvector = (fun _ n -> string_of_int (Extracted.Glue.int_of_bitvector n))
 }

let print_byte b = string_of_int (IntelHex.int_of_vect b)

let print_argument print_arg =
 function
    Extracted.Joint.Imm b -> print_byte b
  | Extracted.Joint.Reg x -> print_arg x

let print_Register =
 function
  | Extracted.I8051.Register00     -> "Register00"
  | Extracted.I8051.Register01     -> "Register01"
  | Extracted.I8051.Register02     -> "Register02"
  | Extracted.I8051.Register03     -> "Register03"
  | Extracted.I8051.Register04     -> "Register04"
  | Extracted.I8051.Register05     -> "Register05"
  | Extracted.I8051.Register06     -> "Register06"
  | Extracted.I8051.Register07     -> "Register07"
  | Extracted.I8051.Register10     -> "Register10"
  | Extracted.I8051.Register11     -> "Register11"
  | Extracted.I8051.Register12     -> "Register12"
  | Extracted.I8051.Register13     -> "Register13"
  | Extracted.I8051.Register14     -> "Register14"
  | Extracted.I8051.Register15     -> "Register15"
  | Extracted.I8051.Register16     -> "Register16"
  | Extracted.I8051.Register17     -> "Register17"
  | Extracted.I8051.Register20     -> "Register20"
  | Extracted.I8051.Register21     -> "Register21"
  | Extracted.I8051.Register22     -> "Register22"
  | Extracted.I8051.Register23     -> "Register23"
  | Extracted.I8051.Register24     -> "Register24"
  | Extracted.I8051.Register25     -> "Register25"
  | Extracted.I8051.Register26     -> "Register26"
  | Extracted.I8051.Register27     -> "Register27"
  | Extracted.I8051.Register30     -> "Register30"
  | Extracted.I8051.Register31     -> "Register31"
  | Extracted.I8051.Register32     -> "Register32"
  | Extracted.I8051.Register33     -> "Register33"
  | Extracted.I8051.Register34     -> "Register34"
  | Extracted.I8051.Register35     -> "Register35"
  | Extracted.I8051.Register36     -> "Register36"
  | Extracted.I8051.Register37     -> "Register37"
  | Extracted.I8051.RegisterA      -> "RegisterA"
  | Extracted.I8051.RegisterB      -> "RegisterB"
  | Extracted.I8051.RegisterDPL    -> "RegisterDPL"
  | Extracted.I8051.RegisterDPH    -> "RegisterDPH"
  | Extracted.I8051.RegisterCarry  -> "RegisterCarry"

let print_registers_move =
 function
  | Extracted.Joint_LTL_LIN.From_acc (reg,_unit) ->
     print_Register reg ^ " " ^ "ACC_A"
  | Extracted.Joint_LTL_LIN.To_acc (_unit,reg) ->
     "ACC_A " ^ print_Register reg
  | Extracted.Joint_LTL_LIN.Int_to_reg (reg,byte) ->
     print_Register reg ^ " " ^ print_byte byte
  | Extracted.Joint_LTL_LIN.Int_to_acc (_unit,byte) ->
     "ACC_A " ^ print_byte byte

let print_register n = "r_" ^ string_of_pos n

let rTL_printing_params =
 { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 ; print_acc_a_reg = Obj.magic print_register
 ; print_acc_b_reg = Obj.magic print_register
 ; print_acc_a_arg = Obj.magic (print_argument print_register)
 ; print_acc_b_arg = Obj.magic (print_argument print_register)
 ; print_dpl_reg = Obj.magic print_register
 ; print_dph_reg = Obj.magic print_register
 ; print_dpl_arg = Obj.magic (print_argument print_register)
 ; print_dph_arg = Obj.magic (print_argument print_register)
 ; print_snd_arg = Obj.magic (print_argument print_register)
 ; print_pair_move = Obj.magic
    (fun {Extracted.Types.fst = reg; snd = arg} ->
      print_register reg ^ " " ^ print_argument print_register arg)
 ; print_call_args = Obj.magic
    (fun l -> String.concat " " (List.map (print_argument print_register) l))
 ; print_call_dest = Obj.magic
    (fun l -> String.concat " " (List.map print_register l))
 ; print_ext_seq =
    (fun ext ->
      match Obj.magic ext with
       Extracted.RTL.Rtl_stack_address (reg1,reg2) ->
        "Rtl_stack_address " ^ print_register reg1 ^ " " ^ print_register reg2)
 }

let print_move_dst =
 function
    Extracted.ERTL.PSD reg -> print_register reg
  | Extracted.ERTL.HDW reg -> print_Register reg

let eRTL_printing_params =
 { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 ; print_acc_a_reg = Obj.magic print_register
 ; print_acc_b_reg = Obj.magic print_register
 ; print_acc_a_arg = Obj.magic (print_argument print_register)
 ; print_acc_b_arg = Obj.magic (print_argument print_register)
 ; print_dpl_reg = Obj.magic print_register
 ; print_dph_reg = Obj.magic print_register
 ; print_dpl_arg = Obj.magic (print_argument print_register)
 ; print_dph_arg = Obj.magic (print_argument print_register)
 ; print_snd_arg = Obj.magic (print_argument print_register)
 ; print_pair_move = Obj.magic
    (fun {Extracted.Types.fst = dst; snd = src} ->
      print_move_dst dst ^ " " ^ print_argument print_move_dst src )
 ; print_call_args =
    Obj.magic (fun n -> string_of_int (Extracted.Glue.int_of_matitanat n))
 ; print_call_dest = (fun _ -> "")
 ; print_ext_seq =
     (fun ext -> match Obj.magic ext with
     | Extracted.ERTL.Ertl_new_frame -> "NEW FRAME"
     | Extracted.ERTL.Ertl_del_frame -> "DEL FRAME"
     | Extracted.ERTL.Ertl_frame_size r -> "FRAMESIZE " ^ print_register r)
 }

let joint_LTL_LIN_printing_params =
 { Extracted.Joint_printer.print_pass_ind = printing_pass_independent_params
 ; print_acc_a_reg = (fun _ -> "ACC_A")
 ; print_acc_b_reg = (fun _ -> "ACC_B")
 ; print_acc_a_arg = (fun _ -> "ACC_A")
 ; print_acc_b_arg = (fun _ -> "ACC_B")
 ; print_dpl_reg = (fun _ -> "DPL")
 ; print_dph_reg = (fun _ -> "DPH")
 ; print_dpl_arg = (fun _ -> "DPL")
 ; print_dph_arg = (fun _ -> "DPH")
 ; print_snd_arg = (fun hdw_arg -> print_argument print_Register (Obj.magic hdw_arg))
 ; print_pair_move = Obj.magic print_registers_move
 ; print_call_args =
    (fun n ->string_of_int (Extracted.Glue.int_of_matitanat (Obj.magic n)))
 ; print_call_dest = (fun _ -> "")
 ; print_ext_seq =
     (fun ext -> match Obj.magic ext with
     | Extracted.Joint_LTL_LIN.SAVE_CARRY -> "SAVE_CARRY"
     | Extracted.Joint_LTL_LIN.RESTORE_CARRY -> "RESTORE_CARRY"
     |  Extracted.Joint_LTL_LIN.HIGH_ADDRESS l ->
       Format.sprintf "HIGH_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l)
     |  Extracted.Joint_LTL_LIN.LOW_ADDRESS l ->
       Format.sprintf "LOW_ADDRESS l_%d" (Extracted.Glue.int_of_matitapos l))
 }

let rec list_of_matitalist =
 function
    Extracted.List.Nil -> []
  | Extracted.List.Cons (hd,tl) -> hd :: list_of_matitalist tl

let print_graph l =
 let l = list_of_matitalist l in
  String.concat "\n\n"
   (List.map
     (fun {Extracted.Types.fst=ident; snd=commands} ->
       let commands = list_of_matitalist commands in
       print_ident ident ^ ":\n" ^
       String.concat "\n" (List.rev commands)
     )
    l)

let extension_of_pass =
 function
 | Extracted.Compiler.Clight_pass                -> "clight"
 | Extracted.Compiler.Clight_switch_removed_pass -> "clight_sr"
 | Extracted.Compiler.Clight_label_pass          -> "clight_l"
 | Extracted.Compiler.Clight_simplified_pass     -> "clight_s"
 | Extracted.Compiler.Cminor_pass                -> "cminor"
 | Extracted.Compiler.Rtlabs_pass                -> "rtlabs"
 | Extracted.Compiler.Rtl_separate_pass          -> "rtl"
 | Extracted.Compiler.Rtl_uniq_pass              -> "rtl_u"
 | Extracted.Compiler.Ertl_pass                  -> "ertl"
 | Extracted.Compiler.Ltl_pass                   -> "ltl"
 | Extracted.Compiler.Lin_pass                   -> "lin"
 | Extracted.Compiler.Assembly_pass              -> "assembly"
 | Extracted.Compiler.Object_code_pass           -> "hex"
;;


let print_program sourcename pass (program : Extracted.Preamble.__) =
 let beprint pcs =
  print_graph (pcs (Extracted.Types.fst (Obj.magic program))) in
 let lines =
  match pass with
   | Extracted.Compiler.Clight_pass
   | Extracted.Compiler.Clight_switch_removed_pass
   | Extracted.Compiler.Clight_label_pass
   | Extracted.Compiler.Clight_simplified_pass ->
      ClightPrinter.print_program ClightPrinter.Cost_plain (Obj.magic program)
   | Extracted.Compiler.Rtlabs_pass ->
      RTLabsPrinter.print_program (Obj.magic program)
   | Extracted.Compiler.Rtl_separate_pass ->
      beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params)
   | Extracted.Compiler.Rtl_uniq_pass ->
      beprint (Extracted.RTL_printer.print_RTL_program rTL_printing_params)
   | Extracted.Compiler.Ertl_pass ->
      beprint (Extracted.ERTL_printer.print_ERTL_program eRTL_printing_params)
   | Extracted.Compiler.Ltl_pass ->
      beprint
       (Extracted.LTL_printer.print_LTL_program joint_LTL_LIN_printing_params)
   | Extracted.Compiler.Lin_pass ->
      beprint
       (Extracted.LIN_printer.print_LIN_program joint_LTL_LIN_printing_params)
   | Extracted.Compiler.Object_code_pass ->
      ASMPrinter.print_program (Obj.magic program)
   | _ -> ""
 in
  let filename =
   Filename.chop_extension sourcename ^ "." ^ extension_of_pass pass in
  let och = open_out filename in
  output_string och lines;
  close_out och