Untitled

(* File: one_step_exp_cps_eval.ml *)

open Common;;

let rec app_exn_handler env ex_k i = (match ex_k with 
  | ExnContVarCPS exi -> (match lookup_exn_cont env exi with 
    | None -> Failed 
    | Some (_k, _env) -> app_exn_handler _env _k i
  )
  | EmptyExnContCPS -> UncaughtException i
  | UpdateExnContCPS (l, _k) -> 
    let rec find_ex l i = (match l with 
      | [] -> app_exn_handler env _k i 
      | (None, v)::rem -> Intermediate (env, v) 
      | (n, v)::rem -> if n = Some i then Intermediate (env, v) else find_ex rem i 
    ) in find_ex l i 
)

let rec app_cont_to_value env k v = match k with 
  | External -> Final v
  | ContVarCPS (_k) -> (match lookup_cont env _k with 
    | None -> Failed 
    | Some (_k, _env) -> app_cont_to_value _env _k v)
  | FnContCPS (y, e) -> Intermediate((ValueBinding (y, v))::env, e)
  | ExnMatch ex_k -> (match v with 
    | IntVal i -> app_exn_handler env ex_k i 
    | _ -> Failed
  )


let rec one_step_exp_cps_eval env exp_cps = match exp_cps with 
  | ConstCPS (k, c) -> app_cont_to_value env k (const_to_val c)
  | VarCPS (k, x) -> (match lookup_value env x with | None -> Failed | Some v -> app_cont_to_value env k v)
  | MonOpAppCPS (k, op, x, e) -> (match lookup_value env x with 
    | None -> Failed 
    | Some v -> (match monOpApply op v with 
      | Exn n -> app_exn_handler env e n
      | Value v' -> app_cont_to_value env k v'
      ) 
    )
  | BinOpAppCPS (k, op, x, y, e) -> (match (lookup_value env x, lookup_value env y) with 
    | None, None | None, _ | _, None -> Failed 
    | Some v1, Some v2 -> (match binOpApply op v1 v2 with 
      | Exn n -> app_exn_handler env e n 
      | Value v -> app_cont_to_value env k v 
      )
    )
  | IfCPS (b, e1, e2) -> (match lookup_value env b with 
      | Some (BoolVal true) -> Intermediate (env, e1)
      | Some (BoolVal false) -> Intermediate (env, e2)
      | _ -> Failed
    )
  | FunCPS (k, x, ek, e, p) -> app_cont_to_value env k (CPSClosureVal (x, ek, e, p, env))
  | FixCPS (k, f, x, ek, e, p) -> app_cont_to_value env k (CPSRecClosureVal (f, x, ek, e, p, env))
  | AppCPS (k, f, x, eps) -> (match lookup_value env x with 
    | Some v -> (match lookup_value env f with 
      | None -> Failed 
      | Some CPSClosureVal (y, fk, ek, e, p') -> 
          Intermediate (ValueBinding(y, v)::ContBinding(fk, (k, env))::ExnContBinding(ek, (eps, env))::p', e)
      | Some CPSRecClosureVal (g, y, fk, ek, e, p') -> 
          Intermediate (ValueBinding(y, v)::ValueBinding(g, (CPSRecClosureVal (g, y, fk, ek, e, p')))::ContBinding(fk, (k, env))::ExnContBinding(ek, (eps, env))::p', e)
      | _ -> Failed
      )
    | _ -> Failed 
    )
  | _ -> Failed