(*
 Oukseh Lee

 Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System
 (National Creative Research Initiative Center 1998-2003)
 http://ropas.snu.ac.kr/n

 All rights reserved. This file is distributed under the terms of
 an Open Source License.
*)

structure Lameval = struct
  open Lambda
  structure E = Lamenv
  exception Runtime_error of string
  exception Pfail
  exception Fail of E.store
  exception Exception of exnid * E.value option * E.store

  fun eval env st exp = 
    let fun value v = case v of
              Var x => ((E.E.find x env) handle Not_found => (
(*                                           E.print_env env; *)
                                           raise Runtime_error("Var "^string_of_int x)))
            | Const c => E.Const c
            | Data(id,_) => E.Data(id, None)
            | Op(Unary,s) =>
                let val x = new_var()
                in  E.Closure(x,App[Op(Unary,s), Var x],E.E.empty,[])
                end
            | Op(Binary,s) => 
                let val x = new_var() val y = new_var()
                in  E.Closure(x,Fun(y,Tbullet,App[Op(Binary,s),Var x,Var y]),E.E.empty,[])
                end

        fun f exp = case exp of
          Value v => (value v, st)
        | Fun(x,_,e) => (E.Closure(x,e,env,[]), st)
        | App[] | App[_] => raise Runtime_error "App.nil_or_one"
        | App[Op(Unary,s),v] => 
            let val v' = value v
            in  case (s,v') of
                  ("-",E.Const(Int i)) => (E.Const(Int(-i)), st)
                | ("-",E.Const(Real r)) => (E.Const(Real(-r)), st)
                | ("not",E.Const(Bool b)) => (E.Const(Bool(not b)), st)
                | ("print", v) => (E.print_value v; Format.printf "\n"; (E.Const Unit, st))
                | _ => raise Runtime_error "App.Op.Unary"
            end
        | App[Op(Binary,s), v1, v2] =>
            let val v1' = value v1 val v2' = value v2
            in  (case (s,v1',v2') of
                  ("<",_,_) =>  (E.Const(Bool(compare v1' v2' < 0)), st)
                | (">",_,_) =>  (E.Const(Bool(compare v1' v2' > 0)), st)
                | ("<=",_,_) => (E.Const(Bool(compare v1' v2' <= 0)), st)
                | (">=",_,_) => (E.Const(Bool(compare v1' v2' >= 0)), st)
                | ("=",_,_) =>  (E.Const(Bool(v1' = v2')), st)
                | (s,E.Const(Int i),E.Const(Int j)) => 
                    (E.Const(Int(case s of
                                    "+" => i+j | "-" => i-j | "*" => i*j
                                  | "/" => i/j | "%" => i mod j | "**" => i**j
                                  | ">>" => i>>j | "<<" => i<<j
                                  | _ => raise Runtime_error "App.Op.Binary.int"
                                 )), st)
                | (s,E.Const(Real i),E.Const(Real j)) => 
                    (E.Const(Real(case s of
                                    "+" => i+j | "-" => i-j | "*" => i*j
                                  | "/" => i/j (* | "**" => (i:real)**j *)
                                  | _ => raise Runtime_error "App.Op.Binary.Real"
                                )), st)
                | _ => raise Runtime_error "App.Op.Binary")
              handle
                  Division_by_zero => raise Exception("Zero",None,st)
                | Invalid_argument "equal: functional value" 
                    => raise Exception("Equality",None,st)
            end

        | App[x1,x2] => 
            let val v1 = value x1 val v2 = value x2
            in  case v1 of
                  E.Data(k,None) => (E.Data(k,Some v2), st)
                | E.Closure(x,e,env',[]) => eval (E.E.add x v2 env') st e
                | E.Closure(x,e,env',l) => 
                    let val env0 = List.fold_left 
                                     (fn e x => E.E.add x (E.E.find x env) e)
                                     env' l
                        val env1 = E.E.add x v2 env0
                    in  eval env1 st e
                    end
                | _ => raise Runtime_error "App"
            end
        | App(x1::x2::t) => 
            let val x3 = new_var()
            in  f(Let([(x3,Tbullet,App[x1,x2])],App(Var(x3)::t)))
            end
        | Tyfun(_,e) => f e
        | Tyapp(x,_) => (value x, st)
        | Let(l,e) => 
            let fun f (env',st') (x,_,e) =
                  let val (v,s) = eval env' st' e
                  in  (E.E.add x v env', s)
                  end
                val (env',st') = List.fold_left f (env,st) l
            in  eval env' st' e
            end
        | Letrec(l,e) => 
            let fun f (env0,s0) (x,_,e) =
                  let val (v,s1) = eval env s0 e
                  in  (E.E.add x v env0, s1)
                  end
                val (envn,sn) = List.fold_left f (E.E.empty, st) l
                val l' = List.map (fn x=>x.0) l
                fun makerec env = E.E.map (fn E.Closure(x,e,env',[]) => 
                                                E.Closure(x,e,env',l')
                                            | E.Closure _ => raise Runtime_error "Letrec.Closure"
                                            | x => x) env
                val env' = E.E.fold E.E.add (makerec envn) env
(*                val _ = E.print_env env' *)
            in  eval env' sn e
            end
        | Case(x,m) =>
            let val v = value x
            in  (match env st v m) handle Fail s' => raise Exception("Match",None,s')
            end
        | Raise x => 
            let val v = value x
            in  case v of
                  E.Data(Except id,opt) => raise Exception(id,opt,st)
                | _ => raise Runtime_error "Raise"
            end
        | Handle(e,m) =>
            ((f e) handle Exception(id,opt,s) => 
              ((match env s (E.Data(Except id,opt)) m)
                 handle Fail s' => raise Exception(id,opt,s)))
        | Tuple l => (E.Tuple(Array.map value l), st)
        | Pi(i,x) =>
            (case value x of
               E.Tuple l => ((l.[i],st) handle Invalid_argument "Array.sub" => 
                                          raise Exception("Bound",None,st))
              | _ => raise Runtime_error "Pi") 
        | Seq l => List.fold_left (fn (v,s) e => eval env s e) (E.Const Unit,st) l
        | Ref x => 
            let val a = E.new_address()
            in  (E.Addr a, E.S.add a (value x) st)
            end
        | Bang x =>
            (case value x of 
               E.Addr a => ((E.S.find a st, st) handle Not_found =>
                                                  raise Runtime_error "Bang.addr")
             | _ => raise Runtime_error "Bang")
        | Assign(x1,x2) =>
            (case value x1 of
               E.Addr a => (E.Const Unit, E.S.add a (value x2) st)
             | _ => raise Runtime_error "Assign")
        | Array l =>
            let val s = ref st
                fun f x = let val (v,s') = eval env (!s) (Ref x) in s := s'; v end
                val l' = Array.map f l
            in  (E.Tuple l', !s)
            end
        | Sub(x1,x2) =>
            (case (value x1,value x2) of
               (E.Tuple l, E.Const(Int i)) => 
                  ((l.[i],st) handle Invalid_argument "Array.sub" =>
                                raise Exception("Bound",None,st))
             | _ => raise Runtime_error "Sub")
        | For(x,v,e2,e3,e4) =>
            let fun fordo v s = 
                  let val env' = E.E.add x v env
                      val (v1,s1) = eval env' s e2
                  in  case v1 of 
                        E.Const(Bool true) =>
                          let val (v2,s2) = eval env' s1 e4
                              val (v3,s3) = eval env' s2 e3
                          in  fordo v3 s3
                          end
                      | E.Const(Bool false) => (E.Const Unit, s1)
                      | _ => raise Runtime_error "For"
                  end
            in  fordo (value v) st
            end
    in  f exp
    end

  and match env st value m =
    let fun f (p,e) = eval (E.E.fold E.E.add (pat value p) env) st e
        fun g [] = raise Runtime_error "Nil_match"
          | g [h] = f h
          | g (h::t) = (f h) handle Pfail => g t
    in  (g m) handle Pfail => raise Fail st
    end

  and pat value p = case (value,p) of
        (E.Const c1, Pconst c2) => if c1=c2 then E.E.empty else raise Pfail
      | (E.Data(k1,None), Pdata(k2,_)) => if k1=k2 then E.E.empty else raise Pfail
      | (E.Data(k1,Some v), Pdataarg((k2,_),x)) => if k1=k2 then E.E.add x v E.E.empty
                                               else raise Pfail
      | (v, Pvar x) => E.E.add x v E.E.empty
      | _ => raise Pfail


  fun eval_prog e = (ignore(eval E.E.empty E.S.empty e); ())
        handle Runtime_error s => Format.printf "½ÇÇà½Ã°£ ¿À·ù: %s.\n" s
             | Exception(s,a,_) => Format.printf "¿¹¿Ü»óȲ %s ÀÌ Ã³¸® ¾ÈµÆ½À´Ï´Ù.\n" s

end