(* uC, a fraction of the C language * sestoft@dina.kvl.dk * 2001-03-18

   A value is an integer; it may represent an integer or a pointer,
   where a pointer is just an address in the store (of a variable or
   pointer or the base address of an array).  The environment maps a
   variable to an address (location), and the store maps a location to
   an integer.  This freely permits pointer arithmetics, as in real C.
   Expressions can have side effects.  A function takes a list of
   typed arguments and may optionally return a result.

   For now, arrays can be one-dimensional only.  For simplicity, we
   represent an array as a variable which holds the address of the
   first array element.  This is consistent with the way array-type
   parameters are handled in C, but not with the way array-type
   variables are handled.

   The store behaves as a stack, so all data are stack allocated:
   variables, function parameters and arrays.  

   The return statement is not implemented (for simplicity), so all
   functions should be void.  But there is as yet no typecheck, so be
   careful.
 *)

app load ["Absyn", "Env", "Sto"];

open Absyn Env Sto;

fun int2bool 0 = false
  | int2bool _ = true

fun bool2int false = 0
  | bool2int true  = 1

(* ------------------------------------------------------------------- *)

(* The variable environment keeps track of the next unused store location *)

type venv = (string, int) env * int

(* The function environment maps a function name to parameter list and body *)

type fenv = (string, paramdec list * stmt) env

(* The store maps adresses to values (ints) *)

type sto  = int Sto.sto                 

(* Bind variable to location in env and allocate in store *)

fun allocate (typ, x) (env0, nextloc) sto0 = 
    let fun initsto first len sto = 
            List.foldl (fn (loc, sto) => setsto sto loc ~1) sto
                       (List.tabulate(len, fn i => i + first))
        val (nextloc1, v, sto1) =
            case typ of 
                TypA (t, SOME (Cst (CstI i))) => 
                    (nextloc+i, nextloc, initsto nextloc i sto0)
              | TypA (t, _) => raise Fail "allocate: dynamic array size"
              | _ => (nextloc, ~1, sto0)
    in 
        bindvar x v (env0, nextloc1) sto1
    end;

(* ------------------------------------------------------------------- *)

(* Global environments for variables and functions *)

local 
    val glovenv = ref Env.empty : (string, int) env ref
    val glofenv = ref Env.empty : fenv ref
in
    fun mkvenv (topdecs : topdec list) : int * sto = 
        let fun addv []                      env sto = (env, sto)
              | addv (Vardec typx :: tdr) env sto =
                let val (env1, sto1) = allocate typx env sto
                in addv tdr env1 sto1 end
              | addv (Fundec _    :: tdr) env sto = addv tdr env sto
            val sto0 = Sto.empty ()
            val ((venv, nextloc), sto1) = addv topdecs (Env.empty, 0) sto0
        in 
            glovenv := venv;
            (nextloc, sto1)
        end;

    fun mkfenv (topdecs : topdec list) : unit = 
        let fun addf []                              fenv = fenv
              | addf (Fundec(_, f, xs, body) :: tdr) fenv = 
                let val env1 = bind1 fenv (f, (xs, body))
                in addf tdr env1 end
              | addf (Vardec _ :: tdr) fenv = addf tdr fenv
        in 
            glofenv := addf topdecs Env.empty
        end;
    
    fun lookupglobalfun f = (lookup (!glofenv) f, !glovenv)
end

(* ------------------------------------------------------------------- *)

(* Interpreting uC statements *)

fun exec stmt (env : venv) (sto : sto) : venv * sto = 
    case stmt of 
        If(e, stmt1, stmt2) => 
            let val (v, sto1) = eval e env sto
            in 
                if int2bool v then
                    (env, #2 (exec stmt1 env sto1))
                else
                    (env, #2 (exec stmt2 env sto1))
            end
      | While(e, body) =>
            let fun loop sto1 =
                    let val (v, sto2) = eval e env sto1
                    in 
                        if int2bool v then 
                            loop (#2 (exec body env sto2))
                        else
                            sto2
                    end
            in (env, loop sto) end
      | Expr e => 
            let val (v, sto1) = eval e env sto 
            in (env, sto1) end
      | Block stmts => 
            let fun loop []       (env, sto) = (env, sto)
                  | loop (s1::sr) (env, sto) = loop sr (stmtordec s1 env sto)
                val (_, sto1) = loop stmts (env, sto) 
            in (env, sto1) end
      | Return _ => raise Fail "return not implemented"

and stmtordec (Stmt stmt)   env sto = exec stmt env sto
  | stmtordec (Dec(typ, x)) env sto = allocate (typ, x) env sto

(* Evaluating uC expressions *)

and eval e env sto : int * sto = 
    case e of
        Access acc     => let val (loc, sto1) = access acc env sto
                          in (getsto sto1 loc, sto1) end
      | Assign(acc, e) => let val (loc, sto1) = access acc env sto
                              val (res, sto2) = eval e env sto1
                          in (res, setsto sto2 loc res) end
      | Cst (CstI i)   => (i, sto)
      | Cst CstN       => (~1, sto)
      | Addr acc       => access acc env sto
      | Prim1(ope, e1) =>
            let val (i1, sto1) = eval e1 env sto
                val res =
                    case ope of
                        "!"      => bool2int (not (int2bool i1))
                      | "printi" => (print (Int.toString i1); print " "; i1)
                      | "printc" => (print (str (chr i1)); i1)
                      | _        => raise Fail "unknown primitive 1"
            in (res, sto1) end
      | Prim2(ope, e1, e2) =>
            let val (i1, sto1) = eval e1 env sto
                val (i2, sto2) = eval e2 env sto1
                val res =
                    case ope of
                        "*"  => i1 * i2
                      | "+"  => i1 + i2
                      | "-"  => i1 - i2
                      | "==" => bool2int (i1 =  i2)
                      | "!=" => bool2int (i1 <> i2)
                      | "<"  => bool2int (i1 <  i2)
                      | "<=" => bool2int (i1 <= i2)
                      | ">=" => bool2int (i1 >= i2)
                      | ">"  => bool2int (i1 >  i2)
                      | _    => raise Fail "unknown primitive 2"
            in (res, sto2) end
      | Andalso(e1, e2) => 
            let val res as (i1, sto1) = eval e1 env sto
            in 
                if int2bool i1 then eval e2 env sto1 else res
            end
      | Orelse(e1, e2) => 
            let val res as (i1, sto1) = eval e1 env sto
            in 
                if int2bool i1 then res else eval e2 env sto1
            end
      | Call(f, es) => callfun f es env sto 

and access (AccVar x)   env sto = (lookup (#1 env) x, sto)
  | access (AccDeref e) env sto = 
    let val (a, sto1) = eval e env sto
    in (a, sto1) end
  | access (AccIndex(acc, idx)) env sto = 
    let val (a, sto1) = access acc env sto
        val aval = getsto sto1 a
        val (i, sto2) = eval idx env sto1
    in (aval + i, sto2) end

and evals []       env sto = ([], sto)
  | evals (e1::er) env sto = 
    let val (v1, sto1) = eval e1 env sto
        val (vr, stor) = evals er env sto1 
    in (v1::vr, stor) end
    
and callfun f es (env as (_, nextloc)) sto : int * sto =
    let val ((paramdecs, body), gloenv) = lookupglobalfun f
        val (vs,   sto1) = evals es env sto
        val (envf, sto2) = bindvars (map #2 paramdecs) vs (gloenv,nextloc) sto
        val (_, sto3)    = exec body envf sto2 
    in (~111, sto3) end;

(* Interpreting complete uC programs by invoking the `main' function *)

fun run (Prog topdecs) vs = 
    let val (nextloc, sto0) = mkvenv topdecs
        val _ = mkfenv topdecs
        val ((paramdecs, body), gloenv) = lookupglobalfun "main"
        val (envf, sto2) = bindvars (map #2 paramdecs) vs (gloenv,nextloc) sto0
    in
        exec body envf sto2; ()
    end;


(* Example programs are found in the files ex1.c, ex2.c, etc *)