(***********************************************************************)
(*                                                                     *)
(*                       Objective Caml                                *)
(*                                                                     *)
(*                 L3 - Programmation fonctionnelle                    *)
(*                Baptiste Tan   -   Projet 2006-2007                  *)
(*                                                                     *)
(***********************************************************************)



(* definition du type processeur: *)

(* les registres sont des entiers *)
(* marche est un booleen qui represente l'etat du processeur *) 
(* true = en marche / false = en arret *)
(* la pile arithmetique est une liste d'entiers*)
(* la pile d'appel est un tableau d'entiers *)
(* la pile de retour est un tableau d'entiers *)

(* ############### CONVENTIONS ############### *)

(* le sommet de la pile arithmetique se situe AU DEBUT de la liste *)
(* le sommet de la pile d'appel se situe EN FIN de tableau *)
(* le sommet de la pile de retour se situe EN FIN de tableau *)

(* REMARQUE *)
(* Certaines fonctions comme app_push et ret_push sont propres aux tableaux *)
(* Cela vient du choix du type des deux piles *)
(* Ici on a choisi de reecrire les primitives pour chaque pile *)


type proc = {
mutable marche : bool;
mutable pc : int ;
mutable sp : int ;
mutable bp : int ;
mutable ari : int list ;
mutable app : int array;
mutable ret : int array } ;;

type instr_asm =
  CONST of int | ADD | SUB | MUL | DIV | EQU | NEQ
| ALLOC of int | FREE of int
| LOAD of int | STORE of int | PUSH
| JNZ | JMP of int
| CALL of int | RET
| STOP
;;


(* ############### LA  PILE ARITHMETHIQUE ############### *)

exception Pile_arithmetique_vide ;;

let ari_vide l = match l with
  []     -> true
| a::l'  -> false
;;

let ari_head l = match l with
  []     -> print_string("Erreur head! \n");raise (Pile_arithmetique_vide) 
| a::l'  -> a
;;

let ari_tail l = match l with
  []     -> print_string("Erreur tail! \n");raise (Pile_arithmetique_vide) 
| a::l'  -> l'
;;

let ari_add l = match l with
  []     -> print_string("Impossible de depiler pour l'addition! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour l'addition! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> [(a+b)]@l''
;;

let ari_sub l = match l with
  []     -> print_string("Impossible de depiler pour la soustraction! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour la soustraction! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> [(a-b)]@l''
;;

let ari_mul l = match l with
  []     -> print_string("Impossible de depiler pour la multiplication! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour la multiplication! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> [(a*b)]@l''
;;

let ari_div l = match l with
  []     -> print_string("Impossible de depiler pour la division! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour la division! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> [(a/b)]@l''
;;

let ari_equ l = match l with
  []     -> print_string("Impossible de depiler pour le test d'egalite! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour le test d'egalite! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> if(a=b) then [1]@l'' else [0]@l''
;;

let ari_neq l = match l with
  []     -> print_string("Impossible de depiler pour le test de difference! (0/2) \n");raise (Pile_arithmetique_vide) 
| a::l'  -> match l' with
		  []     -> print_string("Impossible de depiler pour le test de difference! (1/2) \n");raise (Pile_arithmetique_vide)
		| b::l'' -> if(a<>b) then [1]@l'' else [0]@l''
;;


(* ############### LA  PILE D'APPEL ############### *)

exception Argument_negatif;;
exception Pile_appel_vide ;;

let app_alloc n t = Array.append t (Array.make n 0);;

let app_free n t = 
if (n<0)
then( print_string("Impossible de depiler pour le free \n");raise (Argument_negatif) )
else if (Array.length t) < n 
then( print_string("Impossible de depiler pour le free \n"); raise (Pile_appel_vide) )
else if (Array.length t) = n
then [||]
else (Array.sub t 0 ((Array.length t)-n))
;;

let app_push n t = Array.append t [|n|];;


(* ############### LA  PILE DE RETOUR ############### *)

exception Pile_retour_vide ;;

let ret_push n t = Array.append t [|n|];;

let ret_free n t = 
if (n<0)
then( print_string("Impossible de depiler pour le free \n");raise (Argument_negatif) )
else if (Array.length t) < n 
then( print_string("Impossible de depiler pour le free \n"); raise (Pile_retour_vide) )
else if (Array.length t) = n
then [||]
else (Array.sub t 0 ((Array.length t)-n))
;;

(* ############### LE PROCESSEUR ############### *)

(* Les instructions arithmetiques *)

(* CONST *)
let const n p = 
p.ari <- ([n]@p.ari);
p.pc <- (p.pc+1)
;;

(* ADD *)
let add p = 
p.ari <- (ari_add p.ari);
p.pc <- (p.pc+1);;

(* SUB *)
let sub p = 
p.ari <- (ari_sub p.ari);
p.pc <- (p.pc+1);;

(* MUL *)
let mul p = 
p.ari <- (ari_mul p.ari);
p.pc <- (p.pc+1);;

(* DIV *)
let div p = 
p.ari <- (ari_div p.ari);
p.pc <- (p.pc+1);;

(* EQU *)
let equ p = 
p.ari <- (ari_equ p.ari);
p.pc <- (p.pc+1);;

(* NEQ *)
let neq p = 
p.ari <- (ari_neq p.ari);
p.pc <- (p.pc+1);;

(* Les instructions d'allocation et de liberation *)

(* ALLOC *)
let alloc n p = 
p.app <- (app_alloc n p.app);
p.sp <- (p.sp+n);
p.pc <- (p.pc+1);;

(* FREE *)
let free n p = 
p.app <- (app_free n p.app);
p.sp <- (p.sp-n);
p.pc <- (p.pc+1);;

(*les instructions de transfert *)

exception Erreur_load;;
exception Erreur_store;; 

(* LOAD *)
let load i p = 
if ( ((p.bp+i) < 0) or ((p.bp+i) >= (Array.length p.app)) )
then ( print_string "Emplacement de chargement errone! \n";raise (Erreur_load) )
else 
const (p.app.(p.bp+i)) p; 
p.pc <- (p.pc+1)
;;

(* STORE *)
let store i p = 
if ( ((p.bp+i) < 0) or ((p.bp+i) >= (Array.length p.app)) )
then ( print_string "Emplacement de reserve errone! \n";raise (Erreur_store) )
else if (ari_vide p.ari)
then (print_string "Impossible de depiler pour le store! \n";raise (Pile_arithmetique_vide) )
else 
p.app.((p.bp+i)) <- (ari_head p.ari);
p.ari <- (ari_tail p.ari);
p.pc <- (p.pc+1)
;;

(* PUSH *)
let push p =
if (ari_vide p.ari)
then (print_string "Impossible de depiler pour le push! \n";raise (Pile_arithmetique_vide) )
else 
p.app <- ( app_push (ari_head p.ari) p.app );
p.ari <- (ari_tail p.ari);
p.sp <- (p.sp+1);
p.pc <- (p.pc+1)
;;

(* les instructions de branchement *)

exception Erreur_jmp;;

(* JNZ *)
let jnz_aux x p =
if (x <> 0) 
then ( p.pc <- (p.pc+2);p.ari <- (ari_tail p.ari) ) 
else ( p.pc <- (p.pc+1);p.ari <- (ari_tail p.ari) )
;;

let jnz p =
if (ari_vide p.ari)
then (print_string "Impossible de depiler pour le JNZ! \n" ;raise (Pile_arithmetique_vide) )
else (jnz_aux (ari_head p.ari) p)
;;

(* JMP *)
let jmp i p =
if ( (p.pc + i) <0 ) 
then (print_string " Numero d'instruction negatif! \n" ;raise (Erreur_jmp) )
else p.pc <- (p.pc +i)
;;

(* les instructions d'appel et de retour *)

(* CALL *)
let call a p = 
p.ret <- (ret_push ((p.pc)+1) p.ret);
p.app <- (app_push (p.bp) p.app);
p.sp <- ((p.sp)+1);
p.bp <- p.sp;
p.pc <- a
;;

(* RET *)
let ret p =
p.sp <- p.bp;
p.app <- (app_free ((Array.length p.app)-(p.sp)-1) p.app);
if(p.sp<0)
then (print_string "Impossible de depiler pour le RET! \n"; raise (Pile_appel_vide))
else if ((Array.length (p.ret)) < 0)
then (print_string "Impossible de depiler pour le RET! \n"; raise (Pile_retour_vide))
else ( 
p.bp <- p.app.((p.sp));
p.sp <- ((p.sp)-1);
p.app <- (app_free 1 (p.app)); 
p.pc <- ( (p.ret).(((Array.length (p.ret)) - 1)) );
p.ret <- (ret_free 1 (p.ret)) )
;;

(* l'instruction d'arręt *)

(* STOP *)
let stop p =
p.marche <- false
;;


(* ############### LE PROGRAMME ############### *)

let proc = { marche=true; pc=0; sp=(-1); bp=(-1); ari=[]; app=[||]; ret=[||] };;

let init_proc p =
p.marche <- true;
p.pc <- 0;
p.sp <- (-1);
p.bp <- (-1);
p.ari <- [];
p.app <- [||];
p.ret <- [||]
;;


let execute instruction = match instruction with
  CONST(a)  -> const a proc
| ADD       -> add proc
| SUB       -> sub proc
| MUL       -> mul proc
| DIV       -> div proc
| EQU       -> equ proc
| NEQ       -> neq proc
| ALLOC(a)  -> alloc a proc
| FREE(a)   -> free a proc
| LOAD(a)   -> load a proc
| STORE(a)  -> store a proc
| PUSH      -> push proc
| JNZ       -> jnz proc
| JMP(a)    -> jmp a proc
| CALL(a)   -> call a proc
| RET       -> ret proc
| STOP      -> stop proc


let execute2 instruction = match instruction with
  CONST(a)  -> print_string ("on fait const "^((string_of_int) a)^" proc: \n"); const a proc
| ADD       -> print_string ("on fait add proc: \n"); add proc
| SUB       -> print_string ("on fait sub proc: \n"); sub proc
| MUL       -> print_string ("on fait mul proc: \n"); mul proc
| DIV       -> print_string ("on fait div proc: \n"); div proc
| EQU       -> print_string ("on fait equ proc: \n"); equ proc
| NEQ       -> print_string ("on fait neq proc: \n"); neq proc
| ALLOC(a)  -> print_string ("on fait alloc "^((string_of_int) a)^" proc: \n"); alloc a proc
| FREE(a)   -> print_string ("on fait free "^((string_of_int) a)^" proc: \n"); free a proc
| LOAD(a)   -> print_string ("on fait load "^((string_of_int) a)^" proc: \n"); load a proc
| STORE(a)  -> print_string ("on fait store "^((string_of_int) a)^" proc: \n"); store a proc
| PUSH      -> print_string ("on fait push proc: \n"); push proc
| JNZ       -> print_string ("on fait jnz proc: \n"); jnz proc
| JMP(a)    -> print_string ("on fait jmp "^((string_of_int) a)^" proc: \n"); jmp a proc
| CALL(a)   -> print_string ("on fait call "^((string_of_int) a)^" proc: \n"); call a proc
| RET       -> print_string ("on fait ret proc: \n"); ret proc
| STOP      -> print_string ("on fait stop proc: \n"); stop proc
;;

let execution mini_ASM = 
while (proc.marche)
do ( execute (Array.get mini_ASM (proc.pc)) )
done;
ari_head (proc.ari)
;;

(* ############### INTERFACE IMPERATIVE ############### *)

print_string "Debut du programme ! \n";;

let mini = [|CONST 4; CONST 3;ADD;CONST 8;MUL;ALLOC 5;FREE 4;CALL 9;CALL 13; CONST 5;ADD;ALLOC 2;RET;CONST 6;SUB;STOP|];;
print_string "resultat: \n";;
execution mini;;