open Syntax
open Value

(* 実際の計算をする関数 *)
(* Interpreter with combined arguments : eval7 *)

(* 初期継続 *)
let idc s t = match s with
    SCons (v, SNil) -> 
    begin match t with
        TNil -> v
      | Trail (c, s) -> c (SCons (v, s)) TNil
    end
  | _ -> failwith "stack error"

(* cons : c -> s -> t -> t *)
let rec cons c s t = match t with
    TNil -> Trail (c, s)
  | Trail (c', s') ->
    Trail (
      (fun s t ->
        begin match s with
            SCons (v, SAppend (s, s')) -> c (SCons (v, s)) (cons c' s' t)
          | _ -> failwith "stack error"
        end), 
      SAppend (s, s'))

(* apnd : t -> t -> t *)
let apnd t0 t1 = match t0 with
    TNil -> t1
  | Trail (c, s) -> cons c s t1

(* f7 : e -> string list -> s -> c -> t -> v *)
let rec f7 e xs s c t = match s with
    SCons (VEnv (vs), s) -> 
    begin match e with
        Num (n) -> c (SCons (VNum (n) ,s)) t
      | Var (x) -> c (SCons (List.nth vs (Env.offset x xs), s)) t
      | Op (e0, op, e1) ->
        f7 e0 xs (SCons (VEnv (vs), SCons (VEnv (vs), s))) (fun s0 t0 ->
            begin match s0 with
                (SCons (v0, SCons (VEnv (vs), s))) ->
                f7 e1 xs (SCons (VEnv (vs), SCons (v0, s))) (fun s1 t1 ->
                    begin match s1 with
                        SCons (v1, SCons (v0, s)) ->
                        begin match (v0, v1) with
                            (VNum (n0), VNum (n1)) ->
                            begin match op with
                                Plus -> c (SCons (VNum (n0 + n1), s)) t1
                              | Minus -> c (SCons (VNum (n0 - n1), s)) t1
                              | Times -> c (SCons (VNum (n0 * n1), s)) t1
                              | Divide ->
                                if n1 = 0 then failwith "Division by zero"
                                else c (SCons (VNum (n0 / n1), s)) t1
                            end
                          | _ -> failwith "op is only Num"
                        end
                      | _ -> failwith "stack error"
                    end) t0
              | _ -> failwith "stack error"
            end) t
      | Fun (x, e) ->
        let vfun = VFun (fun s' c' t' ->
            begin match s' with
                SCons (v, s') ->
                f7 e (x :: xs) (SCons (VEnv (v :: vs), s')) c' t'
              | _ -> failwith "stack error"
            end) in
        c (SCons (vfun, s)) t
      | App (e0, e1) ->
        f7 e0 xs (SCons (VEnv (vs), SCons (VEnv (vs), s))) (fun s0 t0 ->
            begin match s0 with
                SCons (v0, SCons (VEnv (vs), s)) ->
                f7 e1 xs (SCons (VEnv (vs), SCons (v0, s))) (fun s1 t1 ->
                    begin match s1 with
                        SCons (v1, SCons (v0, s)) ->
                        begin match v0 with
                            VFun (f) -> f (SCons (v1, s)) c t1
                          | VCont (c', s', t') ->
                            c' (SCons (v1, s')) (apnd t' (cons c s t1))
                          | _ -> failwith "not app"
                        end
                      | _ -> failwith "stack error"
                    end) t0
              | _ -> failwith "stack error"
            end) t
      | Control (x, e) ->
        f7 e (x :: xs) (SCons (VEnv (VCont (c, s, t) :: vs), SNil)) idc TNil
      | Prompt (e) ->
        c (SCons (f7 e xs (SCons (VEnv (vs), SNil)) idc TNil, s)) t
    end
  | _ -> failwith "stack error"

(* f : e -> v *)
let f expr = f7 expr [] (SCons (VEnv ([]), SNil)) idc TNil