Untitled

open Common;;

let const_to_val c = raise (Failure "Not implemented yet.")

let monOpApply op v = match op with 
  | HdOp -> (match v with | ListVal (hd::tl) -> hd | ListVal [] -> Exn 0)
  | TlOp -> (match v with | ListVal (hd::tl) -> ListVal tl | ListVal [] -> Exn 0)
  | FstOp -> (match v with | PairVal (x, y) -> x)
  | SndOp -> (match v with | PairVal (x, y) -> y)
  | IntNegOp -> (match v with | IntVal i -> IntVal (-i))
  | PrintOp -> (match v with | StringVal s -> print_string s; UnitVal)

let binOpApply binop (v1,v2) = match binop with 
  | IntPlusOp -> (match v1 with IntVal i1  -> (match v2 with IntVal i2 -> IntVal (i1 + i2)))
  | IntMinusOp -> (match v1 with IntVal i1 -> (match v2 with IntVal i2 -> IntVal (i1 - i2)))
  | IntTimesOp -> (match v1 with IntVal i1 -> (match v2 with IntVal i2 -> IntVal (i1 * i2)))
  | IntDivOp -> (match v1 with IntVal i1 -> (match v2 with IntVal i2 -> if i2 = 0 then Exn 0 else IntVal (i1 / i2)))
  | ModOp -> (match v1 with IntVal i1 -> (match v2 with IntVal i2 -> IntVal (i1 mod i2)))
  | FloatPlusOp -> (match v1 with FloatVal f1 -> (match v2 with FloatVal f2 -> FloatVal (f1 +. f2)))
  | FloatMinusOp -> (match v1 with FloatVal f1 -> (match v2 with FloatVal f2 -> FloatVal (f1 -. f2)))
  | FloatTimesOp -> (match v1 with FloatVal f1 -> (match v2 with FloatVal f2 -> FloatVal (f1 *. f2)))
  | ExpoOp -> (match v1 with FloatVal f1 -> (match v2 with FloatVal f2 -> FloatVal (f1 ** f2)))
  | FloatDivOp -> (match v1 with FloatVal f1 -> (match v2 with FloatVal f2 -> if f2 = 0.0 then Exn 0 else FloatVal (f1 /. f2)))
  | ConcatOp -> (match v1 with StringVal s1 -> (match v2 with StringVal s2 -> StringVal (s1 ^ s2)))
  | ConsOp -> (match v2 with ListVal l -> ListVal (v1 :: l))
  | CommaOp -> PairVal (v1, v2)
  | EqOp -> BoolVal (v1 = v2)
  | GreaterOp -> BoolVal (v1 > v2)



let const_to_val c = match c with 
  | IntConst c -> IntVal c 
  | FloatConst c -> FloatVal c
  | BoolConst c -> BoolVal c
  | StringConst c -> StringVal c 
  | UnitConst -> UnitVal
  | NilConst -> ListVal []

let rec eval_exp (exp, m) = match exp with 
  | ConstExp c -> const_to_val c 
  | VarExp x -> let v = lookup_mem m x in (match v with 
                | RecVarVal (g, y, e, m') -> Closure (y, e, ins_env m' g (RecVarVal (g, y, e, m')) )
                | _ -> v)
  | MonOpAppExp (mon, e) -> let v = eval_exp (e, m) in (match v with Exn i -> Exn i | _ -> monOpApply mon v)
  | BinOpAppExp (op, e1, e2) -> let v1 = (eval_exp (e1, m)) in (match v1 with Exn i -> Exn i | _ -> let v2 = (eval_exp (e2, m)) in (match v2 with Exn i -> Exn i | _ -> binOpApply op (v1, v2)))
  | IfExp (e1, e2, e3) -> let cond = eval_exp (e1, m) in (match cond with | Exn i -> Exn i | BoolVal b -> 
                          if b then eval_exp (e2, m) else eval_exp (e3, m))
  | LetInExp (x, e1, e2) -> let v1 = eval_exp (e1, m) in (match v1 with Exn i -> Exn i | _ -> eval_exp (e2, (ins_env m x v1)))
  | FunExp (x, e) -> Closure (x, e, m)
  | AppExp (e1, e2) -> let v1 = eval_exp (e1, m) in (match v1 with Exn i -> Exn i | Closure (x, e', m') -> 
                       let v' = eval_exp (e2, m) in (match v' with Exn i -> Exn i | _ -> eval_exp (e', (ins_env m' x v')) | Exn (i) -> Exn (i)))
  | LetRecInExp (f, x, e1, e2) -> eval_exp (e2, ins_env m f (RecVarVal (f, x, e1, m)))
  | RaiseExp e -> let v = eval_exp (e, m) in (match v with | IntVal n -> Exn n | Exn i -> Exn i)
  |



let eval_dec (dec, m) = match dec with 
  | Anon e -> ((None, eval_exp(e, m)), m)
  | Let (x, e) -> let v = eval_exp (e, m) in ((Some x, v), (ins_env m x v))
  | LetRec (f, x, e) -> ((Some f, RecVarVal (f, x, e, m)), ins_env m f (RecVarVal (f, x, e, m)))