ljs_cesk.ml

open Ljs_delta
open Ljs_pretty
open Ljs_values
open Prelude

module S = Ljs_syntax
module K = Ljs_kont

let interp_error pos message =
  raise (PrimErr ([], String ("[interp] (" ^ Pos.string_of_pos pos ^ ") " ^ message)))

(* Machine-specific closures *)
type closure =
  | ExpClosure of S.exp * env
  | ValClosure of value * env
  | PEClosure of S.prop * env
  | PVClosure of propv * env ;;

let exp_of clos = match clos with
  | ExpClosure (expr, _) -> Some expr
  | _ -> None
let env_of clos = match clos with
  | ExpClosure (_, env) -> Some env
  | _ -> None
let add_opt clos xs f = match f clos with
  | Some x -> x::xs
  | None -> xs

(* from ljs_eval, let's move these to a util file eventuallly *)
let rec get_attr store attr obj field = match obj, field with
  | ObjLoc loc, String s -> let (attrs, props) = get_obj store loc in
      if (not (IdMap.mem s props)) then
        undef
      else
        begin match (IdMap.find s props), attr with
          | Data (_, _, config), S.Config
          | Accessor (_, _, config), S.Config -> bool config
          | Data (_, enum, _), S.Enum
          | Accessor (_, enum, _), S.Enum -> bool enum
          | Data ({ writable = b; }, _, _), S.Writable -> bool b
          | Data ({ value = v; }, _, _), S.Value -> v
          | Accessor ({ getter = gv; }, _, _), S.Getter -> gv
          | Accessor ({ setter = sv; }, _, _), S.Setter -> sv
          | _ -> interp_error Pos.dummy "bad access of attribute"
        end
  | _ -> failwith ("[interp] get-attr didn't get an object and a string.")

let unbool b = match b with
  | True -> true
  | False -> false
  | _ -> failwith ("tried to unbool a non-bool" ^ (pretty_value b))

let rec set_attr (store : store) attr obj field newval = match obj, field with
  | ObjLoc loc, String f_str -> begin match get_obj store loc with
      | ({ extensible = ext; } as attrsv, props) ->
        if not (IdMap.mem f_str props) then
          if ext then
            let newprop = match attr with
              | S.Getter ->
                Accessor ({ getter = newval; setter = Undefined; },
                          false, false)
              | S.Setter ->
                Accessor ({ getter = Undefined; setter = newval; },
                          false, false)
              | S.Value ->
                Data ({ value = newval; writable = false; }, false, false)
              | S.Writable ->
                Data ({ value = Undefined; writable = unbool newval },
                      false, false)
              | S.Enum ->
                Data ({ value = Undefined; writable = false },
                      unbool newval, true)
              | S.Config ->
                Data ({ value = Undefined; writable = false },
                      true, unbool newval) in
            let store = set_obj store loc
                  (attrsv, IdMap.add f_str newprop props) in
            true, store
          else
            failwith "[interp] Extending inextensible object ."
        else
        (* 8.12.9: "If a field is absent, then its value is considered
        to be false" -- we ensure that fields are present and
        (and false, if they would have been absent). *)
          let newprop = match (IdMap.find f_str props), attr, newval with
            (* S.Writable true -> false when configurable is false *)
            | Data ({ writable = true } as d, enum, config), S.Writable, new_w ->
              Data ({ d with writable = unbool new_w }, enum, config)
            | Data (d, enum, true), S.Writable, new_w ->
              Data ({ d with writable = unbool new_w }, enum, true)
            (* Updating values only checks writable *)
            | Data ({ writable = true } as d, enum, config), S.Value, v ->
              Data ({ d with value = v }, enum, config)
            (* If we had a data property, update it to an accessor *)
            | Data (d, enum, true), S.Setter, setterv ->
              Accessor ({ getter = Undefined; setter = setterv }, enum, true)
            | Data (d, enum, true), S.Getter, getterv ->
              Accessor ({ getter = getterv; setter = Undefined }, enum, true)
            (* Accessors can update their getter and setter properties *)
            | Accessor (a, enum, true), S.Getter, getterv ->
              Accessor ({ a with getter = getterv }, enum, true)
            | Accessor (a, enum, true), S.Setter, setterv ->
              Accessor ({ a with setter = setterv }, enum, true)
            (* An accessor can be changed into a data property *)
            | Accessor (a, enum, true), S.Value, v ->
              Data ({ value = v; writable = false; }, enum, true)
            | Accessor (a, enum, true), S.Writable, w ->
              Data ({ value = Undefined; writable = unbool w; }, enum, true)
            (* enumerable and configurable need configurable=true *)
            | Data (d, _, true), S.Enum, new_enum ->
              Data (d, unbool new_enum, true)
            | Data (d, enum, true), S.Config, new_config ->
              Data (d, enum, unbool new_config)
            | Data (d, enum, false), S.Config, False ->
              Data (d, enum, false)
            | Accessor (a, enum, true), S.Config, new_config ->
              Accessor (a, enum, unbool new_config)
            | Accessor (a, enum, true), S.Enum, new_enum ->
              Accessor (a, unbool new_enum, true)
            | Accessor (a, enum, false), S.Config, False ->
              Accessor (a, enum, false)
            | _ -> raise (PrimErr ([], String ("[interp] bad property set "
                    ^ (pretty_value obj) ^ " " ^ f_str ^ " " ^
                    (S.string_of_attr attr) ^ " " ^ (pretty_value newval))))
        in begin
            let store = set_obj store loc
              (attrsv, IdMap.add f_str newprop props) in
            true, store
        end
  end
  | _ -> failwith ("[interp] set-attr didn't get an object and a string")

let get_obj_attr attrs attr = match attrs, attr with
  | { proto=proto }, S.Proto -> proto
  | { extensible=extensible} , S.Extensible -> bool extensible
  | { code=Some code}, S.Code -> code
  | { code=None}, S.Code -> Null
  | { primval=Some primval}, S.Primval -> primval
  | { primval=None}, S.Primval ->
      failwith "[interp] Got Primval attr of None"
  | { klass=klass }, S.Klass -> String klass

let rec get_prop p store obj field =
  match obj with
    | Null -> None
    | ObjLoc loc -> begin match get_obj store loc with
      | { proto = pvalue; }, props ->
        try Some (IdMap.find field props)
        with Not_found -> get_prop p store pvalue field
    end
    | _ -> failwith (interp_error p
                     "get_prop on a non-object.  The expression was (get-prop "
                     ^ pretty_value obj
                     ^ " " ^ field ^ ")")

(* end borrowed ljs_eval helpers *)

let rec eval_cesk desugar clos store kont : (value * store) =
  let eval clos store kont =
    begin try eval_cesk desugar clos store kont with
    | Break (exprs, l, v, s) ->
      raise (Break (add_opt clos exprs exp_of, l, v, s))
    | Throw (exprs, v, s) ->
      raise (Throw (add_opt clos exprs exp_of, v, s))
    | PrimErr (exprs, v) ->
      raise (PrimErr (add_opt clos exprs exp_of, v))
    | Snapshot (exps, v, envs, s) ->
      raise (Snapshot (add_opt clos exps exp_of, v, add_opt clos envs env_of, s))
    | Sys.Break ->
      raise (PrimErr (add_opt clos [] exp_of, String "s5_cesk_eval stopped by user interrupt"))
    | Stack_overflow ->
      raise (PrimErr (add_opt clos [] exp_of, String "s5_cesk_eval overflowed the Ocaml stack"))
    end in
  let rec apply p store func args = match func with
    | Closure (env, xs, body) ->
      let alloc_arg argval argname (store, env) =
        let (new_loc, store) = add_var store argval in
        let env' = IdMap.add argname new_loc env in
        (store, env') in
      if (List.length args) != (List.length xs) then
        arity_mismatch_err p xs args
      else
        let (store, env) = (List.fold_right2 alloc_arg args xs (store, env)) in
        (body, env, store)
    | ObjLoc loc -> begin match get_obj store loc with
        | ({ code = Some f }, _) -> apply p store f args
        | _ -> failwith "Applied an object without a code attribute"
    end
    | _ -> failwith (interp_error p
                       ("Applied non-function, was actually " ^
                         pretty_value func)) in
  match clos, kont with
  | ValClosure (valu, env), K.Mt -> (valu, store)
  (* value cases *)
  | ExpClosure (S.Undefined _, env), _ ->
    eval (ValClosure (Undefined, env)) store kont
  | ExpClosure (S.Null _, env), _ ->
    eval (ValClosure (Null, env)) store kont
  | ExpClosure (S.String (_, s), env), _ ->
    eval (ValClosure (String s, env)) store kont
  | ExpClosure (S.Num (_, n), env), _ ->
    eval (ValClosure (Num n, env)) store kont
  | ExpClosure (S.True _, env), _ ->
    eval (ValClosure (True, env)) store kont
  | ExpClosure (S.False _, env), _ ->
    eval (ValClosure (False, env)) store kont
  | ExpClosure (S.Id (p, name), env), _ ->
    (try
      let valu = get_var store (IdMap.find name env) in
      eval (ValClosure (valu, env)) store kont
    with Not_found ->
      failwith ("[interp] Unbound identifier: " ^ name ^ " in identifier lookup at " ^
                   (Pos.string_of_pos p)))
  | ExpClosure (S.Lambda (_, xs, body), env), k -> (* should we remove the env' from Closure? *)
    let free = S.free_vars body in
    let env' = IdMap.filter (fun var _ -> IdSet.mem var free) env in
    eval (ValClosure (Closure (env', xs, body), env')) store k
  (* SetBang cases *)
  (* TODO(adam): error cases for non-existent id's *)
  | ExpClosure (S.SetBang (_, x, exp'), env), k ->
    eval (ExpClosure (exp', env)) store (K.SetBang (IdMap.find x env, k))
  | ValClosure (v, env), K.SetBang (loc, k) ->
    let store' = set_var store loc v in
    eval (ValClosure (v, env)) store' k
  (* Object cases *)
  | ExpClosure (S.Object (p, attrs, props), env), k ->
    begin
      let { S.primval = primexp; (* Opt *)
            S.code = codexp;     (* Opt *)
            S.proto = protoexp;  (* Opt *)
            S.extensible = ext;
            S.klass = kls; } = attrs in match primexp with
        (* we have a primexp, we can evaluate it *)
        | Some primexp ->
          (eval (ExpClosure (primexp, env))
                store
                (K.Object (None, codexp, None, protoexp, None, None, ext, kls, props, [])))
        (* no primexp, see if we have a codexp *)
        | _ -> match codexp with
            | Some codexp ->
              (eval (ExpClosure (codexp, env))
                    store
                    (K.Object (None, None, None, protoexp, None, None, ext, kls, props, [])))
            (* no primexp or codexp, jump straight to protoexp which we can represent as
               Undefined if we have none. *)
            | _ -> match protoexp with
                | Some protoexp ->
                  (eval (ExpClosure (protoexp, env))
                        store
                        (K.Object (None, None, None, None, None, None, ext, kls, props, [])))
                | _ ->
                  (* where do we go from here?
                     gotta keep from duplicating this match effort *)
                  (eval (ValClosure (Undefined, env))
                        store
                        (K.Object (None, None, None, None, Some Undefined, None, ext, kls, props, [])))

    end

(*  | ValClosure (p_val, env),
    K.Object (None, Some protoexp, None, codexp, None, None, ext, kls, props, propvs) ->
    begin match protoexp with
      | Some 
    (eval (ExpClosure (protoexp, env))
          store
          (K.Object (Some p_val, None, None, codexp, None, None, ext, kls, props, propvs)))

  | ValClosure (proto_val, env),
      K.Object (p_val, None, None, Some codexp, None, None, ext, kls, props, propvs) ->
    (eval (ExpClosure (codexp, env))
          store
          (K.Object (p_val, None, Some proto_val, None, None, None, ext, kls, props, propvs)))
    *)
(*  | ValClosure (code_val, env),
    K.Object (Some p_val, None, Some proto_val, None,
              None, None, ext, kls, props, propvs) ->
    let attrsv = {
      code=code_val; proto=proto_val; primval=p_val;
      extensible=ext; klass=kls; } in
    eval (PEClosure (props, env)) store *)

  (* Prop Cases *)

  (* GetAttr *)
  (* better way to do this? it's non-exhaustive, but shouldn't be an issue we
     we are guaranteeing left to right evaluation on the obj / field *)
  | ExpClosure (S.GetAttr (p, attr, obj, field), env), k ->
    eval (ExpClosure (obj, env)) store (K.GetAttr (attr, None, Some field, k))
  | ValClosure (obj_val, env), K.GetAttr (attr, None, Some field, k) ->
    eval (ExpClosure (field, env)) store (K.GetAttr (attr, Some obj_val, None, k))
  | ValClosure (field_val, env), K.GetAttr (attr, Some obj_val, None, k) ->
    eval (ValClosure (get_attr store attr obj_val field_val, env)) store k
  (* SetAttr Cases *)
  | ExpClosure (S.SetAttr (_, pattr, oe, pe, new_val_expr), env), k ->
    eval (ExpClosure (oe, env)) store (K.SetAttr (pattr, None, Some pe, None, Some new_val_expr, k))
  | ValClosure (oe_val, env), K.SetAttr (pattr, None, Some pe, None, Some new_val_expr, k) ->
    eval (ExpClosure (pe, env)) store (K.SetAttr (pattr, Some oe_val, None, None, Some new_val_expr, k))
  | ValClosure (pe_val, env), K.SetAttr (pattr, Some oe_val, None, None, Some new_val_expr, k) ->
    eval (ExpClosure (new_val_expr, env)) store (K.SetAttr (pattr, Some oe_val, None, Some pe_val, None, k))
  | ValClosure (new_val, env), K.SetAttr (pattr, Some oe_val, None, Some pe_val, None, k) ->
    let b, store = set_attr store pattr oe_val pe_val new_val in
    eval (ValClosure (bool b, env)) store k
  (* GetObjAttr Cases *)
  | ExpClosure (S.GetObjAttr (_, oattr, obj), env), k ->
    eval (ExpClosure (obj, env)) store (K.GetObjAttr (oattr, k))
  | ValClosure (obj_val, env), K.GetObjAttr (oattr, k) ->
    begin match obj_val with
      | ObjLoc obj_loc ->
        let (attrs, _) = get_obj store obj_loc in
        eval (ValClosure (get_obj_attr attrs oattr, env)) store k
      | _ -> failwith ("[interp] GetObjAttr got a non-object: " ^
                          (pretty_value obj_val))
    end
  (* SetObjAttr Cases *)
  | ExpClosure (S.SetObjAttr (_, oattr, obj_exp, na_exp), env), k ->
    eval (ExpClosure (obj_exp, env)) store (K.SetObjAttr (oattr, None, Some na_exp, k))
  | ValClosure (obj_val, env), K.SetObjAttr (oattr, None, Some na_exp, k) ->
    eval (ExpClosure (na_exp, env)) store (K.SetObjAttr (oattr, Some obj_val, None, k))
  | ValClosure (na_val, env), K.SetObjAttr (oattr, Some obj_val, None, k) ->
    begin match obj_val with
      | ObjLoc loc ->
        let (attrs, props) = get_obj store loc in
        let attrs' = match oattr, na_val with
          | S.Proto, ObjLoc _
          | S.Proto, Null -> { attrs with proto=na_val }
          | S.Proto, _ ->
            failwith ("[interp] Update proto failed: " ^
                       (pretty_value na_val))
          | S.Extensible, True -> { attrs with extensible=true }
          | S.Extensible, False -> { attrs with extensible=false }
          | S.Extensible, _ ->
            failwith ("[interp] Update extensible failed: " ^
                       (pretty_value na_val))
          | S.Code, _ -> failwith "[interp] Can't update Code"
          | S.Primval, v -> { attrs with primval=Some v }
          | S.Klass, _ -> failwith "[interp] Can't update Klass" in
        eval (ValClosure (na_val, env)) (set_obj store loc (attrs', props)) k
      | _ -> failwith ("[interp] SetObjAttr got a non-object: " ^
                        (pretty_value obj_val))
    end
  (* GetField cases *)
  | ExpClosure (S.GetField (p, obj, field, body), env), k ->
    eval (ExpClosure (obj, env)) store (K.GetField (p, None, Some field, None, Some body, k))
  | ValClosure (obj_val, env), K.GetField (p, None, Some field, None, Some body, k) ->
    (eval (ExpClosure (field, env))
          store
          (K.GetField (p, Some obj_val, None, None, Some body, k)))
  | ValClosure (field_val, env), K.GetField (p, obj_val, None, None, Some body, k) ->
    (eval (ExpClosure (body, env))
          store
          (K.GetField (p, obj_val, None, Some field_val, None, k)))
  | ValClosure (body_val, env),
    K.GetField (p, Some obj_val, None, Some field_val, None, k) ->
    begin match (obj_val, field_val) with
      | (ObjLoc _, String s) ->
        let prop = get_prop p store obj_val s in
        begin match prop with
          | Some (Data ({value=v;}, _, _)) -> eval (ValClosure (v, env)) store k
          | Some (Accessor ({getter=g;},_,_)) ->
            let (body, env', store') = (apply p store g [obj_val; body_val]) in
            eval (ExpClosure (body, env')) store' k
          | None -> eval (ValClosure (Undefined, env)) store k
        end
      | _ -> failwith ("[interp] Get field didn't get an object and a string at "
                       ^ Pos.string_of_pos p ^ ". Instead, it got "
                       ^ pretty_value obj_val ^ " and "
                       ^ pretty_value field_val)
    end
  (* own field names cases *)
  | ExpClosure (S.OwnFieldNames (p, obj), env), k ->
    eval (ExpClosure (obj, env)) store (K.OwnFieldNames k)
  | ValClosure (obj_val, env), K.OwnFieldNames k ->
    begin match obj_val with
    | ObjLoc loc ->
      let _, props = get_obj store loc in
      let add_name n x m =
        IdMap.add (string_of_int x) (Data ({ value = String n; writable = false; }, false, false)) m in
      let names = IdMap.fold (fun k v l -> (k :: l)) props [] in
      let props = List.fold_right2 add_name names (iota (List.length names)) IdMap.empty in
      let d = float_of_int (List.length names) in
      let final_props =
        IdMap.add "length" (Data ({ value = Num d; writable = false; }, false, false)) props in
      let (new_obj, store) = add_obj store (d_attrsv, final_props) in
      eval (ValClosure (ObjLoc new_obj, env)) store k
    | _ -> failwith ("[interp] OwnFieldNames didn't get an object," ^
                  " got " ^ (pretty_value obj_val) ^ " instead.")
    end
  (* delete field cases *)
  | ExpClosure (S.DeleteField (p, obj, field), env), k ->
    eval (ExpClosure (obj, env)) store (K.DeleteField (p, None, Some field, k))
  | ValClosure (valu, env), K.DeleteField (p, None, Some field, k) ->
    eval (ExpClosure (field, env)) store (K.DeleteField (p, Some valu, None, k))
  | ValClosure (f_val, env), K.DeleteField (p, Some obj_val, None, k) ->
    begin match obj_val, f_val with
    | ObjLoc loc, String s ->
      begin match get_obj store loc with
      | attrs, props ->
        begin
          try match IdMap.find s props with
          | Data (_, _, true)
          | Accessor (_, _, true) ->
            let store' = set_obj store loc (attrs, IdMap.remove s props) in
            eval (ValClosure (True, env)) store' k
          | _ -> raise (Throw ([], String "unconfigurable-delete", store))
          with Not_found -> eval (ValClosure (False, env)) store k
        end
      end
    | _ -> failwith ("[interp] Delete field didn't get an object and a string at "
                     ^ Pos.string_of_pos p
                     ^ ". Instead, it got "
                     ^ pretty_value obj_val
                     ^ " and "
                     ^ pretty_value f_val)
    end
  (* SetField Cases *)
  | ExpClosure (S.SetField (p, obj, field, nf_exp, body), env), k ->
    (eval (ExpClosure (obj, env))
          store
          (K.SetField (p, None, Some field, None, Some nf_exp, None, Some body, k)))
  | ValClosure (obj_val, env),
    K.SetField (p, None, Some field, None, nf_exp, None, body, k) ->
    (eval (ExpClosure (field, env))
          store
          (K.SetField (p, Some obj_val, None, None, nf_exp, None, body, k)))
  | ValClosure (field_val, env),
    K.SetField (p, obj_val, None, None, Some nf_exp, None, body, k) ->
    (eval (ExpClosure (nf_exp, env))
          store
          (K.SetField (p, obj_val, None, Some field_val, None, None, body, k)))
  | ValClosure (nf_val, env),
    K.SetField (p, obj_val, None, field_val, None, None, Some body, k) ->
    (eval (ExpClosure (body, env))
          store
          (K.SetField (p, obj_val, None, field_val, None, Some nf_val, None, k)))
  | ValClosure (body_val, env),
    K.SetField (p, Some obj_val, None, Some field_val, None, Some nf_val, None, k) ->
    begin match (obj_val, field_val) with
      | (ObjLoc loc, String s) ->
        let ({extensible=extensible;} as attrs, props) =
          get_obj store loc in
        let prop = get_prop p store obj_val s in
        let unwritable = (Throw ([],
                                 String "unwritable-field",
                                 store)) in
        begin match prop with
          | Some (Data ({ writable = true; }, enum, config)) ->
            let (enum, config) =
              if (IdMap.mem s props)
              then (enum, config) (* 8.12.5, step 3, changing the value of a field *)
              else (true, true) in (* 8.12.4, last step where inherited.[[writable]] is true *)
            let store = set_obj store loc
              (attrs,
               IdMap.add s
                 (Data ({ value = nf_val; writable = true },
                        enum, config))
                 props) in
            eval (ValClosure (nf_val, env)) store k
          | Some (Data _) -> raise unwritable
          | Some (Accessor ({ setter = Undefined; }, _, _)) ->
            raise unwritable
          | Some (Accessor ({ setter = setterv; }, _, _)) ->
                (* 8.12.5, step 5 *)
            let (body, env', store') = apply p store setterv [obj_val; body_val] in
            eval (ExpClosure (body, env')) store' k
          | None ->
                (* 8.12.5, step 6 *)
            if extensible
            then
              let store = set_obj store loc
                (attrs,
                 IdMap.add s
                   (Data ({ value = nf_val; writable = true; },
                          true, true))
                   props) in
              eval (ValClosure (nf_val, env)) store k
            else
              eval (ValClosure (Undefined, env)) store k
        end
      | _ -> failwith ("[interp] Update field didn't get an object and a string"
                       ^ Pos.string_of_pos p ^ " : " ^ (pretty_value obj_val) ^
                         ", " ^ (pretty_value field_val))
    end
  (* Op1 cases *)
  | ExpClosure (S.Op1 (_, name, arg), env), k ->
    eval (ExpClosure (arg, env)) store (K.Op1 (name, k))
  | ValClosure (arg_val, env), K.Op1 (name, k) ->
    eval (ValClosure (op1 store name arg_val, env)) store k
  (* Op2 cases *)
  | ExpClosure (S.Op2 (_, name, arg1, arg2), env), k ->
    eval (ExpClosure (arg1, env)) store (K.Op2 (name, None, Some arg2, k))
  | ValClosure (arg1_val, env), K.Op2 (name, None, Some arg2, k) ->
    eval (ExpClosure (arg2, env)) store (K.Op2 (name, Some arg1_val, None, k))
  | ValClosure (arg2_val, env), K.Op2 (name, Some arg1_val, None, k) ->
    eval (ValClosure (op2 store name arg1_val arg2_val, env)) store k
  (* If cases *)
  | ExpClosure (S.If (_, pred, than, elze), env), k ->
    eval (ExpClosure (pred, env)) store (K.If (env, than, elze, k))
  | ValClosure (v, env), K.If (env', than, elze, k) ->
    if (v = True)
    then eval (ExpClosure (than, env')) store k
    else eval (ExpClosure (elze, env')) store k
  (* App cases *)
  | ExpClosure (S.App (pos, func, args), env), k ->
    eval (ExpClosure (func, env)) store (K.App (pos, None, env, [], args, k))
  | ValClosure (func, _), K.App (pos, None, _, vals, [], k) -> (* special case for no arg apps *)
    let (body, env', store') = apply pos store func vals in
    eval (ExpClosure (body, env')) store' k
  | ValClosure (func, _), K.App (pos, None, env, vs, expr::exprs, k) ->
    eval (ExpClosure (expr, env)) store (K.App (pos, Some func, env, vs, exprs, k))
  | ValClosure (arg_val, _), K.App (pos, Some func, env, vs, expr::exprs, k) ->
    eval (ExpClosure (expr, env)) store (K.App (pos, Some func, env, arg_val::vs, exprs, k))
  | ValClosure (arg_val, _), K.App (pos, Some func, env, vs, [], k) ->
    let (body, env', store') = apply pos store func (arg_val::vs) in (* may need to reverse this list *)
    eval (ExpClosure (body, env')) store' k
  (* sequence (begin) cases *)
  | ExpClosure (S.Seq (_, left, right), env), k ->
    eval (ExpClosure (left, env)) store (K.Seq (right, k))
  | ValClosure (_, env), K.Seq (right, k) ->
    eval (ExpClosure (right, env)) store k
  (* let cases *)
  | ExpClosure (S.Let (_, name, expr, body), env), k ->
    eval (ExpClosure (expr, env)) store (K.Let (name, body, k))
  | ValClosure (v, env), K.Let (name, body, k) ->
    let (new_loc, store') = add_var store v in
    eval (ExpClosure (body, IdMap.add name new_loc env)) store' k
  (* letrec cases *)
  | ExpClosure (S.Rec (_, name, expr, body), env), k ->
    let (new_loc, store') = add_var store Undefined in
    let env' = IdMap.add name new_loc env in
    eval (ExpClosure (expr, env')) store' (K.Rec (new_loc, body, k))
  | ValClosure (v, env), K.Rec (new_loc, body, k) ->
    eval (ExpClosure (body, env)) (set_var store new_loc v) k
  (* Label case, just creates a try that we can break to. Should control flow
     rely on OCaml's control flow? *)
  | ExpClosure (S.Label (_, name, exp), env), k ->
    (try
      eval (ExpClosure (exp, env)) store k
    with Break (t, l', v, store') ->
      if name = l' then (v, store')
      else raise (Break (t, l', v, store')))
  (* break cases, see details in label case for future work *)
  | ExpClosure (S.Break (_, label, expr), env), k ->
    eval (ExpClosure (expr, env)) store (K.Break (label, k))
  | ValClosure (v, _), K.Break (label, _) ->
    raise (Break ([], label, v, store))
  (* try catch *)
  | ExpClosure (S.TryCatch (pos, body, catch), env), k ->
    (try
      eval (ExpClosure (body, env)) store k
    with Throw (_, valu, store) ->
      eval (ExpClosure (catch, env)) store (K.TryCatch (pos, catch, env, valu, k)))
  | ValClosure (valu, _), K.TryCatch (pos, catch, env, throw_val, k) ->
    let (body, env', store') = apply pos store valu [throw_val] in
    eval (ExpClosure (body, env')) store' k
  (* try finally. the semantics below will throw errors which occur during the evaluation
     of the finally clause up, as is the expected? functionality, which is inconsistent with
     the original eval *)
  | ExpClosure (S.TryFinally (_, body, fin), env), k ->
    (try
       eval (ExpClosure (body, env)) store (K.TryFinally (Some fin, env, None, k))
     with
     | except ->
       eval (ExpClosure (fin, env)) store (K.TryFinally (None, env, Some except, k)))
  | ValClosure (valu, env'), K.TryFinally (Some fin, env, None, k) -> (* now evaluate the fin *)
    eval (ExpClosure (fin, env)) store k
  | ValClosure (valu, env'), K.TryFinally (None, env, Some except, k) ->
    (match except with
    | Throw (t, v, _) -> raise (Throw (t, v, store))
    | Break (t, l, v, _) -> raise (Break (t, l, v, store)))
  (* lob those exceptions *)
  | ExpClosure (S.Throw (_, expr), env), k ->
    eval (ExpClosure (expr, env)) store K.Throw
  | ValClosure (valu, env), K.Throw ->
    raise (Throw ([], valu, store))
  (* eval *)
  | ExpClosure (S.Eval (pos, str_expr, bindings), env), k ->
    eval (ExpClosure (str_expr, env)) store (K.Eval (pos, None, Some bindings, store, k))
  | ValClosure (valu, env), K.Eval (pos, None, Some bindings, store', k) ->
    eval (ExpClosure (bindings, env)) store (K.Eval (pos, Some valu, None, store', k))
  | ValClosure (bind_val, env), K.Eval (pos, Some str_val, None, store', k) ->
    (match str_val, bind_val with
    | String s, ObjLoc o ->
      let expr = desugar s in
      let env', store'' = envstore_of_obj pos (get_obj store o) store in
      eval (ExpClosure (expr, env')) store'' (K.Eval (pos, None, None, store', k))
    | String _, _ -> interp_error pos "Non-object given to eval() for env"
    | v, _ -> eval (ValClosure (v, env)) store' k)
  | ValClosure (valu, env), K.Eval (_, None, None, store', k) ->
    eval (ValClosure (valu, env)) store' k
  (* hints, we raise a snapshot if that's what we need to do, otherwise we
     just continue evaluation *)
  | ExpClosure (S.Hint (_, "___takeS5Snapshot", expr), env), k ->
    eval (ExpClosure (expr, env)) store K.Hint
  | ExpClosure (S.Hint (_, _, expr), env), k ->
    eval (ExpClosure (expr, env)) store k
  | ValClosure (valu, env), K.Hint ->
    raise (Snapshot ([], valu, [], store))

and envstore_of_obj p (_, props) store =
  IdMap.fold (fun id prop (env, store) -> match prop with
    | Data ({value=v}, _, _) ->
      let new_loc, store = add_var store v in
      let env = IdMap.add id new_loc env in
      env, store
    | _ -> interp_error p "Non-data value in env_of_obj")
  props (IdMap.empty, store)

and arity_mismatch_err p xs args = interp_error p ("Arity mismatch, supplied " ^ string_of_int (List.length args) ^ " arguments and expected " ^ string_of_int (List.length xs) ^ ". Arg names were: " ^ (List.fold_right (^) (map (fun s -> " " ^ s ^ " ") xs) "") ^ ". Values were: " ^ (List.fold_right (^) (map (fun v -> " " ^ pretty_value v ^ " ") args) ""))

(*and eval_prop prop store = match prop with
  | S.Data ({ S.value = vexp; S.writable = w; }, enum, config) ->
    let vexp, store = eval (ExpClosure (vexp, env) store in
    Data ({ value = vexp; writable = w; }, enum, config), store
  | S.Accessor ({ S.getter = ge; S.setter = se; }, enum, config) ->
    let gv, store = eval ge env store in
    let sv, store = eval se env store in
    Accessor ({ getter = gv; setter = sv}, enum, config), store
*)
let err show_stack trace message =
  if show_stack then begin
      eprintf "%s\n" (string_stack_trace trace);
      eprintf "%s\n" message;
      failwith "Runtime error"
    end
  else
    eprintf "%s\n" message;
    failwith "Runtime error"

(*
(*     expr => Ljs_syntax.exp
    desugar => (string -> Ljs_syntax.exp)
print_trace => bool
        env => IdMap
      store => (Store, Store)
               where the left is for objects and
               the right is for values            *)
let continue_eval expr desugar print_trace env store = try
  Sys.catch_break true;
  let (v, store) = eval desugar expr env store in
  Answer ([], v, [], store)
with
  | Snapshot (exprs, v, envs, store) ->
    Answer (exprs, v, envs, store)
  | Throw (t, v, store) ->
      let err_msg =
        match v with
          | ObjLoc loc -> begin match get_obj store loc with
            | _, props -> try match IdMap.find "%js-exn" props with
              | Data ({value=jserr}, _, _) -> string_of_value jserr store
              | _ -> string_of_value v store
              with Not_found -> string_of_value v store
            end
          | v -> string_of_value v store in
        err print_trace t (sprintf "Uncaught exception: %s\n" err_msg)
  | Break (p, l, v, _) -> failwith ("Broke to top of execution, missed label: " ^ l)
  | PrimErr (t, v) ->
      err print_trace t (sprintf "Uncaught error: %s\n" (pretty_value v))

(*     expr => Ljs_syntax.exp
    desugar => (string -> Ljs_syntax.exp)
print_trace => bool                       *)
let eval_expr expr desugar print_trace =
  continue_eval expr desugar print_trace IdMap.empty (Store.empty, Store.empty)
*)