(* aintv.ml, Caml Light version 0.73 *)

#open "print";;

(* impression des valeurs a l'execution *)
let echo_val = 
 fun (ECST s)  -> print_string ("Error: "^s) 
  |  (BCST b)  -> if b then
				    print_string "true"
                  else
				    print_string "false"
  |  (NCST n)  -> print_int  n;;

(* recherche de la liste de parametres formels et du corps *)
(* d'une fonction dans une liste de declarations           *)
let rec fparsbody =
  fun (f, (fj, h) :: fds) -> if f = fj then FUNDECLARED(h)
                                       else fparsbody(f, fds)
   | (f, [])              -> FUNnotDECLARED ;;

(*** interpretation of primitive functions ***)

let iadd =
 fun ((NCST n1), (NCST n2)) -> (NCST (n1 + n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "addition of non-integer values")
;;

let isub =
 fun ((NCST n1), (NCST n2)) -> (NCST (n1 - n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "subtraction of non-integer values")
;;

let imult =
 fun ((NCST n1), (NCST n2)) -> (NCST (n1 * n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "multiplication of non-integer values")
;;

let idiv =
 fun ((NCST n1), (NCST n2)) -> (NCST (n1 / n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "division of non-integer values")
;;

let iless =
 fun ((NCST n1), (NCST n2)) -> (BCST (n1 < n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "inequality of non-integer values")
;;

let iequal =
 fun ((NCST n1), (NCST n2)) -> (BCST (n1 = n2))
  | (BCST b1,BCST b2)        -> (BCST (b1 = b2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "equality of non-integer values")
;;

let inot =
 fun (BCST true)  -> (BCST false)
  |  (BCST false) -> (BCST true)
  |  (ECST s)     -> (ECST s)
  |  e            -> (ECST "negation of non-boolean values") 
;;

let iand =
 fun ((BCST b1), (BCST b2)) -> (BCST (b1 & b2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "conjunction of non-boolean values")
;;

(*** pile a l'execution ***)

(* appel de fonction : empiler la liaison de parametres b sur *)
(* l'environnement r                                          *)
let push =
 fun (b,  r) -> b :: r ;;

(* retour de fonction: depiler la liaison de parametres b de *)
(* l'environnement r                                         *) 
let pull =
 fun (b :: r, v) -> (r, v)
  |  _           -> raise (Failure "pull") ;;

(* recherche dans une liaison de parametres *)
let rec val_in_bindings =
 fun (x, (y, v) :: b) -> if x = y then (FOUND v)
                                  else (val_in_bindings (x, b))
  |  (x, [])          -> NotFOUND ;;

(* recherche dans la pile d'execution *)
let rec val_in_env =
 fun (x, (f, b) :: r) -> (match val_in_bindings (x, b) with
                               (FOUND v) -> (FOUND v)
                           |   NotFOUND  -> (val_in_env (x, r))
                         )
  |  (x, [])          -> NotFOUND ;;

(* affectation dans une liaison de parametres *)
let rec assign_in_bindings =
 fun (x, v, ((y, p) :: b))
       -> if x = y then 
            (ASSIGNED ((x, (VALUE v)) :: b))
          else
            (match assign_in_bindings (x, v, b) with
              (ASSIGNED bm)    -> (ASSIGNED ((y, p) :: bm))
            | (NotASSIGNED bm) -> (NotASSIGNED ((y, p) :: bm))
            )
 |   (x, v, [])  
       -> (NotASSIGNED []);;

(* affectation dans la pile d'execution *)
let rec assign_env =
 fun (x, v, (f, b) :: r)
       -> (match assign_in_bindings (x, v, b) with
            (ASSIGNED bm)    -> (f, bm) :: r
          | (NotASSIGNED bm) -> (f, bm) :: (assign_env (x, v, r))
          )
  |  (x, v, [])        
       -> [("main",
            [(x, (VALUE (ECST "variable affectee mais non declaree")))])];;

(*** interpretation d'un programme ***)

(* trace d'execution elementaire *)
let istracing = ref false ;;
let trace_eval () = istracing := true ;;
let untrace_eval () = istracing := false ;;

(* impression du resultat de l'evaluation *)
let echo_result re =
  match re with
    ([], v) -> echo_val v; print_string "\n"
  | _       -> print_string "\n echo_result: unexpected result \n" ;;
  
#open "print";;

(* evaluation du programme p *)
let evalprog = fun (fds, ep) ->
 let rec
  (* (bind ((fps, aps), r)) lier les parametres formels fps *)
  (* aux parametres effectifs aps dans l'environnement r.   *)
  bind = fun 
  | (((fpar :: fps), (e :: aps)), r) ->
      (match fpar with
	| FPVAL x ->
	    if !istracing then
	      (print_string ("\nbind (val) == "^x); print_newline ());
	    let (r', v') = (eval (e, r)) in
	    let (r'', b) = (bind ((fps, aps), r')) in
	    (r'', ((x, (VALUE v')) :: b))
	| FPNDYN x ->
	    if !istracing then
	      (print_string ("\nbind (ndyn) == "^x); print_newline ());
	    let (r',b) = (bind ((fps, aps), r)) in
	    (r', ((x, (NDYN e))::b))
	| FPNSTAT x ->
	    if !istracing then
	      (print_string ("\nbind (nstat) == "^x); print_newline());
	    let (r',b) = (bind ((fps, aps),r )) in
	    (r', ((x, (NSTAT (e,r)))::b)))
  |  (([], []), r)  ->  (r, [])
  |  (([], aps), r) -> raise (Failure "too many actual parameters")
  |  ((fps, []), r) -> raise (Failure "too few actual parameters")
 and
  (* eval (e, r) evalue l'expression e dans l'environnement r et *)
  (* retourne  (r', v),  ou r' est l'environnement modifie et v  *)
  (* est la valeur de e                                          *)
  eval c =
    if !istracing then
        (print_string "\neval ===> \n";
	print_expr_env c
	        );
    let reseval =
      match c with
          ((CST "true"), r)  -> (r, (BCST true))
       |  ((CST "false"), r) -> (r, (BCST false))
       |  ((CST n), r) -> (r, (try (NCST (int_of_string n)) with
                               Failure s -> (ECST "boolean or integer required")
                              ))
       |  ((VAR x), r) ->
             (match val_in_env(x, r) with
               | FOUND (VALUE v) -> (r, v)
	       | FOUND (NDYN e) ->
		   let (r',v)=eval (e,r) in
		   let r''=assign_env (x,v,r) in
		   (r'',v)
	       | FOUND (NSTAT (e,r')) ->
		   let (r'',v)=eval (e,r') in
		   let r'''=assign_env (x,v,r) in
		   (r''',v)
               | NotFOUND -> (r, (ECST ("variable " ^ x ^ " not declared")))
             )
       |  ((ADD (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iadd(v1, v2))
       |  ((SUB (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, isub(v1, v2))
       |  ((MULT (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, imult(v1, v2))
       |  ((DIV (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, idiv(v1, v2))
       |  ((LESS (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iless(v1, v2))
       |  ((EQUAL (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iequal(v1, v2))
       |  ((NOT e), r) ->
            let (rp, v) = (eval (e, r)) in
              (rp, inot(v))
       |  ((AND (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iand(v1, v2))
       | ((IF (e1, (e2, e3))), r) ->
            (match (eval (e1, r)) with
              (r1, (BCST b)) -> if b then (eval (e2, r1))
                                else (eval (e3, r1))
            | (r1, (NCST n)) -> (r1, (ECST "integer result in a test"))
            | (r1, (ECST s)) -> (r1, (ECST s))
            )
       | ((CALL (f, aps)), r) ->
            (match (fparsbody (f, fds)) with
              (FUNDECLARED (fps, bf)) -> 
                let (r', b) = (bind ((fps, aps), r)) in
                (pull (eval (bf, (push ((f, b), r'))) ) )
            | FUNnotDECLARED ->
                (r, (ECST ("function " ^ f ^ " not declared")))
            )
    in
      if !istracing then
        (print_string "\n<=== \n";
	print_reseval reseval
        );
      reseval
 in
    (echo_result (eval (ep, []))) ;;

(*let message_initial =
print_newline ();
print_string "evalprog p      : execution du programme p (syntaxe abstraite) ;";
print_newline ();
print_string "trace_eval ()   : trace d'execution elementaire ;";
print_newline ();
print_string "untrace_eval () : pas de trace (par defaut).";
print_newline ();;
*)