(* Programming language concepts, seminar 2, 2002-02-13 *)
(* Evaluation, checking, and compilation of object language expressions *)
(* Stack machines for expression evaluation                             *) 

(* SML polymorphic functions *)

fun len []      = 0
  | len (x::xr) = 1 + len xr;


(* SML equality type variables *)

fun member x []      = false
  | member x (y::yr) = x=y orelse member x yr;

fun workday d = member d ["Mon", "Tue", "Wed", "Thu", "Fri"];


(* SML Basis Library, List.nth etc, Moscow ML Library documentation,
   mosmllib online 
 *)

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

(* SML: polymorphic datatypes *)

datatype 'a tree =
    Lf 
  | Br of 'a * 'a tree * 'a tree;
    
fun sumtree Lf              = 0
  | sumtree (Br(v, t1, t2)) = v + sumtree t1 + sumtree t2;

fun preorder1 Lf              = []
  | preorder1 (Br(v, t1, t2)) = v :: preorder1 t1 @ preorder1 t2

fun preo Lf              acc = acc
  | preo (Br(v, t1, t2)) acc = v :: preo t1 (preo t2 acc)
fun preorder t = preo t [] 

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

datatype expr = 
    CstI of int
  | Var of string
  | Let of string * expr * expr
  | Prim of string * expr list

(* Some closed expressions: *)

val e1 = Let("z", CstI 17, Prim("+", [Var "z", Var "z"]));

val e2 = Let("z", CstI 17, 
             Prim("+", [Let("z", CstI 22, Prim("*", [CstI 100, Var "z"])),
                        Var "z"]));

val e3 = Let("z", Prim("-", [CstI 5, CstI 4]), 
             Prim("*", [CstI 100, Var "z"]));

val e4 = Prim("+", [Prim("+", [CstI 20, Let("z", CstI 17, 
					    Prim("+", [Var "z", CstI 2]))]),
		    CstI 30]);

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

(* Evaluation of expressions with variables and bindings *)

fun lookup []          x = raise Fail (x ^ " not found")
  | lookup ((y, v)::r) x = if x=y then v else lookup r x;

fun eval (e : expr) (env : (string * int) list) : int =
    case e of 
        CstI i => i
      | Var x  => lookup env x 
      | Let(x, erhs, ebody) => 
            let val xval  = eval erhs env
                val env1 = (x, xval) :: env 
            in eval ebody env1 end
      | Prim("+", [e1, e2]) => eval e1 env + eval e2 env
      | Prim("*", [e1, e2]) => eval e1 env * eval e2 env
      | Prim("-", [e1, e2]) => eval e1 env - eval e2 env
      | Prim _              => raise Fail "unknown primitive"

fun eval0 e = eval e []

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

(* Closedness *)

(* Checking whether an expression is closed.  The environment env is a
   list of the bound variables.  *)

fun closedin (e : expr) (env : string list) : bool =
    case e of 
        CstI i => true
      | Var x  => member x env
      | Let(x, erhs, ebody) => 
            let val env1 = x :: env 
            in closedin erhs env andalso closedin ebody env1 end
      | Prim(ope, [e1, e2]) => closedin e1 env andalso closedin e2 env;

(* An expression is closed if it is closed in the empty environment *)

fun closed1 e = closedin e [];


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

(* Free variables *)

(* Operations on sets, represented as lists.  Simple but inefficient;
   one could use binary trees, hashtables or splaytrees for
   efficiency.  *)

(* union(xs, ys) is the set of all elements in xs or ys, without duplicates *)

fun union ([],    ys) = ys
  | union (x::xr, ys) = if member x ys then union(xr, ys)
                        else x :: union(xr, ys)

(* minus xs ys  is the set of all elements in xs but not in ys *)

fun minus ([],    ys) = []
  | minus (x::xr, ys) = if member x ys then minus(xr, ys)
                        else x :: minus (xr, ys)

(* Find all variables that occur free in expression e *)

fun freevars e : string list =
    case e of 
        CstI i => []
      | Var x  => [x]
      | Let(x, erhs, ebody) => 
            union (freevars erhs, minus (freevars ebody, [x]))
      | Prim(ope, [e1, e2]) => union (freevars e1, freevars e2);

(* Alternative definition of closed *)

fun closed2 e = (freevars e = [])


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

(* Compilation to target expressions with numerical indexes instead of
   symbolic variable names.  *)

datatype texpr =                        (* target expressions *)
    TCstI of int
  | TVar of int                         (* index into runtime environment *)
  | TLet of texpr * texpr
  | TPrim of string * texpr list


(* Map variable name to variable index at compile-time *)

fun getindex (cenv : ''a list) (x : ''a) =      
    let fun h []      = raise Fail "unknown variable"
          | h (y::yr) = if x=y then 0 else 1 + h yr
    in h cenv end

(* Compiling from expr to texpr *)

fun tcomp (e : expr) (cenv : string list) : texpr =
    case e of 
        CstI i => TCstI i
      | Var x  => TVar (getindex cenv x)
      | Let(x, erhs, ebody) => 
            let val cenv1 = x :: cenv 
            in TLet(tcomp erhs cenv, tcomp ebody cenv1) end
      | Prim(ope, [e1, e2]) => TPrim(ope, [tcomp e1 cenv, tcomp e2 cenv])

(* Evaluation of target expressions with variable indexes.  The
   run-time environment renv is a list of variable values (ints).  *)

fun teval e (renv : int list) : int =
    case e of 
        TCstI i => i
      | TVar x  => List.nth(renv, x)
      | TLet(erhs, ebody) => 
            let val xval = teval erhs renv
                val renv1 = xval :: renv 
            in teval ebody renv1 end
      | TPrim("+", [e1, e2]) => teval e1 renv + teval e2 renv
      | TPrim("*", [e1, e2]) => teval e1 renv * teval e2 renv
      | TPrim("-", [e1, e2]) => teval e1 renv - teval e2 renv
      | TPrim _              => raise Fail "unknown primitive"

(* Correctness: eval e []  equals  teval (tcomp e []) [] *)


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

(* Stack machines *)

(* Stack machine instructions.  An expressions in postfix or reverse
   Polish form is a list of stack machine instructions. *)

datatype rinstr =
    RCstI of int
  | RAdd 
  | RSub
  | RMul 
  | RDup
  | RSwap

(* A simple stack machine for evaluation of variable-free expressions
   in postfix form *)

fun reval ([] : rinstr list) (v :: _) = v
  | reval ([] : rinstr list) []       = raise Fail "reval: no result"
  | reval (inst :: rest)     stk =
    case (inst, stk) of
        (RCstI i, _)              => reval rest (i::stk)
      | (RAdd,  i2 :: i1 :: stkr) => reval rest ((i1+i2)::stkr)
      | (RSub,  i2 :: i1 :: stkr) => reval rest ((i1-i2)::stkr)
      | (RMul,  i2 :: i1 :: stkr) => reval rest ((i1*i2)::stkr)
      | (RDup,        i1 :: stkr) => reval rest (i1 :: i1 :: stkr)
      | (RSwap, i2 :: i1 :: stkr) => reval rest (i1 :: i2 :: stkr)

val rpn1 = reval [RCstI 10, RCstI 17, RDup, RMul, RAdd] [];


(* Compilation of a variable-free expression to a rinstr list *)

fun rcomp e : rinstr list =
    case e of 
        CstI i => [RCstI i]
      | Prim("+", [e1, e2]) => rcomp e1 @ rcomp e2 @ [RAdd]
      | Prim("*", [e1, e2]) => rcomp e1 @ rcomp e2 @ [RMul]
      | Prim("-", [e1, e2]) => rcomp e1 @ rcomp e2 @ [RSub]
      | Prim _              => raise Fail "unknown primitive"
            
(* Correctness: eval e []  equals  reval (rcomp e) [] *)


(* Storing intermediate results and variable bindings in the same stack *)

datatype sinstr =
    SCstI of int                        (* push integer           *)
  | SVar of int                         (* push variable from env *)
  | SAdd                                (* pop args, push sum     *)
  | SSub                                (* pop args, push diff.   *)
  | SMul                                (* pop args, push product *)
  | SPop                                (* pop value/unbind var   *)
  | SSwap                               (* exchange top and next  *)
 
fun seval ([] : sinstr list) (v::_) = v
  | seval ([] : sinstr list) _      = raise Fail "seval: no result??"
  | seval (inst :: rest)     stk = 
    (case (inst, stk) of
         (SCstI i,    _)            => seval rest (i :: stk) 
       | (SVar i,     _)            => seval rest (List.nth(stk, i) :: stk) 
       | (SAdd,       i2::i1::stkr) => seval rest (i1+i2 :: stkr)
       | (SSub,       i2::i1::stkr) => seval rest (i1-i2 :: stkr)
       | (SMul,       i2::i1::stkr) => seval rest (i1*i2 :: stkr)
       | (SPop,          _ :: stkr) => seval rest stkr
       | (SSwap,      i2::i1::stkr) => seval rest (i1::i2::stkr))


(* A compile-time variable environment with dummies Intrm for
   intermediate values. *)

datatype rtvalue =
    Bound of string                     (* A bound variable       *)
  | Intrm                               (* An intermediate result *)


(* Compilation to a list of instructions for a unified-stack machine *)

fun scomp e (cenv : rtvalue list) : sinstr list =
    case e of 
        CstI i => [SCstI i]
      | Var x  => [SVar (getindex cenv (Bound x))]
      | Let(x, erhs, ebody) => 
            scomp erhs cenv @ scomp ebody (Bound x :: cenv) @ [SSwap, SPop]
      | Prim(ope, [e1, e2]) => 
            scomp e1 cenv 
            @ scomp e2 (Intrm :: cenv) 
            @ [case ope of 
                   "+" => SAdd
                 | "-" => SSub
                 | "*" => SMul
                 | _   => raise Fail "SPrim2 operator"]


val ss = map (fn e => scomp e []) [e1, e2, e4];



(* Output the integers in list inss to the text file called fname: *)

fun instofile (inss : int list) (fname : string) = 
    let val os = TextIO.openOut fname
        fun outn n = TextIO.output(os, " " ^ Int.toString n);
    in
        List.app outn inss; 
        TextIO.closeOut os
    end;

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

(* Possibly drop this *)

(* SML: higher-order functions *)

fun map f []      = []
  | map f (x::xr) = f x :: map f xr;


(* SML: anonymous functions *)

fun double x = 2 * x;

map double [4, 5, 89];

map (fn x => 2 * x) [4, 5, 89];


(* SML: the list iterator foldr replaces `::' by f and [] by e *)

fun foldr f e []      = e
  | foldr f e (x::xr) = f(x, foldr f e xr);

fun len xs   = foldr (fn (_, res) => 1+res) 0 xs;

fun sum xs   = foldr (fn (x, res) => x+res) 0 xs;

fun prod xs  = foldr (fn (x, res) => x*res) 1 xs;

fun map g xs = foldr (fn (x, res) => g x :: res) [] xs;

(* Using foldr and map to compute freevars for arbitrary primitives *)

fun freevars e : string list =
    case e of 
        CstI i => []
      | Var x  => [x]
      | Let(x, erhs, ebody) => 
            union (freevars erhs, minus (freevars ebody, [x]))
      | Prim(ope, es) => foldr union [] (map freevars es)


(* SML: the tree iterator tfold replaces Br by f and Lf by e *)

fun tfold f e Lf            = e
  | tfold f e (Br(v,t1,t2)) = f(v, tfold f e t1, tfold f e t2);

fun sumtree t = tfold (fn (v, r1, r2) => v + r1 + r2) 0 t;