(******************************************************************************
 * SNU 4190.310 Programming Languages (Fall 2006)
 *
 * HW 4: unsugar call-by-ref, K- to SM5, tail-call
 ******************************************************************************)

(******************************************************************************
 * Exercise 1.
 * unsugar call-by-ref
 ******************************************************************************)

fun new_var id = id^"-ref"

(* dissolve call-by-reference sugar *)
val rec dissolve: exp -> (id -> id) -> exp
= fn exp change => case exp 
  of VAR id => VAR (change id)
   | ADD (e1, e2) => ADD (dissolve e1 change, dissolve e2 change) 
   | SUB (e1, e2) => SUB (dissolve e1 change, dissolve e2 change)
   | MUL (e1, e2) => MUL (dissolve e1 change, dissolve e2 change)
   | DIV (e1, e2) => DIV (dissolve e1 change, dissolve e2 change)
   | EQUAL (e1, e2) => EQUAL (dissolve e1 change, dissolve e2 change)
   | LESS (e1, e2) => LESS (dissolve e1 change, dissolve e2 change)
   | NOT e => NOT (dissolve e change)
   | ASSIGNV (id, e) => ASSIGNV (change id, dissolve e change)
   | ASSIGNF (e1, id, e2) => ASSIGNF (dissolve e1 change, id, dissolve e2 change)
   | ASSIGNG (e1, e2) => ASSIGNG (dissolve e1 change, dissolve e2 change)
   | SEQ (e1,e2) => SEQ (dissolve e1 change, dissolve e2 change)
   | IF2 (e1,e2,e3) => IF2 (dissolve e1 change, dissolve e2 change, dissolve e3 change)
   | IF1 (e1,e2) => IF1 (dissolve e1 change, dissolve e2 change) 
   | WHILE (e1, e2) => WHILE (dissolve e1 change, dissolve e2 change) 
   | FOR (id, e1,e2,e3) => FOR (change id, dissolve e1 change, dissolve e2 change, dissolve e3 change)  
   | RECORD lst  => exp 
   | FIELD (e1, id) => FIELD (dissolve e1 change, id)
   | MALLOC e => MALLOC (dissolve e change)
   | AMPER id => AMPER (change id)
   | STAR e => STAR (dissolve e change)
   | READ id => READ (change id)
   | WRITE e => WRITE (dissolve e change)
     (* new variable introduction *)
   | LETV (id,e1,e2) =>
     let val new_change =
       (fn x => if x = id then id else change x)
     in LETV (id, dissolve e1 change, dissolve e2 new_change)
     end
     (* original function call *)
   | CALLV (id, e) => CALLV (id, dissolve e change)
     (* f<x> --> f'(&x) *)
   | CALLR (fid, aid) => CALLV (change fid, AMPER (change aid))
     (* let procedure f(x) =            let procedure f(x) =
          let ret := 0 in                 write x;
          let z := *x in       <-----     x := x + 1;
          write z ;                       write x
          z := z + 1 ;                  in ... end
          ret := (write z);
          (x) := z;
          ret 
          end end 
        in ... end
      *)
   | LETF (fid, aid,e1,e2) => 
     let val fprime  = new_var fid 
         val new_arg = new_var aid
         val return_var = new_var "RET"
         val change_for_function  = (fn x => if x = fid then fprime else (change x))
         val change_for_arg = (fn x => if x = aid then new_arg else (change_for_function x))
         fun insert_return exp = case exp 
          of SEQ(e1, e2) => SEQ(e1, insert_return e2)
           | exp => ASSIGNV (return_var, exp)
         val e1_prime = 
           LETV (return_var, NUM 0,
             LETV (new_arg, STAR (VAR aid),
               SEQ (dissolve (insert_return e1) change_for_arg,
                SEQ (ASSIGNG (ADD(VAR aid,NUM 0) ,VAR new_arg),
                 VAR return_var))))
     in
         LETF (fprime, aid,
         LETF (fid,aid, dissolve e1 change_for_function, e1_prime),
         LETF (fid, aid, dissolve e1 change_for_function,
         dissolve e2 change_for_function))
     end
   | _ => exp

val dissolveCbr : program -> program
=fn pgm -> dissolve pgm (fn x => x)


(******************************************************************************
 * Exercise 2.
 * K- to SM5
 ******************************************************************************)

open Sm5

structure HW = struct

val rec trans : K.program -> Sm5.command
=fn pgm => case pgm of 
    (* Values *)
      K.NUM i => (PUSH(Val(Z i)))::empty_command
    | K.TRUE => (PUSH(Val(B true)))::empty_command
    | K.FALSE => (PUSH(Val(B false)))::empty_command
    | K.UNIT => (PUSH(Val(Unit)))::empty_command
    
    (* VAR *)
    | K.VAR x => (PUSH(Id x))::LOAD::empty_command
    
    (* arithmetic operations *)
    (* Bind(임시저장) 후 push 작업을 해주는 이유: trans(e1), trans(e2)에서 발생할 수 있는 unit 때문 *)
    (* 두 개의 인자를 받는 모든 커맨드는 위의 작업을 해주어야 한다. *)
    | K.ADD(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::ADD::empty_command)
        end
    | K.SUB(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::SUB::empty_command)
        end
    | K.MUL(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::MUL::empty_command)
        end
    | K.DIV(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::DIV::empty_command)
        end
        
    (* EQUAL / LESS / NOT *)
    | K.EQUAL(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::EQ::empty_command)
        end
    | K.LESS(e1, e2) => 
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::trans(e2):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::PUSH(Id "A'")::PUSH(Id "B'")::empty_command)
        in
            List.append list2 (UNBIND::UNBIND::POP::POP::LESS::empty_command)
        end
    |    K.NOT(e1) => 
        List.append (trans(e1):cmd list) (NOT::empty_command)
    
    (* ASSIGNV *)
    | K.ASSIGNV(x, e) =>
        let 
            val list1 = List.append ((PUSH(Id x))::(BIND "A'")::empty_command) (trans(e):cmd list) 
            val list2 = List.append list1 ((BIND "B'")::empty_command) (* A' = x, B' = e *)
            val list3 = List.append list2 ((PUSH(Id "B'"))::empty_command) (* 스택에 e를 넣음 *)
            val list4 = List.append list3 ((PUSH(Id "A'"))::empty_command) (* 스택에 x를 넣음 *)
            val list5 = List.append list4 (UNBIND::UNBIND::empty_command) (* B'과 A'을 환경에서 제거 *)
        in
            List.append list5 (POP::POP::STORE::(PUSH(Val(Unit)))::empty_command) (* 스택 정리 후 STORE *)
        end
        
    (* ASSIGNF *)    
    | K.ASSIGNF(e1, x, e2) =>
        let
            val list1 = List.append (trans(e1):cmd list) ((UNBOX x)::empty_command) (* assign할 주소 *)
            val list2 = List.append list1 ((BIND "B'")::trans(e2):cmd list) (* assign할 값; A' = e2, B' = x *)
            val list3 = List.append list2 ((BIND "A'")::(PUSH(Id "A'"))::((PUSH(Id "B'"))::empty_command)) 
        in
            List.append list3 (UNBIND::UNBIND::POP::POP::STORE::(PUSH(Val(Unit)))::empty_command) 
            (* 스택 정리 후 STORE *)
        end
    (* ASSIGNG *)
    | K.ASSIGNG(e1, e2) =>
        let 
            val list1 = List.append (trans(e1):cmd list) ((BIND "A'")::(trans(e2):cmd list)) 
            val list2 = List.append list1 ((BIND "B'")::empty_command) (* A' = e1, B' = e2 *)
            val list3 = List.append list2 ((PUSH(Id "B'"))::empty_command) (* 스택에 e2를 넣음 *)
            val list4 = List.append list3 ((PUSH(Id "A'"))::empty_command) (* 스택에 e1(주소)를 넣음 *)
            val list5 = List.append list4 (UNBIND::UNBIND::empty_command) (* B'과 A'을 환경에서 제거 *)
        in
            List.append list5 (POP::POP::STORE::(PUSH(Val(Unit)))::empty_command) (* 스택 정리 후 STORE *)
        end
                
    (* SEQ *)    
    | K.SEQ(e1, e2) =>
        List.append (trans(e1):cmd list) (trans(e2):cmd list)
        
    (* IF2 *)
    | K.IF2(e1, e2, e3) =>
        let 
            val list1 = List.append (trans(e1):cmd list) (JTR((trans(e2):cmd list), (trans(e3):cmd list))::empty_command)
        in
            List.append list1 ((PUSH(Val(Unit)))::empty_command)
        end
    
    (* IF1 *)
    | K.IF1(e1, e2) =>
        let 
            val list1 = List.append (trans(e1):cmd list) (JTR((trans(e2):cmd list), empty_command)::empty_command)
        in
            List.append list1 ((PUSH(Val(Unit)))::empty_command)
        end
        
    (* LETV *)    
    | K.LETV(x, e1, e2) =>
        let
            val list1 = List.append (MALLOC::(BIND x)::empty_command) (trans(e1):cmd list)
            val list2 = List.append list1 ((PUSH(Id x))::STORE::empty_command)
            val list3 = List.append list2 (trans(e2):cmd list)
        in
            List.append list3 (UNBIND::POP::empty_command) (* 유효범위 내 명령이 끝나면 unbind *)
        end 
        
    (* LETF *)    
    | K.LETF(f, x, e1, e2) =>
        let
            val list0 = (BIND f)::(trans(e1):cmd list)  (* C': BIND f를 덧붙이는 것은 재귀호출 위한 것 *)
            val list1 = List.append ((PUSH(Fn(x, list0)))::empty_command) ((BIND f)::empty_command)
            val list2 = List.append list1 (trans(e2):cmd list) 
        in
            List.append list2 (UNBIND::POP::empty_command)
        end
        
    (* CALLV *)
    | K.CALLV(f, e) =>
        let
            val list1 = List.append (trans(e):cmd list) ((PUSH(Id f))::(PUSH(Id f))::MALLOC::empty_command)
            val list2 = List.append list1 ((BIND "A'")::(BIND "B'")::(BIND "C'")::(BIND "D'")::empty_command)
            val list3 = 
                List.append list2 ((PUSH(Id "B'"))::(PUSH(Id "C'"))::(PUSH(Id "D'"))::(PUSH(Id "A'"))::empty_command)
        in    
            List.append list3 (UNBIND::UNBIND::UNBIND::UNBIND::POP::POP::POP::POP::CALL::empty_command)
        end
        (* 1번의 PUSH(Id f)는 재귀호출 위한 것 *)
        (* e 내에서도 함수가 호출될 수 있다. 그러므로, *)
        (* 함수 body 실행 시 스택에 쌓일 수 있는 unit 값을 고려하여 일부러 순서를 바꾸어 push.*)
        (* 처음 스택 상태 l::f::f::v => 나중 상태 l::v::f::f , 변환해줄 필요가 있다. *)
        
    
    (* RECORD *)
    | K.RECORD([(x, e1), (y, e2)]) =>
         let
            val list1 = List.append (MALLOC::(BIND x)::empty_command) (trans(e1):cmd list) (* 일단 bind *)
            val list2 = List.append list1 ((PUSH(Id x))::STORE::empty_command) (* 저장 *)
            val list3 = List.append list2 ((PUSH(Id x))::(PUSH(Val(Z 1)))::ADD::(BIND y)::empty_command)
            val list4 = List.append list3 (trans(e2):cmd list) 
        in
            List.append list4 ((PUSH(Id y))::STORE::UNBIND::UNBIND::(BOX 2)::empty_command)
        end
        
    (* FIELD *)
    | K.FIELD(e, x) =>
            List.append (trans(e):cmd list) ((UNBOX x)::LOAD::empty_command)
            
    (* MALLOC *)
    | K.MALLOC(e) => MALLOC::empty_command
        
    (* AMPER *)
    | K.AMPER(x) => (PUSH(Id x))::empty_command
    
    (* STAR *)
    | K.STAR(e) => List.append (trans(e):cmd list) (LOAD::empty_command)
        
    (* READ *)
    | K.READ(x) => MALLOC::(BIND x)::GET::(PUSH(Id x))::STORE::(PUSH(Val(Unit)))::empty_command
        
    (* WRITE *)
    | K.WRITE(n) => List.append (trans(n):cmd list) (PUT::(PUSH(Val(Unit)))::empty_command)
    
    | _ => empty_command
end


(******************************************************************************
 * Exercise 3.
 * tail-call
 ******************************************************************************)

(*
- trans함수는 trans_sub와 trans_find라는 부함수를 가지고 있다.
- trans_sub가 실질적인 번역과정을 수행한다.
- Sm5x에 추가된 명령어는 CALLTR이다.
     | (V(L l)::V v::P(x,c',e')::s,_,_,CALLTR::c,k) =>     // CALLTR : Tail-recursive call을 위한 명령어. 
         (s, (l,v)::m, (x,V(L l))::e', c', k)
   -> 기존의 CALL에 대해, 단순히 k에 더이상의 명령어를 쌓지 않는 역할만 한다.
   -> Tail-recursive call인지 판별하는 것은 trans에서 수행해줌으로써, Sm5x의 수행속도에는 판별 과정이 지장을 주지 않게 된다.
- trans_sub는 is_tr이라는 인자를 가지고 있으며, is_tr은 현재 상태에서 'Tail-recursive-call(이하 TR)일 가능성이 있는지'를 알려주는 일종의 flag이며 boolean값을 갖는다..
- trans는 trans_sub를 실행할 때 is_tr값으로 false를 넘겨주며, LETF(f, x, e1, e2)를 만날 경우 e2를 번역할때 true로 셋팅해준다. 
- LETF내에서 만나는 각각의 command에 대해, 현재 command를 수행할 경우 무조건 '다음에 할 일이 있는(예를 들면 ADD같은 경우)' 경우는 이후에 수행하는 exp에 대해
   false를 넘겨준다. 정확히 알 수 없는 경우는 받은 is_tr값을 그대로 흘려준다.
- is_tr값이 무사히(?) true값을 유지하며 CALLV까지 닿았을 경우, CALLTR을 수행하도록 하고, 중간에 false를 만나 쓰러졌을 경우는 본디의 CALL을 수행한다.
- trans_find는 오직 SEQ에서만 쓰인다. SEQ(e1, e2)일때 e2에서 함수 리턴을 위한 처리가 되어있을 가능성이 있으므로, e1에서 CALLV한 결과를 그대로 대입하는 내용이
   있는지 판단한다.

- 다음과 같은 경우를 TR로 판단하고 수행한다.
1) 기본 예제의 gcd.k-
2) let procedure f(x) = call f(x - 1)  
3) let procedure rtest(x) =
            if ( x = 0 )
                then
                    1
                else
                    call rtest(x-1)
            end
4)    let procedure rtest(x) = 
          let result := 0 
          in 
             if ( x = 0 ) 
                then 
                   result := 1 
                else 
                   result := call rtest(x-1) 
             end; 
             result 
          end 
5)   let procedure rtest(x) = 
          let result := malloc(5) 
          in 
             if ( x = 0 ) 
                then 
                   (result+1) := 1 
                else 
                   (result+1) := call rtest(x-1) ;(*(result+1))
             end; 
         *(result+1)     // 어차피 값을 리턴하는 것만 수행한다.
      end 
6)     let x := 0 in 
    let y := 0 in 
           let procedure perm(x) =             // 순열을 계산한다.
              let result := 0 
              in 
                 if ( x.fst = 0) 
                    then 
                       result := x.snd.s 
                    else 
                       result := call perm({ fst := x.fst-1, snd := {n := x.snd.n-1, s := x.snd.n * x.snd.s} }) 
                 end; 
                 result 
              end 
           in 
              read x; 
              read y; 
              write call perm( { fst := y, snd := {n := x, s := 1} }) 
           end 
    end 
    end 
*)

signature SM5 = 
sig
  type cmd = 
         PUSH of obj | POP | STORE | LOAD | JTR of command * command
       | MALLOC | BOX of int | UNBOX of string | BIND of string | UNBIND
       | GET | PUT | CALL | CALLTR | ADD | SUB | MUL | DIV | EQ | LESS | NOT
   and obj = Val of value | Id of string | Fn of string * command
   and value = Z of int | B of bool | L of loc | Unit | R of record
   and record
   and loc
   and command = cmd list

  val empty_command : command

  val print : command -> unit
  val run : command -> unit
end

structure Sm5x : SM5 =
struct
  type cmd = 
         PUSH of obj | POP | STORE | LOAD | JTR of command * command
       | MALLOC | BOX of int | UNBOX of string | BIND of string | UNBIND
       | GET | PUT | CALL | CALLTR | ADD | SUB | MUL | DIV | EQ | LESS | NOT 
   and obj = Val of value | Id of string | Fn of string * command
   and svalue = V of value | P of proc | M of map
   and value = Z of int | B of bool | L of loc | Unit | R of record
   and record = map list
   and loc = int * int
   and map = string * svalue
   and proc = string * command * environment
   and stack = svalue list
   and memory = (loc * value) list
   and environment = map list
   and command = cmd list
   and continuation = (command * environment) list
   
  exception RunError of stack * memory * environment * command * continuation
  exception Unbound_id of string
  exception Unbound_loc of int * int
  exception End

  val empty_command = []

  fun (@?) l x = snd (List.find (fn y => x = fst y) l)

  open Format

  fun print_seq f g l =
    case l of
      [] => ()
    | [h] => f h
    | h::t => f h; g h; print_seq f g t
  fun printv v =
    case v of
      Z i => printf "%d" i
    | B b => if b then printf "true" else printf "false"
    | R [] => printf "[]"
    | R (h::t) =>
        let fun pf (x, V(L(l1, l2))) = printf "(%s,<%d,%d>)" x l1 l2
              | pf _ = raise Invalid_argument "non Loc in Record"
        in  printf "["; pf h; List.iter (fn f => printf ", "; pf f) t; 
            printf "]"
        end
    | Unit => printf "()" 
    | L (b,o) => printf "<%d,%d>" b o
  fun printp p = 
    case p of
      Val v => printv v
    | Id x => printf "%s" x
    | Fn(x,c) => printf "@[<1>(%s,@ " x; print c; printf ")@]"
  and printc c = printf "@[";
    (case c of
         PUSH p => printf "push "; printp p
       | POP => printf "pop"
       | STORE => printf "store"
       | LOAD => printf "load"
       | JTR(c1,c2) => 
           printf "@[<5>jtr ("; print c1; printf ",@ ";
           print c2; printf ")@]"
       | MALLOC => printf "malloc"
       | BOX z => printf "box %d" z
       | UNBOX x => printf "unbox %s" x
       | BIND x => printf "bind %s" x
       | UNBIND => printf "unbind"
       | GET => printf "get"
       | PUT => printf "put"
       | CALL => printf "call"
       | CALLTR => printf "calltr"
       | ADD => printf "add"
       | SUB => printf "sub"
       | MUL => printf "mul"
       | DIV => printf "div"
       | EQ => printf "eq"
       | LESS => printf "less"
       | NOT => printf "not"); printf "@]"
  and print l =
    printf "@[";
    print_seq printc (fn _ => printf "@ ") l;
    printf "@]";
    print_flush()
    
  val loccount = ref 0
  fun newl() = loccount++; (!loccount,0)

  fun eval (x as (s,m,e,c,k)) = eval(
     case x of
       (_,_,_,PUSH(Val v)::c,_) => (V v::s, m, e, c, k)
     | (_,_,_,PUSH(Id x)::c, _) => 
         (((e @? x)::s, m, e, c, k) 
          handle Not_found => raise Unbound_id x) 
     | (_,_,_,PUSH(Fn(x,c'))::c,_) => (P(x,c',e)::s, m, e, c, k)
     | (w::s,_,_,POP::c,k) => (s, m, e, c, k)
     | (V(L l)::V v::s,_,_,STORE::c,_) => (s, (l,v)::m, e, c, k)
     | (V(L l)::s,_,_,LOAD::c,_) => 
         ((V(m @? l)::s, m, e, c, k)
           handle Not_found => raise Unbound_loc l)
     | (V(B b)::s,_,_,JTR(c1,c2)::c,_) => 
         (s, m, e, if b then c1@c else c2@c, k)
     | (_,_,_,MALLOC::c,_) => (V(L(newl()))::s, m, e, c, k)
     | (_,_,_,BOX z::c,_) =>
        let fun box b 0 s = V (R b)::s
              | box b z (M m::s) = box (m::b) (z-1) s
              | box _ _ _ = raise RunError (s,m,e,c,k)
        in  (box [] z s,m,e,c,k)
        end
     | (V (R b)::s,_,_,UNBOX x::c,_) =>
        (((b @? x)::s,m,e,c,k)
            handle Not_found => raise Unbound_id x)
     | (w::s,_,_,BIND x::c,_) => (s, m, (x,w)::e, c, k)
     | (_,_,i::e,UNBIND::c,_) => (M i::s, m, e, c, k)
     | (_,_,_,GET::c,_) => (V(Z(read_int()))::s, m, e, c, k) 
     | (V(Z z)::s,_,_,PUT::c,_) => 
          print_int z; print_newline(); (s, m, e, c, k)
     | (V(Z z2)::V(Z z1)::s,_,_,ADD::c,_) => (V(Z(z1+z2))::s, m, e, c, k)
     | (V(Z z2)::V(L(l1,l2))::s,_,_,ADD::c,_) => (V(L(l1,l2+z2))::s, m, e, c, k)
     | (V(L(l1,l2))::V(Z z2)::s,_,_,ADD::c,_) => (V(L(l1,l2+z2))::s, m, e, c, k)
     | (V(Z z2)::V(Z z1)::s,_,_,SUB::c,_) => (V(Z(z1-z2))::s, m, e, c, k)
     | (V(Z z2)::V(L(l1,l2))::s,_,_,SUB::c,_) => (V(L(l1,l2-z2))::s, m, e, c, k)
     | (V(L(z1,z2))::V(L(l1,l2))::s,_,_,SUB::c,_) => if z1 = l1 then (V(Z(l2-z2))::s, m, e, c, k)
                                                     else raise RunError (s,m,e,c,k)
     | (V(Z z2)::V(Z z1)::s,_,_,MUL::c,_) => (V(Z(z1*z2))::s, m, e, c, k)
     | (V(Z z2)::V(Z z1)::s,_,_,DIV::c,_) => (V(Z(z1/z2))::s, m, e, c, k)
     | (V v1::V v2::s,_,_,EQ::c,_) => (V(B(v1=v2))::s, m, e, c, k)
     | (V(Z z2)::V(Z z1)::s,_,_,LESS::c,_) => (V(B(z1<z2))::s, m, e, c, k)
     | (V(L(z1,z2))::V(L(l1,l2))::s,_,_,LESS::c,_) => if z1 = l1 then (V(B(l2<z2))::s, m, e, c, k)
                                                     else raise RunError (s,m,e,c,k)
     | (V(B b)::s,_,_,NOT::c,_) => (V(B(not b))::s, m, e, c, k)
     | (V(L l)::V v::P(x,c',e')::s,_,_,CALL::c,k) =>  
         (s, (l,v)::m, (x,V(L l))::e', c', (c,e)::k)
         
     | (V(L l)::V v::P(x,c',e')::s,_,_,CALLTR::c,k) =>     // CALLTR : Tail-recursive call을 위한 명령어. 
         (s, (l,v)::m, (x,V(L l))::e', c', k)
     
     | (_,_,_,[],(c,e')::k) => (s, m, e', c, k)
     | (_,_,_,[],[]) => raise End
     | _ => raise RunError (s,m,e,c,k))

  fun print_error x = printf "SM5x evaluation error: ";
    (case x of
       Unbound_id x => printf "unbound id '%s'.@." x
     | Unbound_loc (l1,l2) => printf "unbound loc (%d,%d).@." l1 l2
     | RunError s => printf "stuck configuration.@."
     | x => raise x);
    print_flush()  

  fun run c = (ignore (eval ([],[],[],c,[]))) 
                handle End => ()
                     | x => print_error x
end

fun trans(pgm)= trans_sub(false, pgm)

and trans_sub(is_tr, K.NUM n)= Sm5x.PUSH(Sm5x.Val(Sm5x.Z n))::[]
   | trans_sub(is_tr, K.TRUE)= Sm5x.PUSH(Sm5x.Val(Sm5x.B true))::[]
   | trans_sub(is_tr, K.FALSE)= Sm5x.PUSH(Sm5x.Val(Sm5x.B false))::[]
   | trans_sub(is_tr, K.UNIT)= Sm5x.PUSH(Sm5x.Val(Sm5x.Unit))::[]
   | trans_sub(is_tr, K.VAR x)= Sm5x.PUSH(Sm5x.Id x)::Sm5x.LOAD::[]
   | trans_sub(is_tr, K.CALLV (f, e))= 
     (case is_tr 
      of true => Sm5x.PUSH(Sm5x.Id f)::Sm5x.PUSH(Sm5x.Id f)::(List.append (trans_sub(false, e)) (Sm5x.MALLOC::Sm5x.CALLTR::[]))
       | false => Sm5x.PUSH(Sm5x.Id f)::Sm5x.PUSH(Sm5x.Id f)::(List.append (trans_sub(false, e)) (Sm5x.MALLOC::Sm5x.CALL::[])) )
   | trans_sub(is_tr, K.ADD (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.ADD::[]))
   | trans_sub(is_tr, K.SUB (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.SUB::[]))
   | trans_sub(is_tr, K.MUL (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.MUL::[]))
   | trans_sub(is_tr, K.DIV (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.DIV::[]))
   | trans_sub(is_tr, K.EQUAL (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.EQ::[]))
   | trans_sub(is_tr, K.LESS (e1, e2))= List.append (trans_sub(false, e1)) (List.append (trans_sub(false, e2)) (Sm5x.LESS::[]))
   | trans_sub(is_tr, K.NOT e)= List.append (trans_sub(false, e)) (Sm5x.NOT::[])
   | trans_sub(is_tr, K.ASSIGNV (x, e))= List.append (trans_sub(is_tr, e)) (Sm5x.PUSH(Sm5x.Id x)::Sm5x.STORE::(trans_sub(false, K.UNIT)))
   | trans_sub(is_tr, K.SEQ (e1, e2))= 
     (case (trans_find (e2, e1)) 
      of true=> List.append (trans_sub(is_tr, e1)) (Sm5x.POP::trans_sub(is_tr, e2))
       | false=> List.append (trans_sub(false, e1)) (Sm5x.POP::trans_sub(is_tr, e2)))
   | trans_sub(is_tr, K.IF2 (e1, e2, e3))= List.append (trans_sub(false, e1)) (Sm5x.JTR(trans_sub(is_tr,e2), trans_sub(is_tr,e3))::Sm5x.POP::(trans_sub(false, K.UNIT)))
   | trans_sub(is_tr, K.IF1 (e1, e2))= List.append (trans_sub(false, e1)) (Sm5x.JTR(trans_sub(is_tr,e2), [])::Sm5x.POP::(trans_sub(false, K.UNIT)))
   | trans_sub(is_tr, K.READ x)= Sm5x.GET::Sm5x.PUSH(Sm5x.Id x)::Sm5x.STORE::(trans_sub(false, K.UNIT))
   | trans_sub(is_tr, K.WRITE e)= List.append (trans_sub(false, e)) (Sm5x.PUT::(trans_sub(false, K.UNIT)))
   | trans_sub(is_tr, K.LETV (x, e1, e2))= Sm5x.MALLOC::(Sm5x.BIND x)::(List.append (List.append (trans_sub(false, e1)) (Sm5x.PUSH(Sm5x.Id x)::Sm5x.STORE::[])) (List.append (trans_sub(is_tr, e2)) (Sm5x.UNBIND::Sm5x.POP::[])))
   | trans_sub(is_tr, K.LETF (f, x, e1, e2))= Sm5x.PUSH(Sm5x.Fn(x, (Sm5x.BIND(f)::(trans_sub(true, e1)) )))::Sm5x.BIND(f)::(List.append (trans_sub(is_tr, e2)) (Sm5x.UNBIND::Sm5x.POP::[]))
   | trans_sub(is_tr, K.RECORD [(x, e1), (y, e2)])
     = Sm5x.MALLOC::Sm5x.BIND(x)::(List.append (trans_sub(false, e1)) (Sm5x.PUSH(Sm5x.Id x)::Sm5x.STORE::
       Sm5x.MALLOC::Sm5x.BIND(y)::(List.append (trans_sub(false, e2)) (Sm5x.PUSH(Sm5x.Id y)::Sm5x.STORE::
       Sm5x.UNBIND::Sm5x.UNBIND::Sm5x.BOX(2)::[]))))
   | trans_sub(is_tr, K.RECORD _) = invalid_arg "eval RECORD"
   | trans_sub(is_tr, K.ASSIGNF (e1, x, e2))= List.append (trans_sub(is_tr, e2)) (List.append (trans_sub(is_tr, e1)) (Sm5x.UNBOX(x)::Sm5x.STORE::(trans_sub(false, K.UNIT))))
   | trans_sub(is_tr, K.FIELD (e, x))= List.append (trans_sub(false, e)) (Sm5x.UNBOX(x)::Sm5x.LOAD::[])
   | trans_sub(is_tr, K.MALLOC e)= Sm5x.MALLOC::[]
   | trans_sub(is_tr, K.AMPER x)= Sm5x.PUSH(Sm5x.Id x)::[]
   | trans_sub(is_tr, K.STAR e)= List.append (trans_sub(false, e)) (Sm5x.LOAD::[])
   | trans_sub(is_tr, K.ASSIGNG (e1, e2))= List.append (trans_sub(is_tr, e2)) (List.append (trans_sub(is_tr, e1)) (Sm5x.STORE::(trans_sub(false, K.UNIT))))
   
and trans_find(exp, (K.ASSIGNV (x, e))) = 
    (case exp 
     of K.VAR y => if (x=y) then (case e of K.CALLV(f, e2) => true | _ => false) else false
      | _        => false)
  | trans_find(exp, (K.SEQ (e1, e2))) = 
    if (exp = e2) then trans_find(exp, e1)
    else trans_find(exp, e2)
  | trans_find(exp, (K.IF2 (e1, e2, e3))) = 
    if (trans_find(exp, e2)) then true
    else if (trans_find(exp, e3)) then true
    else false
  | trans_find(exp, (K.IF1 (e1, e2))) = trans_find(exp, e2)
  | trans_find(exp, (K.LETV (x, e1, e2))) = trans_find(exp, e2)
  | trans_find(exp, (K.LETF (f, x, e1, e2))) = trans_find(exp, e2)
  | trans_find(exp, (K.ASSIGNF (e1, x, e2))) = 
    (case exp 
     of K.FIELD(e, y) => if ((x=y) && (exp=e1)) then (case e2 of K.CALLV(f, e3) => true | _ => false) else false
      | _ => false)
  | trans_find(exp, (K.ASSIGNG (e1, e2))) = 
    (case exp 
     of K.STAR e3 => if (e3=e1) then (case e2 of K.CALLV(f, e3) => true | _ => false) else false
      | _ => if (exp=e1) then (case e2 of K.CALLV(f, e3) => true | _ => false) else false)
  | trans_find _ = false