(* 03-02-05.sml *)

(* ********** *)

(* Source abstract syntax: *)

structure Expr
= struct
    type ide = string
    datatype expr = LIT of int
                  | VAR of ide
                  | LAM of ide * expr
                  | APP of expr * expr
    type program = expr
    (* A program is a closed expression. *)
  end;

(* ********** *)

(* Environment: *)

signature ENV
= sig
    type 'a env
    exception UNDECLARED
    val empty : 'a env
    val extend : Expr.ide * 'a * 'a env -> 'a env
    val lookup : Expr.ide * 'a env -> 'a
  end;

structure Env : ENV
= struct
    type 'a env = (Expr.ide * 'a) list

    val empty = nil

    fun extend (x, d, env)
	= (x, d) :: env

    exception UNDECLARED

    fun lookup (x, env)
	= let fun walk nil
		  = (TextIO.output (TextIO.stdOut, "Undeclared variable: ");
		     TextIO.output (TextIO.stdOut, x);
		     raise UNDECLARED)
		| walk ((x', d) :: env)
		  = if x = x'
		    then d
		    else walk env
	  in walk env
	  end
  end;

(* ********** *)

(* A call-by-value evaluator: *)

structure Eval_cbv
= struct
    datatype exprval = INT of int
		     | FUN of exprval -> exprval

    exception STUCK

    fun eval (Expr.LIT n, env)
	= INT n
      | eval (Expr.VAR x, env)
        = Env.lookup (x, env)
      | eval (Expr.LAM (x, e), env)
        = FUN (fn a => eval (e, Env.extend (x, a, env)))
      | eval (Expr.APP (t0, t1), e)
        = (case eval (t0, e)
	     of (FUN f)
		=> f (eval (t1, e))
	      | _
		=> raise STUCK)

     fun evaluate t
         = eval (t, Env.empty)
  end;

(* ********** *)

(* A call-by-name evaluator: *)

structure Eval_cbn
= struct
    datatype exprval = INT of int
		     | FUN of (unit -> exprval) -> exprval

    exception STUCK

    fun eval (Expr.LIT n, env)
	= INT n
      | eval (Expr.VAR x, env)
        = Env.lookup (x, env) ()
      | eval (Expr.LAM (x, e), env)
        = FUN (fn a => eval (e, Env.extend (x, a, env)))
      | eval (Expr.APP (t0, t1), e)
        = (case eval (t0, e)
	     of (FUN f)
		=> f (fn () => eval (t1, e))
	      | _
		=> raise STUCK)

     fun evaluate t
         = eval (t, Env.empty)
  end;

(* ********** *)

(* eof *)