open Ci
open Print
open Aintv
open Printer
open Lexervhc
open Parse_exceptions
open Parservhc

type tableau_cible = {
  tableau : typeCode;
  taille : int;
  mutable pos_instr : int;
}

let creer_tableau taille = 
  let t = Array.create taille Void in
  t.(0) <- Valeur 2;
  t.(1) <- Goto;
{
 tableau = t;
 taille = taille;
 pos_instr = 2;
}

let finaliser t =
 t.tableau.(t.pos_instr) <- Stop;
 t.tableau.(t.pos_instr + 1) <- Fin;
 t.pos_instr <- t.pos_instr + 2;
 t.tableau

let rec simplifier = function
  | CST "true" -> CST "true"
  | CST "false" -> CST "false"
  | CST c -> CST c
  | VAR nom -> VAR nom

  | ADD (a,b) -> let a',b' = simplifier a, simplifier b in
    begin 
     match a',b' with
       | CST a'', CST b'' -> CST (string_of_int (int_of_string a'' + int_of_string b''))
       | CST a'', _ when int_of_string a'' = 0 -> b'
       | _, CST b'' when int_of_string b'' = 0 -> a'
       | _ -> ADD (a', b')
    end 

  | SUB (a,b) -> let a',b' = simplifier a, simplifier b in
    begin 
     match a',b' with
       | CST a'', CST b'' -> CST (string_of_int (int_of_string a'' - int_of_string b''))
       | _, CST b'' when int_of_string b'' = 0 -> a'
       | _ -> SUB (a', b')
    end 

  | MULT (a,b) -> let a',b' = simplifier a, simplifier b in
    begin 
     match a',b' with
       | CST a'', CST b'' -> CST (string_of_int (int_of_string a'' * int_of_string b''))
(*       | CST a'', _ when int_of_string a'' = 0 -> CST "0" *)
       | CST a'', _ when int_of_string a'' = 1 -> b'
       | _, CST b'' when int_of_string b'' = 1 -> a'
(*       | _, CST b'' when int_of_string b'' = 0 -> CST "0" *)
       | _ -> MULT (a', b')
    end 

  | DIV (a,b) -> let a',b' = simplifier a, simplifier b in 
    begin 
     match a',b' with
       | _, CST b'' when int_of_string b'' = 0  -> DIV (a',b')
       | CST a'', CST b'' -> CST (string_of_int (int_of_string a'' / int_of_string b''))
(*       | CST a'', _ when int_of_string a'' = 0 -> CST "0" *)
       | _, CST b'' when int_of_string b'' = 1 -> a'
       | _ -> DIV (a', b')
    end 

  | LESS (a,b) -> let a',b' = simplifier a, simplifier b in
    begin
     match a',b' with
       | CST a'', CST b'' when int_of_string a'' < int_of_string b'' -> CST "true"
       | _ -> LESS (a',b')
    end

  | EQUAL (a,b) -> let a',b' = simplifier a, simplifier b in
    begin
     match a',b' with
       | CST a'', CST b'' when a'' = b'' -> CST "true"
       | CST "true", _ -> b'
       | _, CST "true" -> a'
       | _ -> EQUAL (a',b')
    end

  | NOT a -> let a' = simplifier a in
    begin
     match a' with
       | CST "true" -> CST "false"
       | CST "false" -> CST "true"
       | NOT b' -> b'
       | _ -> EQUAL(a', CST "false")
(*       | _ -> NOT a'  : je n'utilise plus not car il demande 9 instructions *)
    end

  | AND (a,b) -> let a',b' = simplifier a, simplifier b in
    begin
     match a',b' with
       | CST "false", _ -> CST "false"
(*       | _, CST "false" -> CST "false" *)
       | CST "true", _ -> b'
       | _ -> AND (a',b')
    end

  | IF (c, (vt,vf)) -> let c',vt',vf' = simplifier c, simplifier vt, simplifier vf in
    begin
      match c' with
        | CST "true" -> vt'
        | CST "false" -> vf'
        | _ -> IF (c', (vt', vf'))
    end

  | CALL (nom, args) -> CALL (nom, List.map simplifier args)

  | EXPRSEQ (e1, e2) -> EXPRSEQ ( simplifier e1, simplifier e2 )

  | RANDOM arg -> RANDOM ( simplifier arg )

  | OUTPUT arg -> OUTPUT ( simplifier arg )

  | INPUT -> INPUT

let rec prod_expr t fonct arg  = 

 function

  | CST "true" -> 
    t.tableau.(t.pos_instr) <- EmpilerSuiv;
    t.tableau.(t.pos_instr + 1) <- Valeur 1;
    t.pos_instr <- t.pos_instr + 2

  | CST "false" ->
    t.tableau.(t.pos_instr) <- EmpilerSuiv;
    t.tableau.(t.pos_instr + 1) <- Valeur 0;
    t.pos_instr <- t.pos_instr + 2
   
  | CST c ->
    t.tableau.(t.pos_instr) <- EmpilerSuiv;
    t.tableau.(t.pos_instr + 1) <- Valeur (int_of_string c);
    t.pos_instr <- t.pos_instr + 2

  | VAR nom -> let pos_var = List.assoc nom arg in
               t.tableau.(t.pos_instr) <- EmpilerLD;
               t.tableau.(t.pos_instr + 1) <- EmpilerSuiv;
               t.tableau.(t.pos_instr + 2) <- Valeur (3 + pos_var);
               t.tableau.(t.pos_instr + 3) <- Add;
               t.tableau.(t.pos_instr + 4) <- Charger;
               t.pos_instr <- t.pos_instr + 5

  | ADD (a,b) -> prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Add;
               t.pos_instr <- t.pos_instr + 1

  | SUB (a,b) -> prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Sub;
               t.pos_instr <- t.pos_instr + 1

  | MULT (a,b) -> prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Mult;
               t.pos_instr <- t.pos_instr + 1

  | DIV (a,b) -> prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Div;
               t.pos_instr <- t.pos_instr + 1

  | LESS (a,b) -> prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Ifless;
               t.pos_instr <- t.pos_instr + 1

  | EQUAL (a,b) ->  prod_expr t fonct arg a; prod_expr t fonct arg b; 
               t.tableau.(t.pos_instr) <- Ifeq;
               t.pos_instr <- t.pos_instr + 1

  | NOT a -> (* non utilisé *) prod_expr t fonct arg a;
      t.tableau.(t.pos_instr) <- EmpilerSuiv;
      t.tableau.(t.pos_instr + 1) <- Valeur (t.pos_instr + 8);
      t.tableau.(t.pos_instr + 2) <- BrZero;
      t.tableau.(t.pos_instr + 3) <- EmpilerSuiv;
      t.tableau.(t.pos_instr + 4) <- Valeur 0;
      t.tableau.(t.pos_instr + 5) <- EmpilerSuiv;
      t.tableau.(t.pos_instr + 6) <- Valeur (t.pos_instr + 10);
      t.tableau.(t.pos_instr + 7) <- Goto;
      t.tableau.(t.pos_instr + 8) <- EmpilerSuiv;
      t.tableau.(t.pos_instr + 9) <- Valeur 1;
      t.pos_instr <- t.pos_instr + 10
  
  | AND ( EQUAL (CST "0", a'), b ) -> prod_expr t fonct arg a';
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 1) <- Valeur (p0 + 8);
      t.tableau.(p0 + 2) <- BrZero;
      t.tableau.(p0 + 3) <- EmpilerSuiv;
      t.tableau.(p0 + 4) <- Valeur 0;
      t.tableau.(p0 + 5) <- EmpilerSuiv;
      t.tableau.(p0 + 7) <- Goto;
      t.pos_instr <- p0 + 8;
      prod_expr t fonct arg b;
      t.tableau.(p0 + 6) <- Valeur t.pos_instr

  | AND ( EQUAL (a', CST "0"), b ) -> prod_expr t fonct arg a';
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 1) <- Valeur (p0 + 8);
      t.tableau.(p0 + 2) <- BrZero;
      t.tableau.(p0 + 3) <- EmpilerSuiv;
      t.tableau.(p0 + 4) <- Valeur 0;
      t.tableau.(p0 + 5) <- EmpilerSuiv;
      t.tableau.(p0 + 7) <- Goto;
      t.pos_instr <- p0 + 8;
      prod_expr t fonct arg b;
      t.tableau.(p0 + 6) <- Valeur t.pos_instr

  | AND  (a,b) -> prod_expr t fonct arg a;
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 2) <- BrZero;
      t.pos_instr <- p0 + 3;
      prod_expr t fonct arg b;
      let p1 = t.pos_instr in
      t.tableau.(p1) <- EmpilerSuiv;
      t.tableau.(p1 + 1) <- Valeur (p1 + 5);
      t.tableau.(p1 + 2) <- Goto;
      t.tableau.(p1 + 3) <- EmpilerSuiv;
      t.tableau.(p1 + 4) <- Valeur 0;
      t.pos_instr <- p1 + 5;
      t.tableau.(p0 + 1) <- Valeur p1
      
  | IF ( EQUAL (CST "0", c' ), (vt,vf)) -> prod_expr t fonct arg c';
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 2) <- BrZero;
      t.pos_instr <- p0 + 3;
      prod_expr t fonct arg vf;
      let p1 = t.pos_instr in
      t.tableau.(p1) <- EmpilerSuiv;
      t.tableau.(p1 + 2) <- Goto;
      t.pos_instr <- p1 + 3;
      prod_expr t fonct arg vt;
      let p2 = t.pos_instr in
      t.tableau.(p1 + 1) <- Valeur p2;
      t.tableau.(p0 + 1) <- Valeur (p1 + 3)

  | IF ( EQUAL (c', CST "0" ), (vt,vf)) -> prod_expr t fonct arg c';
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 2) <- BrZero;
      t.pos_instr <- p0 + 3;
      prod_expr t fonct arg vf;
      let p1 = t.pos_instr in
      t.tableau.(p1) <- EmpilerSuiv;
      t.tableau.(p1 + 2) <- Goto;
      t.pos_instr <- p1 + 3;
      prod_expr t fonct arg vt;
      let p2 = t.pos_instr in
      t.tableau.(p1 + 1) <- Valeur p2;
      t.tableau.(p0 + 1) <- Valeur (p1 + 3)

  | IF( c,(vt,vf)) -> prod_expr t fonct arg c;
      let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 2) <- BrZero;
      t.pos_instr <- p0 + 3;
      prod_expr t fonct arg vt;
      let p1 = t.pos_instr in
      t.tableau.(p1) <- EmpilerSuiv;
      t.tableau.(p1 + 2) <- Goto;
      t.pos_instr <- p1 + 3;
      prod_expr t fonct arg vf;
      let p2 = t.pos_instr in
      t.tableau.(p1 + 1) <- Valeur p2;
      t.tableau.(p0 + 1) <- Valeur (p1 + 3)

 | CALL (nom, args) -> 
     let p0 = t.pos_instr in
      t.tableau.(p0) <- EmpilerSuiv;
      t.tableau.(p0 + 1) <- Valeur 0;
      t.tableau.(p0 + 2) <- EmpilerLD;
      t.tableau.(p0 + 3) <- EmpilerSuiv;
      let etiq_code = p0 + 4 in
      t.tableau.(etiq_code) <- Valeur 0;
      t.pos_instr <- p0 + 5;
      List.iter (prod_expr t fonct arg) args;
      let f_adr = List.assoc nom fonct in
      let p1 = t.pos_instr in
      t.tableau.(p1) <- EmpilerSP;
      t.tableau.(p1 + 1) <- EmpilerSuiv;
      t.tableau.(p1 + 2) <- Valeur (List.length args + 2);
      t.tableau.(p1 + 3) <- Sub;
      t.tableau.(p1 + 4) <- DepilerLD;
      t.tableau.(p1 + 5) <- EmpilerSuiv;
      t.tableau.(p1 + 6) <- Valeur (2 + f_adr);
      t.tableau.(p1 + 7) <- EmpilerCode;
      t.tableau.(p1 + 8) <- Goto;
      let etiq_retour = p1 + 9 in
      t.tableau.(etiq_retour) <- DepilerLD;
      t.pos_instr <- p1 + 10;
      t.tableau.(etiq_code) <- Valeur (etiq_retour)

 | EXPRSEQ (e1, e2) ->
      prod_expr t fonct arg e1;
      t.tableau.(t.pos_instr) <- EmpilerSP;
      t.tableau.(t.pos_instr + 1) <- EmpilerSuiv;
      t.tableau.(t.pos_instr + 2) <- Valeur 1;
      t.tableau.(t.pos_instr + 3) <- Sub;
      t.tableau.(t.pos_instr + 4) <- DepilerSP;
      t.pos_instr <- t.pos_instr + 5;
      prod_expr t fonct arg e2

 | RANDOM e1 ->
     prod_expr t fonct arg e1;
     t.tableau.(t.pos_instr) <- EmpilerRand;
     t.pos_instr <- t.pos_instr + 1

 | OUTPUT e1 ->
     prod_expr t fonct arg e1;
     t.tableau.(t.pos_instr) <- DumpSP;
     t.pos_instr <- t.pos_instr + 1

 | INPUT ->
     t.tableau.(t.pos_instr) <- EmpilerInput;
     t.pos_instr <- t.pos_instr + 1

let prod_foncts t l =
  let n = List.length l in
  t.pos_instr <- n + 2;
  let cv_param = function
    | FPVAL s -> s
    | FPNECSTAT s -> s
    | FPNECDYN s -> s
  in let fonct =
    let rec creer_fonct i = function
      | [] -> []
      | (nom, _) :: q -> ((nom, i) :: (creer_fonct (i + 1) q))
    in creer_fonct 0 l
  in let prod_f0 (nom, (b,c)) =
    let arg =
    let rec creer_arg i = function
    | [] -> []
    | a :: q -> (cv_param a, i) :: (creer_arg (i + 1) q)
    in creer_arg 0 b;
    in
   t.tableau.(2 + List.assoc nom fonct) <- Valeur t.pos_instr;
   prod_expr t fonct arg c;
   t.tableau.(t.pos_instr) <- EmpilerLD;
   t.tableau.(t.pos_instr + 1) <- Ranger;
   t.tableau.(t.pos_instr + 2) <- EmpilerLD;
   t.tableau.(t.pos_instr + 3) <- EmpilerSuiv;
   t.tableau.(t.pos_instr + 4) <- Valeur 2;
   t.tableau.(t.pos_instr + 5) <- Add;
   t.tableau.(t.pos_instr + 6) <- DepilerSP;
   t.tableau.(t.pos_instr + 7) <- Goto;
   t.pos_instr <- t.pos_instr + 8
  in
  List.iter prod_f0 l;
  t.tableau.(0) <- Valeur t.pos_instr;
  t.tableau.(t.pos_instr) <- DumpCode;
  t.pos_instr <- t.pos_instr + 1;
  fonct

let taille0 = ref 1024 
let fichier_source = ref ""
let fichier_cible = ref ""
let fichier_compile = ref ""

let fichier_entree f =
 if !fichier_compile <> "" then print_string ("Un fichier compilé a déjà été spécifié. -i " ^ f ^ " est ignorée.\n") else if !fichier_source = "" then fichier_source := f else print_string ("Un -i a déjà été spécifié. -i "^ f ^ " est ignorée.\n")

let fichier_sortie f = 
 if !fichier_compile <> "" then print_string ("Un fichier compilé a déjà été spécifié. -o " ^ f ^ " est ignorée.\n") else if !fichier_cible = "" then fichier_cible := f else print_string ("Un -o a déjà été spécifié. -o "^ f ^ " est ignorée.\n")

let fichier_exe f =
 if !fichier_source <> "" || !fichier_cible <> "" then print_string ("Un fichier source ou cible a déjà été spécifié. " ^ f ^ " est ignorée.\n") else if !fichier_compile = "" then fichier_compile := f else print_string ("Un fichier compilé a déjà été spécifié. "^ f ^ " est ignorée.\n")

let chemin_programme = let s = Sys.executable_name in if s.[0] <> '/' then let d = Sys.getcwd() in if d = "/" then ("/"^ s) else d ^ "/" ^ s else s

(* let activer_simplif = ref false *)

let tableau_compile lexbuf = try

			   let (f0, e0) as p = (program token lexbuf) in
			      print_string "--" ; print_newline () ;
			      print_prog p ;
			      print_string "--" ; print_newline () ;
                              let t = creer_tableau !taille0 in
                              let f1, e1 = (* if not !activer_simplif then (f0,e0) else *) ( List.map (fun (nom, (larg, corps)) -> (nom, (larg, simplifier corps))) f0,simplifier e0) in
                              let fonct = prod_foncts t f1 in
                              prod_expr t fonct [] e1;
                              finaliser t
with
  | Type_mismatch -> 
    (print_string "Types incompatibles."; print_newline (); [| |])

  | Undefined_variable (s, i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nVariable non définie : ";
     print_string s; print_newline () ; [| |] )
  | Variable_in_body (s,i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nVariable dans le corps du programme : ";
     print_string s; print_newline (); [| |] )

  | Undefined_function (s,i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nFonction non définie : ";
     print_string s; print_newline (); [| |] )
  | Function_call_mismatch (s,i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nLe nombre de paramètres ne concorde pas : ";
     print_string s; print_newline (); [| |] )

  | Double_fundef (s,i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nDoublon définition de fonction : ";
     print_string s; print_newline (); [| |] )

  | Double_argdef (s,i) ->
    (print_string "Entrée interactive, caractère : ";
     print_int (i + 1);
     print_string "\nDoublon définition de paramètre formel : ";
     print_string s; print_newline (); [| |] )

  | Eof -> (print_string "Fin de fichier.\n" ; exit 0)

  | e -> (print_string "Autre erreur. "; print_string (Printexc.to_string e); [| |] ) 

let compiler_source () =
  let ch = open_in !fichier_source in
  let lexbuf = Lexing.from_channel ch in
  let t = tableau_compile lexbuf in
  close_in ch;
  if t = [| |] then exit 1 else ();
  let ch = open_out !fichier_cible in
  output_string ch ("#!" ^ chemin_programme ^ "\n");
  output_value ch t;
  close_out ch;
  ignore (Sys.command ( "chmod u+x " ^ !fichier_cible ))

let executer_compile () =
  let ch = open_in !fichier_compile in
  ignore (input_line ch);
  let t : typeCode = input_value ch in
  close_in ch;
  executer t

let boucle_interactive _ =
 while true do
 let lexbuf = (print_string ">"; flush stdout; Lexing.from_channel stdin) in
 let t = tableau_compile lexbuf in
 if Array.length t > 0 then executer t
 done

let run () =  Random.self_init (); print_string "CAMLote 1.0\n"; print_newline ();

if Array.length Sys.argv = 1 then boucle_interactive () else
Arg.parse [
(* "-s", Arg.Unit (fun _ -> activer_simplif := true), "Simplifier les expressions" ; *)
"-c", Arg.Int (fun i -> taille0 := i), ": taille du tableau de code";
"--codesize", Arg.Int (fun i -> taille0 := i), ": taille du tableau de code";
"-s", Arg.Int (fun i -> ref_taillepile := i), ": taille de la pile d'exécution";
"--stacksize", Arg.Int (fun i -> ref_taillepile := i), ": taille de la pile d'exécution";
"-t", Arg.Unit traceExe, ": activer la trace à l'exécution";
"--trace", Arg.Unit traceExe, ": trace à l'exécution";
"-u", Arg.Unit unTraceExe, ": désactiver la trace à l'exécution";
"--untrace", Arg.Unit unTraceExe, ": désactiver la trace à l'exécution";
"-o", Arg.String fichier_sortie, ": nom du fichier compilé cible";
"--output", Arg.String fichier_sortie, ": nom du fichier compilé cible";
"-i", Arg.String fichier_entree, ": nom du fichier source";
"--input", Arg.String fichier_entree, ": nom du fichier source";
] fichier_exe ("Usage :

" ^ Sys.executable_name ^ " [options] -o cible -i source : compile un fichier source
options possibles : -c -s

" ^ Sys.executable_name ^ " [options] [ -- ] fichier-compile : exécute un fichier compilé
options possibles : -c -s -t -u
");
if !fichier_compile = "" then 
if !fichier_source = "" || !fichier_cible = "" then
begin
 print_string "Fichier source (option -o) ou cible (option -i) requis.
Tapez ";
print_string Sys.executable_name;
print_string " --help pour plus d'informations.
";
end else compiler_source ()
else executer_compile ()

;;

run ();;