(* Source machine.ml *)
open S.Ast
open Code (* Documentation de Code *)

(* La réalisation de la machine elle-même
   est  un peu plus loin *)

(* Les valeurs de la machines sont des entiers ou des fermetures *)
type value = Int of int | Clo of code * env
and env = value list

(* Il faut aussi pouvoir stocker environnements et code sur la pile. *)
type stack_elt = Val of value | Env of env | Code of code

exception Error

(**************************************)
(* Afficheur de l'état de la machine, *)
(* bien utile pour debugger.          *)
(**************************************)
open Printf

(* Affiche au plus deux éléments d'une liste *)
let plist p chan = function
| []  -> ()
| [x] -> p chan x
| [x;y] -> fprintf chan "%a; %a" p x p y
| x::y::_ -> fprintf chan "%a; %a; ..." p x p y

let pins chan i = Code.print_instruction chan i

(* Code *)
let pcode chan c = plist pins chan c

(* Affiche une valeur *)
let rec pval chan = function
| Int i -> fprintf chan "%i" i
| Clo (c,e) as clo ->  fprintf chan "<%a * %a>" pcode c (penv_rec clo) e

(* Affiche un elt de pile *)
and  pstack_elt chan = function
| Val v -> pval chan v
| Env e -> fprintf chan "<env>[%a]" penv e
| Code c -> fprintf chan "<code>[%a]" pcode c

(* Piles et environnements *)
and pstack chan s = plist pstack_elt chan s

and penv chan e = plist pval chan e

(* Pour éviter de boucler sur les env. récursifs des fermetures *)
and penv_rec clo chan e = match e with
| [] -> ()
| x::e ->
  if x == clo then match e with
  | [] -> fprintf chan "%s" "<rec>"
  | _::_ -> fprintf chan "<rec>; %a" penv e
  else
    penv chan (x::e)

(* Afficher un état (A,S,E,C) *)
let pstate chan a s e c =
  fprintf chan "<%a, [%a], [%a], [%a]>\n"
    pval a
    pstack s
    penv e
    pcode c

let debug =
  List.exists
    (fun s -> s = "-v")
    (Array.to_list Sys.argv)

(*****************************************)
(* Machine proprement dite, cf. le cours *)
(*****************************************)

let rec run a s e c =
  if debug then begin
    pstate stderr a s e c ;
    flush stderr
  end ;
  match a,s,c with
(* Facile *)
  | _,_,Ldi i::c -> run (Int i) s e c
  | _,_,Push::c  -> run a (Val a::s) e c
(* Plus général que le cours qui ne donne que l'exemple de l'addition *)
  | Int n2,Val (Int n1)::s,IOp op::c -> (* Noter 'Val' et l'ordre n1/n2 *)
      run (Int (Op.to_fun op n1 n2)) s e c
(* Le Test sans concaténation de code.
   Cela revient à appeler une fonction sans argument,
   Cf Apply/Retour de fonction plus bas *)
  | Int 0,_,Test (c2,_)::c ->
      run a (Code c::Env e::s) e c2
  | Int _,_,Test (_,c3)::c ->
      run a (Code c::Env e::s) e c3
(* Code avec concaténation
  | Int 0,_,Test (c2,_)::c ->
      run a s e (c2@c)
  | Int _,_,Test (_,c3)::c ->
      run a s e (c3@c)
*)
(* Facile *)
  | _,_,Extend::c -> run a s (a::e) c
(* Facile, si on connaît List.nth *)
  | _,_,Search k::c -> run (List.nth e k) s e c
(* Facile, noter l'application du constructeur 'Env' *)
  | _,_,Pushenv::c -> run a (Env e::s) e c
  | _,Env e::s,Popenv::c -> run a s e c
(* Fermeture ordinaires, une bête paire code X env *)
 | _,_,Mkclos cc::c ->
      run (Clo (cc,e)) s e c
(* Fermetures récursives, il faut s'ajouter en tête de l'env *)
  | _,_,Mkclosrec cc::c ->
      let rec clos = Clo (cc,clos::e) in
      run clos s e c
(* Pas facile, voir le cours *)
  | Clo (cc,ce),Val v::s,Apply::c ->
      run a (Code c::Env e::s) (v::ce) cc
(* Retour de fonction : il y a un code et un env. sur la pile *)
  | a,(Code c::Env e::s),[] ->
      run a s e c
(* Fin le l'exécution du code : pile et code sont vides *)
  | a,[],[] -> a
(* Toutes les autres possibilités sont des erreurs à l'exécution *)
  |  _,_,_ -> raise Error

let exec env code = run (Int 0) [] env code

let print_value chan = function
  | Int i -> Printf.fprintf chan "%i" i
  | Clo _ -> output_string chan "<fun>"