evaluation.ml

(** A mini-ML
    @author Stuart M. Shieber

    This module implements a small untyped ML-like language under
    various operational semantics.
 *)

open Expr ;;
  
(* Exception for evaluator runtime generated by a runtime error *)
exception EvalError of string ;;
(* Exception for evaluator runtime generated by an explicit "raise" construct *)
exception EvalException ;;

module type Env_type = sig
    type env
    type value =
       | Val of expr
       | Closure of (expr * env)
    val create : unit -> env
    val close : expr -> env -> value
    val lookup : env -> varid -> value
    val extend : env -> varid -> value ref -> env
    val env_to_string : env -> string
    val value_to_string : ?printenvp:bool -> value -> string
  end

module Env : Env_type =
  struct

    type env = (varid * value ref) list
     and value =
       | Val of expr
       | Closure of (expr * env)

    exception EnvUnbound

    (* Creates an empty environment *)
    let create () : env = [] ;;

    (* Creates a closure from an expression and the environment it's
       defined in *)
    let close (exp: expr) (env: env) : value =
      Closure (exp,env) ;;

    (* Looks up the value of a variable in the environment *)
    let rec lookup (env: env) (varname: varid) : value =
      match env with
      | [] -> raise (EvalError ("Unbound Variable " ^ varname))
      | (v,r)::tl -> if varname = v then !r else lookup tl varname
      ;;

    (* Returns a new environment just like env except that it maps the
       variable varid to loc *)
    let rec extend (env: env) (varname: varid) (loc: value ref) : env =
      match env with
      | [] -> [(varname,loc)]
      | (v,r)::tl -> if v = varname then (v,loc)::tl
                       else (v,r)::(extend tl varname loc)
      ;; 

    (* Returns a printable string representation of an environment *)
    let rec env_to_string (env: env) : string =
      let rec gen_string e =
        match e with
        | [] -> ""
        | (v,r)::tl -> "[" ^ v ^ "," ^ (value_to_string !r) ^ "] " in
      gen_string env and

    (* Returns a printable string representation of a value; the flag
       printenvp determines whether to include the environment in the
       string representation when called on a closure *)
    value_to_string ?(printenvp : bool = true) (v: value) : string =
      match v with
      | Val e -> "Val" ^ (exp_to_string e)
      | Closure(exp,env) -> if printenvp
                            then "Closure(" ^ (exp_to_string exp) ^
                              "," ^ (env_to_string env) ^ ")"
                            else "Closure(" ^ (exp_to_string exp) ^
                              ",env)"
      ;;
  end
;;
	     
(* The evaluation function: Returns the result of type `value` of
   evaluating the expression `exp` in the environment `env`. In this
   initial implementation, we just convert the expression unchanged to
   a value and return it. *)

let eval_t exp _env = Env.Val exp ;;

(* evaluate a unary operator*)
let uneval uop = 
  match uop with
  | Unop(v,(Num e)) -> (match v with
                       | "~" -> Num (-e)
                       | o -> raise (EvalError ("Invalid Unop Operator " ^ o)))
  | _ -> raise (EvalError "Invalid Unop") ;;

let bineval (bop: expr) : expr =
  match bop with
  | Binop(v,Num e1,Num e2) -> (match v with
                              | "+" -> Num (e1 + e2)
                              | "-" -> Num (e1 - e2)
                              | "*" -> Num (e1 * e2)
                              | "=" -> Bool (e1 = e2)
                              | "<" -> Bool (e1 < e2)
                              | o -> raise (EvalError ("Invalid Binop Operator "
                                                     ^ o)))
  | _ -> raise (EvalError "Invalid Binop") ;;

let condeval (cond: expr) : expr =
  match cond with
  | Conditional(Bool e1,e2,e3) -> if e1 then e2 else e3
  | _ -> raise (EvalError "Invalid Conditional") ;;


let eval_s exp _env = 
  let rec eval_s' exp' =
    match exp' with
    | Var v -> raise (EvalError ("Unbound Variable " ^ v))
    | Num _ -> exp'
    | Bool _ -> exp'
    | Unop(v,e) -> uneval (Unop (v,eval_s' e))
    | Binop(v,e1,e2) -> bineval (Binop (v,eval_s' e1,eval_s' e2))
    | Conditional(e1,e2,e3) -> eval_s' (condeval (Conditional (eval_s' e1,e2,e3)))
    | Fun(v,e) -> exp'
    | Let(v,e1,e2) -> eval_s' (App(Fun(v,e2),e1))
    | Letrec(x,q,p) -> let q' = eval_s' (subst x (Letrec(x,q,Var x)) q) in
                           eval_s' (subst x q' p)
    | Raise -> raise EvalException
    | Unassigned -> raise (EvalError "Unassigned Value")
    | App(e1,e2) -> match App ((eval_s' e1),(eval_s' e2)) with
                    | App(Fun(v,e1),e2) -> eval_s' (subst v e2 e1)
                    | _ -> raise (EvalError "Invalid App") in
  Env.Val (eval_s' exp)
;;

let extract v =
  match v with
  | Env.Val e -> e
  | Env.Closure(exp,env) -> exp ;;
  

let eval_d exp env =
  let rec eval_d' exp' env' =
    match exp' with
    | Var v -> extract (Env.lookup env' v)
    | Num n -> exp'
    | Bool b -> exp'
    | Unop(v,e) -> uneval (Unop (v,(eval_d' e env')))
    | Binop(v,e1,e2) -> bineval (Binop (v,(eval_d' e1 env'),(eval_d' e2 env')))
    | Conditional(c,e1,e2) -> let cond = Conditional ((eval_d' c env'),(e1),(e2)) in
                               eval_d' (condeval cond) env'
    | Fun(v,e) -> Fun(v,e)
    | Let(v,e1,e2) -> eval_d' (App(Fun(v,e2),e1)) env'
    | Letrec(v,e1,e2) -> let env'' = (Env.extend env' v
                                     (ref (Env.Val Unassigned))) in
                         let e1' = eval_d' e1 env'' in
                         let env3 = (Env.extend env'' v (ref (Env.Val e1'))) in
                          eval_d' e2 env3
    | Raise -> raise EvalException
    | Unassigned -> Unassigned
    | App(e1,e2) -> match App(eval_d' e1 env', eval_d' e2 env') with
                    | App(Fun(v,e),e2') -> (eval_d' e (Env.extend env'
                                            v (ref (Env.Val e2'))))
                    | _ -> raise (EvalError "Invalid App") in
  Env.Val (eval_d' exp env)
  ;;


let eval_l exp env = 
  let rec eval_l' value env' =
    let exp' = extract value in 
    match exp' with
    | Var v -> Env.lookup env' v
    | Num n -> Env.Val exp'
    | Bool b -> Env.Val exp'
    | Unop(v,e) -> Env.Val (uneval (Unop (v,extract (eval_l' (Env.Val e)
                     env'))))
    | Binop(v,e1,e2) -> Env.Val (bineval (Binop (v,extract (eval_l' (Env.Val
                          e1) env'),extract (eval_l' (Env.Val e2) env'))))
    | Conditional(c,e1,e2) -> let cond = Conditional (extract (eval_l'
                                         (Env.Val c) env'),e1,e2) in
                                eval_l' (Env.Val (condeval cond)) env'
    | Fun(v,e) -> Env.close exp' env'
    | Let(v,e1,e2) ->  (eval_l' (Env.Val (App(Fun(v,e2),e1))) env')
    | Letrec(v,e1,e2) -> let nref = ref (Env.Val Unassigned) in
                         let env'' = (Env.extend env' v nref) in
                         let e1' = eval_l' (Env.Val e1) env'' in
                         nref := e1'; eval_l' (Env.Val e2) env''
    | Raise -> raise EvalException
    | Unassigned -> Env.Val Unassigned
    | App(e1,e2) -> match eval_l' (Env.Val e1) env' with
                    | Env.Closure (Fun(v,e),oldenv) -> eval_l' (Env.Val e)
                        (Env.extend oldenv v (ref (eval_l' (Env.Val e2) env')))
                    | _ -> raise (EvalError "Invalid App") in
   (eval_l' (Env.Val exp) env)
  ;;



let evaluate = eval_t ;;