nicball

// 在 http://fsharp.net 上了解有关 F# 的更多信息
// 请参阅“F# 教程”项目以获取更多帮助。

exception TypeError
exception InvalidProgram
exception NonexistedKey

type expr =
    | NumE of int
    | IdE of string
    | AppE of expr * expr
    | LambdaE of string * expr
    | BeginE of stat list
    | SetE of string * expr

and stat =
    | ExprS of expr
    | DefS of string * expr

type builtin =
    | PrintB

type location = Location of int

type env = Env of (string * location) list

type value =
    | NumV of int
    | BuiltinV of builtin
    | UnitV
    | LambdaV of string * expr * env

type store = Store of (location * value) list * int

let rec lookup k = function
    | (xk, xv) :: xs -> if xk = k then xv else lookup k xs
    | [] -> raise NonexistedKey

let lookupEnv k (Env e) = lookup k e

let lookupStore k (Store (s, _)) = lookup k s

let print_value = function
    | NumV n -> printfn "%i" n
    | _ -> raise TypeError

let mt_env = Env [
        ("print", Location 0);
        ("unit", Location 1)
    ]
let mt_store = Store ([
        (Location 0, BuiltinV PrintB);
        (Location 1, UnitV)
    ], 2)

let allocate (Store (xs, count)) =
    let loc = Location count
    (loc, Store ((loc, UnitV) :: xs, count + 1))

let bind id loc (Env e) = Env ((id, loc) :: e)

let set_location loc v (Store (s, c)) = Store ((loc, v) :: s, c)

let rec eval env store = function
    | NumE n -> (NumV n, store)
    | AppE (f, e) ->
        let (fv, store_1) = eval env store f
        let (ev, store_2) = eval env store_1 e
        begin match fv with
        | BuiltinV PrintB -> print_value ev; (UnitV, store_2)
        | LambdaV (id, expr, env_0) ->
            let (loc, store_3) = allocate store_2
            let store_4 = set_location loc ev store_3
            let env_0_1 = bind id loc env_0
            eval env_0_1 store_4 expr
        | _ -> raise TypeError
        end
    | IdE id -> (lookupStore (lookupEnv id env) store, store)
    | BeginE exprs -> run env store UnitV exprs
    | LambdaE (id, expr) -> (LambdaV (id, expr, env), store)
    | SetE (id, expr) ->
        let (v, store_1) = eval env store expr
        let loc = lookupEnv id env
        let store_2 = set_location loc v store_1
        (UnitV, store_2)

and run env store retval = function
    | s :: ss ->
        begin match s with
        | ExprS e ->
            let (v, store_1) = eval env store e
            run env store_1 v ss
        | DefS (id, e) ->
            let (loc, store_1) = allocate store
            let env_1 = bind id loc env
            let (v, store_2) = eval env_1 store_1 e
            let store_3 = set_location loc v store_2
            run env_1 store_3 UnitV ss
        end
    | [] -> (retval, store)

[<EntryPoint>]
let main argv =
    ignore (eval mt_env mt_store (BeginE [
            DefS ("i", NumE 5);
            DefS ("f", (LambdaE ("x", (AppE (IdE "print", IdE "i")))));
            ExprS (AppE (IdE "f", IdE "unit"));
            ExprS (SetE ("i", NumE 6));
            ExprS (AppE (IdE "f", IdE "unit"));
            DefS ("i", NumE 7);
            ExprS (AppE (IdE "f", IdE "unit"));
        ]))
    ignore (System.Console.Read ())
    0 // 返回整数退出代码