(* Machine abstraite *)
#open "divers";;
#open "printf";;

exception TypeMismatch;;

type AmInstr =
  Label of int   (* uniquement avant finalisation *)
| Dummy          (* uniquement avant finalisation *)
| Push
| Get of int
| GetGlobal of int
| EnvGet of int
| Drop
| MakeInt of int
| MakeStr of string
| MakeCouple
| First
| Second
| Add
| Mul
| Sub
| Div
| Or
| And
| Neg
| Not
| Call
| CallTerm of int
| MakeClosure of int*int
| MakeVect of int
| MakeConstr of int
| PushMakeCouple of int
| Update of int*int
| DropReturn of int
| Jump of int
| JumpTrue of int
| TestEq
| TestLt
| TestLtEq
| GetVect0
| SetVect0
| MakeRef
| PrintInt
| PrintStr
| TestConstr of int*int
| TestConstConstr of int*int
| Stop of int;;

type AmValue =
  AmValInt  of int
| AmValVect of AmValue vect
| AmValStr  of string;;

type AmState = {
  memo : AmInstr vect;
  stack: AmValue vect;
  mutable accu : AmValue;

  mutable sp   : int;  (* 1er emplacement libre dans la pile *)
  mutable cp   : int;
  mutable env  : AmValue vect
};;

exception AmStop of AmState*int;;


let int_of_value = function
  AmValInt n -> n
| _ -> raise TypeMismatch;;

let string_of_value = function
  AmValStr s -> s
| _ -> raise TypeMismatch;;

let vect_of_value = function
  AmValVect v -> v
| _ -> raise TypeMismatch;;

let bool_of_value v = (int_of_value v)=1;;

let couple_of_value = function
  AmValVect v -> (v.(0),v.(1))
| _ -> raise TypeMismatch;;

let closure_of_value v = match couple_of_value v with
  AmValInt adr, AmValVect env -> (adr,env)
| AmValInt adr, AmValInt 0 -> (adr,[||])
| _ -> raise TypeMismatch;;

let amValUnit = AmValInt 0;;

let rec print_amval prof am = if prof=0 then pr "." else match am with
  AmValInt n   -> print_int n
| AmValVect v  -> print_amvect prof v 0 100
| AmValStr s   -> printf "\"%s\"" s
and
 print_amvect prof v deb fin = if prof=0 then pr "[.]" else begin
  pr "[";
  let n=(vect_length v)-1 in
  let fin=if fin>=vect_length v then vect_length v -1 else fin in
   for i=deb to fin do
     print_amval (prof-1) (v.(i));
     if i<fin then  pr " "
   done;
  pr "]";
  end
 ;;

let rec print_amstate am =
 pr "{";
 print_amval 3 am.accu;
 pr " ";
 print_amvect 3 am.stack (if am.sp>6 then am.sp-6 else 0) (am.sp-1);
 pr " env:"; print_amvect 3 am.env 0 10;
 pr "}\n";;


let print_aminstr = function
  Label n       -> printf "#Label %d" n
| Dummy         -> printf "Dummy"
| Stop n        -> printf "Stop %d" n
| Push          -> pr "Push"
| Get n         -> printf  "Get %d" n
| GetGlobal n   -> printf  "GetGlobal %d" n
| Jump n        -> printf  "Jump %d" n
| JumpTrue n    -> printf  "JumpTrue %d" n
| EnvGet n      -> printf  "EnvGet %d" n
| Drop          -> pr "Drop"
| MakeInt n     -> printf  "MakeInt %d" n
| MakeStr s     -> printf  "MakeStr %s" s
| MakeCouple    -> pr "MakeCouple"
| MakeConstr n  -> printf  "MakeConstr %d" n
| First         -> pr "First"
| Second        -> pr "Second"
| Add           -> pr "Add"
| Sub           -> pr "Sub"
| Mul           -> pr "Mul"
| Div           -> pr "Div"
| Or            -> pr "Or"
| And           -> pr "And"
| Not           -> pr "Not"
| Neg           -> pr "Neg"
| Call          -> pr "Call"
| CallTerm n    -> printf "CallTerm %d" n
| MakeClosure(nb,adr)-> printf "Clos (%d,%d)" nb adr
| MakeVect n    -> printf "MakeVect %d" n
| Update (i,k)  -> printf "Update (%d,%d)" i k
| PushMakeCouple n-> printf "PMC %d" n
| DropReturn n  -> printf  "DropReturn %d" n
| TestEq        -> pr "TestEq"
| TestLt        -> pr "TestLt"
| TestLtEq      -> pr "TestLtEq"
| GetVect0      -> pr "GetVect0"
| SetVect0      -> pr "SetVect0"
| MakeRef       -> pr "MakeRef"
| PrintInt      -> pr "PrintInt"
| PrintStr      -> pr "PrintStr"
| TestConstr (n,j) -> printf "TestConstr (%d,%d)" n j
| TestConstConstr (n,j) -> printf "TestConstConstr (%d,%d)" n j
;;

let rec equalval = fun
  (AmValInt x)  (AmValInt y) -> x=y
| _ _ -> false;;

let boolval b = AmValInt (int_of_bool b);;

let rec runam am =
begin
  let op2    p = am.sp<-am.sp-1; am.accu<-p am.accu am.stack.(am.sp) in
  let op2int p = op2 (fun accu par -> p (int_of_value accu) (int_of_value par)) in
  let test2 p = op2 (fun accu par  -> boolval (p accu par)) in
  let test2int p = op2int (fun accu par -> boolval (p accu par))  in
  let inst=am.memo.(am.cp) in
  let docall () =
        let (adr,nenv)=closure_of_value am.accu in
        am.cp<-adr;
        am.env<-nenv
  in
  let domakevect n =
        am.sp<-am.sp-n;
        let v=make_vect n amValUnit in
        for i=0 to (n-1) do v.(i)<-am.stack.(am.sp+i) done;
        AmValVect v
  in
(*  printf "%3d  " am.cp; print_aminstr inst; pr "\t\t\t"; print_amstate am; *)
(*  printf "cp:%d accu:" am.cp; print_amval am.accu; pr "\n"; *)
  am.cp<-am.cp+1;
  match inst with
  Stop n        -> (*pr "stop:"; print_amval 200 am.accu; pr "\n";*)
    raise (AmStop (am,n))
| Jump n        -> am.cp<-n;
| JumpTrue n    -> if bool_of_value am.accu then am.cp<-n;
| Push          -> am.stack.(am.sp)<-am.accu; am.sp<-am.sp+1
| Get n         -> am.accu<-am.stack.(am.sp-n)
| GetGlobal n   -> am.accu<-am.stack.(n)
| EnvGet n      -> am.accu<-am.env.(n)
| Drop          -> am.sp<-am.sp-1
| MakeInt n     -> am.accu<-AmValInt n
| MakeStr s     -> am.accu<-AmValStr s
| MakeCouple    -> op2 (fun accu par ->AmValVect [|par;accu|])
| MakeConstr n  -> am.accu <- AmValVect [|AmValInt n; am.accu|]
| First         -> am.accu<-fst (couple_of_value am.accu)
| Second        -> am.accu<-snd (couple_of_value am.accu)
| Add           -> op2int (fun accu arg -> AmValInt(accu+arg))
| Mul           -> op2int (fun accu arg -> AmValInt(accu*arg))
| Sub           -> op2int (fun accu arg -> AmValInt(arg-accu))
| Div           -> op2int (fun accu arg -> AmValInt(arg/accu))
| Or            -> op2int (fun accu arg -> AmValInt(arg lor accu))
| And           -> op2int (fun accu arg -> AmValInt(arg land accu))
| Neg           -> am.accu<-AmValInt(-int_of_value am.accu)
| Not           -> am.accu<-AmValInt(1-int_of_value am.accu)
| GetVect0      -> am.accu<-(vect_of_value am.accu).(0)
| SetVect0      -> op2 (fun accu par ->(vect_of_value par).(0)<-accu; amValUnit)
| MakeRef       -> am.accu<-AmValVect [|am.accu|]
| PrintInt      -> print_int (int_of_value am.accu); pr " "; flush std_out
| PrintStr      -> print_string (string_of_value am.accu); flush std_out
| Call          ->
        am.stack.(am.sp)<-AmValInt am.cp;
        am.stack.(am.sp+1)<-AmValVect am.env;
        am.sp<-am.sp+2;
        docall ()
| CallTerm n    ->
        am.stack.(am.sp-4-n)<-am.stack.(am.sp-1);
        am.sp<-am.sp-1-n;
        docall ()
| MakeClosure (nbloc,adr) -> am.accu<-AmValVect [|AmValInt adr;domakevect nbloc|];
| MakeVect n    -> am.accu<-domakevect n
| PushMakeCouple n ->
        am.stack.(am.sp)<-AmValVect [|AmValInt n; am.accu|];
        am.sp<-am.sp+1
| Update (i,k) -> (vect_of_value am.accu).(i)<-am.stack.(am.sp-k)
| DropReturn n ->
        am.sp<-am.sp-3-n;
        am.cp<-int_of_value am.stack.(am.sp+1);
        am.env<-vect_of_value am.stack.(am.sp+2);
| TestEq        -> test2 equalval
| TestLt        -> test2int (prefix >)
| TestLtEq      -> test2int (prefix >=)
| TestConstr (n,j) -> 
    (match am.accu with
    | AmValVect v when (v.(0) = AmValInt n ) ->
      am.stack.(am.sp)<-v.(1);
      am.sp<-am.sp+1;
    | _ -> am.cp<-j
    )
| TestConstConstr (n,j) -> 
    (match am.accu with
    | AmValInt m when (m = n ) -> ()
    | _ -> am.cp<-j
    )
(*    if int_of_value ((vect_of_value am.accu).(0))=n then
    ( 
      am.stack.(am.sp)<-(vect_of_value am.accu).(1);
      am.sp<-am.sp+1;
    ) 
    else
      am.cp<-j*)
| _             -> failwith "runam"
end;
runam am;;


let init_am pgm stacksize = {
 memo   = pgm;
 stack  = make_vect stacksize amValUnit;
 accu   = amValUnit;
 sp     = 0;
 cp     = 0;
 env    = [| |]
 };;


let runpgm pgm = try runam (init_am pgm (4*8192)); 0 with AmStop (am,n) -> n;;