(* micro-C, 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.

   Run this by

      mosmlc -c Env.sig Env.sml
      mosmlc -c Sto.sig Sto.sml
      cd imp
      mosmllex Clex.lex
      mosmlyac -v Cpar.grm
      mosmlc -c Absyn.sml
      mosmlc -c -liberal Cpar.sig Cpar.sml
      mosmlc -c Clex.sml

      mosml -I .. parse.sml c.sml
      run (parsefile "ex1.c") [17];
 *)

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

open Absyn Env Sto;

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

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

type venv = (string, int) env * int

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

type paramdecs = (typ * string) list
type fenv = (string, paramdecs * 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 loc 0   sto = sto
	  | initsto loc len sto = 
	    initsto (loc+1) (len-1) (setsto sto loc ~1)
        val (nextloc1, v, sto1) =
            case typ of 
                TypA (t, SOME i) => 
		    (nextloc+i, nextloc, initsto nextloc i sto0)
              | _ => (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 micro-C 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 v<>0 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 v<>0 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 micro-C 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
                        "!"      => if i1=0 then 1 else 0
                      | "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
                      | "/"  => i1 div i2
                      | "==" => if i1 =  i2 then 1 else 0
                      | "!=" => if i1 <> i2 then 1 else 0
                      | "<"  => if i1 <  i2 then 1 else 0
                      | "<=" => if i1 <= i2 then 1 else 0
                      | ">=" => if i1 >= i2 then 1 else 0
                      | ">"  => if i1 >  i2 then 1 else 0
                      | _    => raise Fail "unknown primitive 2"
            in (res, sto2) end
      | Andalso(e1, e2) => 
            let val res as (i1, sto1) = eval e1 env sto
            in 
                if i1<>0 then eval e2 env sto1 else res
            end
      | Orelse(e1, e2) => 
            let val res as (i1, sto1) = eval e1 env sto
            in 
                if i1<>0 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 a complete micro-C program by invoking its `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 *)