(* mini-smalltalk interpreter *)
(* $Id: st.sml,v 1.1 2003/05/06 11:23:44 eernst Exp $ *)

(* Abstract Grammar:
 *
 *   Program   ::= Class* Expr
 *   Class     ::= VarDcl* MethDcl*
 *   MethDcl   ::= Name MethBody
 *   MethBody  ::= Expr*
 *   Expr      ::= "self"|"arg"|Literal|VarApl|MsgSend|NewExpr|Assign|Cond|Prt
 *   MsgSend   ::= Expr Selector Expr
 *   NewExpr   ::= ClassName
 *   Assign    ::= VarApl Expr
 *   Cond      ::= "cond" Expr Name Name
 *   Prt       ::= "print" Name
 *   Literal   ::= Numeral
 *   VarDcl    ::= Name
 *   VarApl    ::= Name
 *   Selector  ::= Name
 *   ClassName ::= Name
 *
 * where Name and Numeral are defined at the lexical level.
 *)

(* ----- Syntax ----- *)

structure Src
= struct
      type Name = string
      datatype Expr
	= NIL
	| SLF
	| ARG
	| LIT of int
	| VAR of Name
	| MSG of Expr * Name * Expr
	| NEW of Name
	| SET of Name * Expr
	| CND of Name * Name * Expr
	| PRT of Name
      type Body = Expr list
      type Vdcl = Name
      type Mdcl = Name * Body
      type Clss = Name * Mdcl list * Vdcl list
      type Prog = Clss list * Expr

      (* --- Pretty-printing --- *)

      fun strs2str ss = (List.foldl (fn (s1,s2) => s1^s2) "" ss)

      fun name2string n = n
      fun expr2string NIL = "nil"
	| expr2string SLF = "self"
	| expr2string ARG = "arg"
	| expr2string (LIT i) = Int.toString i
	| expr2string (VAR n) = n
	| expr2string (MSG (rcv,n,arg))
	  = "("^(expr2string rcv) ^ ")." ^ n ^ "(" ^ (expr2string arg) ^ ")"
	| expr2string (NEW n) = "new " ^ n
	| expr2string (SET (n,e)) = n ^ " := " ^ (expr2string e)
	| expr2string (CND (c1,c2,e))
	  = "cond (" ^ (expr2string e) ^ ") " ^ c1 ^ " " ^ c2
	| expr2string (PRT n) = "println(" ^ n ^ ")"
      fun body2string es
	  = let fun walk [] = ""
		  | walk (e::es) = "\n    " ^ (expr2string e) ^ walk es
	    in  "{" ^ (walk es) ^ "\n  }"
	    end
      fun vdcl2string n = "\n  :" ^ (name2string n)
      fun mdcl2string (n,b) = "\n  " ^ n ^ "(arg) = " ^ (body2string b)
      fun clss2string (n,ms,vs)
	  = "\nclass " ^ n ^ " {" ^
	    (strs2str (List.map mdcl2string ms)) ^
	    (strs2str (List.map vdcl2string vs)) ^
	    "\n}\n"
      fun prog2string (cs,e)
	  = (strs2str (List.map clss2string cs)) ^ "\n" ^
	    (expr2string e) ^ "\n"

      fun show p = TextIO.print (prog2string p)
  end

(* ----- Environments ----- *)

signature DOMAINS
= sig
      type Domain
      type Range
      val equal: Domain * Domain -> bool
      val toString: Domain -> string
  end

signature MAP
= sig
      exception LOOKUP of string
      type Domain
      type Range
      type Env
      val init: Env
      val extend: Domain * Range * Env -> Env
      val lookup: Domain * Env -> Range
      val update: Domain * Range * Env -> Env
      val toString: Domain -> string
  end

functor Map(structure D: DOMAINS): MAP
= struct
      exception LOOKUP of string

      type Domain = D.Domain
      type Range = D.Range

      type Env = (Domain * Range) list

      val init = nil

      fun extend (key,value,env) = (key,value)::env
      fun lookup (key,env)
	  = let fun walk nil
	            = raise (LOOKUP (D.toString key))
		  | walk ((key',value')::env)
	            = if D.equal(key,key') then value' else walk env
	    in  walk env
	    end
      fun update (key,new_value,env)
	  = let fun walk nil
	            = raise (LOOKUP (D.toString key))
		  | walk ((key',old_value)::env)
	            = if D.equal(key,key')
		      then (key',new_value)::env
		      else (key',old_value)::(walk env)
	    in  walk env
	    end
      val toString = D.toString
  end

(* ----- Auxiliary Functions ----- *)

fun base_equal (x,y) = (x=y)
fun base_toString x = x

fun max_id h = List.foldl (fn ((i,_),j) => if i>j then i else j) 0 h

(* ----- Semantics ----- *)

structure Sem
= struct

      (* --- Semantic Entities --- *)

      type Objid = int (* ~1 means "nil" *)
      datatype Id = I_OBJ of Objid | I_INT of int

      structure Name2Address: DOMAINS
      = struct
	    type Domain   = Src.Name
	    type Range    = Id
	    val  equal    = base_equal
	    val  toString = base_toString
	end
      structure Var = Map(structure D = Name2Address)

      structure Name2Body: DOMAINS
      = struct
	    type Domain   = Src.Name
	    type Range    = Src.Body
	    val  equal    = base_equal
	    val  toString = base_toString
	end
      structure Mth = Map(structure D = Name2Body)

      type Obj_core = Mth.Env * Var.Env
      datatype Obj = S_OBJ of Obj_core | S_INT of int

      structure Address2Object: DOMAINS
      = struct
	    type Domain   = Objid
	    type Range    = Obj_core
	    val  equal    = base_equal
	    val  toString = Int.toString
	end
      structure Sto = Map(structure D = Address2Object)

      type Heap = Sto.Env
      type Class = Mth.Env * Src.Vdcl list

      structure Name2Class: DOMAINS
      = struct
	    type Domain   = Src.Name
	    type Range    = Class
	    val  equal    = base_equal
	    val  toString = base_toString
	end
      structure Cls = Map(structure D = Name2Class)

      type Stack = Id list

      val nil_id = I_OBJ ~1

      (* --- Traversing semantic entities: Lookup --- *)

      fun class cs name = Cls.lookup (name,cs)
      fun obj _ (I_INT i) = S_INT i
	| obj heap (I_OBJ id) = S_OBJ (Sto.lookup (id,heap))
      fun var (S_INT _) napl = raise (Var.LOOKUP napl)
	| var (S_OBJ (_,slots)) napl = Var.lookup (napl,slots)
      fun method (S_INT n) "pred" = [Src.LIT (n-1)]
	| method (S_INT n) "succ" = [Src.LIT (n+1)]
	| method (S_INT _) napl = raise (Mth.LOOKUP napl)
	| method (S_OBJ (ms,_)) selector = Mth.lookup (selector,ms)

      (* --- Transforming semantic entities --- *)

      fun id2string (I_INT i)
	  = Int.toString i
	| id2string (I_OBJ ~1)
	  = "#nil"
	| id2string (I_OBJ id)
	  = "#" ^ (Int.toString id)
      fun xlate_mth ([]: Src.Mdcl list)
	  = Mth.init
	| xlate_mth ((name,body)::ms)
	  = Mth.extend (name, body, xlate_mth ms)
      fun xlate_cls ([]: Src.Clss list)
	  = Cls.init
	| xlate_cls ((name,methods,vars)::cs)
	  = Cls.extend (name, (xlate_mth methods, vars), xlate_cls cs)
      fun create_slots (vdcls: Src.Vdcl list)
	  = List.map (fn name => (name,nil_id)) vdcls
      fun update_slots (slots,name,new_id)
	  = Var.update (name,new_id,slots)
      fun update_heap ([],id,_,_)
	  = raise (Sto.LOOKUP (id2string id))
	| update_heap (_, id as (I_INT i), _, _)
	  = raise (Sto.LOOKUP (id2string id))
	| update_heap (heap, (I_OBJ s_id), name, new_id)
	  = let val (s_methods,s_slots) = Sto.lookup (s_id,heap)
		val new_obj = (s_methods, update_slots (s_slots,name,new_id))
	    in  Sto.update (s_id,new_obj,heap)
	    end

      (* --- Error Handling --- *)

      fun fail s
	  = let val dummy = TextIO.print ("Lookup error regarding " ^ s ^ "\n")
	    in  (Sto.init, nil_id)
	    end
      fun var_fail s = fail "slot: "
      fun mth_fail s = fail "method: "
      fun sto_fail s = fail "store: "
      fun cls_fail s = fail "class: "
  end

(* ----- Evaluation ----- *)

(* 'eval' in all of these structures works as follows: in the static
 *  universe of classes given by 'c', with the dynamic universe 'h'
 * of objects, and with the object having identity 's_id' as the
 * "self", and 'a_id' as the argument, evaluate the expression 'e'
 *)

signature EVAL
= sig
      exception CORE_DUMPED
      val eval:
	  (Sem.Cls.Env * Sem.Heap * Sem.Id * Sem.Id * Src.Expr) ->
	  (Sem.Heap * Sem.Stack)
  end

functor Int(structure E: EVAL)
= struct
      exception CORE_DUMPED = E.CORE_DUMPED
      val eval = E.eval

      fun evaluate (classes, main_expr)
	  = let val init_cls = Sem.xlate_cls classes
		val init_heap = []
		val init_rcv = Sem.nil_id
		val init_arg = Sem.nil_id
	    in  (case eval (init_cls,init_heap,init_rcv,init_arg,main_expr)
		     of (h, v :: nil) => (h, v)
		   | _ => raise CORE_DUMPED)
	    end
	    handle Sem.Var.LOOKUP s => Sem.var_fail s
	    handle Sem.Mth.LOOKUP s => Sem.mth_fail s
	    handle Sem.Sto.LOOKUP s => Sem.sto_fail s
	    handle Sem.Cls.LOOKUP s => Sem.cls_fail s

      fun eval_show (p as (classes, main_expr))
	  = let val (h, v) = evaluate p
	    in  Src.show p;
		TextIO.print ("\n" ^ Sem.id2string v ^ "\n");
		v
	    end
  end

(* Int_canon: a simple, canonical interpreter *)

structure Eval_canon: EVAL
= struct
      exception CORE_DUMPED

      fun eval (cs, h, s_id, a_id, e)
	  = let fun new (h, s, s_id, a_id, name)
	            = let val (ms, vs) = Sem.class cs name
			  val new_id = 1 + max_id h
			  val new_slots = Sem.create_slots vs
			  val new_h = Sem.Sto.extend(new_id,(ms,new_slots),h)
		      in  (new_h,(Sem.I_OBJ new_id)::s)
		      end
		fun eval1 (h, s, s_id, a_id, Src.NIL)
		    = (h, Sem.nil_id :: s)
		  | eval1 (h, s, s_id, a_id, Src.SLF)
		    = (h, s_id :: s)
		  | eval1 (h, s, s_id, a_id, Src.ARG)
		    = (h, a_id :: s)
		  | eval1 (h, s, s_id, a_id, Src.LIT i)
		    = (h, (Sem.I_INT i) :: s)
		  | eval1 (h, s, s_id, a_id, Src.VAR n)
		    = (h, (Sem.var (Sem.obj h s_id) n)::s)
		  | eval1 (h, s, s_id, a_id, Src.MSG (rcv, sel, arg))
		    = let val (h1,s1) = eval1 (h, s, s_id, a_id, rcv)
			  val (h2,s2) = eval1 (h1, s1, s_id, a_id, arg)
			  val (h3,s3) = invoke sel (h2, s2)
		      in  (h3, s3)
		      end
		  | eval1 (h, s, s_id, a_id, Src.NEW name)
		    = new (h, s, s_id, a_id, name)
		  | eval1 (h, s, s_id, a_id, Src.SET (name, expr))
		    = let val (h1, s1) = eval1 (h, s, s_id, a_id, expr)
			  fun assign (h, res_id::s)
			      = (Sem.update_heap (h,s_id,name,res_id),
				 res_id::s)
			    | assign _
			      = raise CORE_DUMPED
			  val (h2, s2) = assign (h1, s1)
		      in  (h2, s2)
		      end
		  | eval1 (h, s, s_id, a_id, Src.CND (name1, name2, expr))
		    = let val (h1, s1) = eval1 (h, s, s_id, a_id, expr)
		          fun cond (h, (Sem.I_INT 0)::s)
			      = new (h, s, s_id, a_id, name2)
			    | cond (h, _::s)
			      = new (h, s, s_id, a_id, name1)
			    | cond _
			      = raise CORE_DUMPED
		      in  cond (h1, s1)
		      end
		  | eval1 (h, s, s_id, a_id, Src.PRT name)
		    = (TextIO.print (name ^ "\n"); (h, Sem.nil_id::s))

		and eval1_body (h, s, s_id, a_id, [], res_id)
		    = (h, res_id :: s)
		  | eval1_body (h, s, s_id, a_id, e :: es, _)
		    = let val (h1, s1) = eval1 (h, s, s_id, a_id, e)
			  fun rest (hx, resx_id::sx)
			      = eval1_body (hx, sx, s_id, a_id, es, resx_id)
			    | rest _
			      = raise CORE_DUMPED
			  val (h2, s2) = rest (h1, s1)
		      in  (h2, s2)
		      end

		and invoke sel (h, arg_id :: rcv_id :: s)
		    = let val body = Sem.method (Sem.obj h rcv_id) sel
		      in (TextIO.print
			  ("\n* "^sel^"("^(Sem.id2string arg_id)^")");
			  eval1_body (h, s, rcv_id, arg_id, body, Sem.nil_id))
		      end
		  | invoke _ _
		    = raise CORE_DUMPED

	    in  eval1 (h, nil, s_id, a_id, e)
	    end
    end

structure Int_canon = Int(structure E = Eval_canon)

(* Int_curry: curried version of Int_canon *)

structure Eval_curry
= struct
      exception CORE_DUMPED

      fun eval (cs, h, s_id, a_id, e)
	  = let fun new (s_id, a_id, name)
	            = (fn (h, s) =>
		       let val (ms, vs) = Sem.class cs name
			   val new_id = 1 + max_id h
			   val new_slots = Sem.create_slots vs
			   val new_h = Sem.Sto.extend(new_id,(ms,new_slots),h)
		       in  (new_h,(Sem.I_OBJ new_id)::s)
		       end)
		fun eval1 (s_id, a_id, Src.NIL)
		    = (fn (h, s) => (h, Sem.nil_id :: s))
		  | eval1 (s_id, a_id, Src.SLF)
		    = (fn (h, s) => (h, s_id :: s))
		  | eval1 (s_id, a_id, Src.ARG)
		    = (fn (h, s) => (h, a_id :: s))
		  | eval1 (s_id, a_id, Src.LIT i)
		    = (fn (h, s) => (h, (Sem.I_INT i) :: s))
		  | eval1 (s_id, a_id, Src.VAR n)
		    = (fn (h, s) => (h, (Sem.var (Sem.obj h s_id) n)::s))
		  | eval1 (s_id, a_id, Src.MSG (rcv, sel, arg))
		    = ((invoke sel)
		       o (eval1 (s_id, a_id, arg))
		       o (eval1 (s_id, a_id, rcv)))
		  | eval1 (s_id, a_id, Src.NEW name)
		    = new (s_id, a_id, name)
		  | eval1 (s_id, a_id, Src.SET (name, expr))
		    = ((fn (h, res_id :: s) =>
			   (Sem.update_heap (h,s_id,name,res_id), res_id::s)
			 | _ => raise CORE_DUMPED)
		       o (eval1 (s_id, a_id, expr)))
		  | eval1 (s_id, a_id, Src.CND (name1, name2, expr))
		    = (fn (h, s) =>
		       let val (h1, s1) = eval1 (s_id, a_id, expr) (h, s)
			   fun cond (h, (Sem.I_INT 0)::s)
			       = new (s_id, a_id, name2) (h, s)
			     | cond (h, _::s)
			       = new (s_id, a_id, name1) (h, s)
			     | cond _
			       = raise CORE_DUMPED
		       in  cond (h1, s1)
		       end)
		  | eval1 (s_id, a_id, Src.PRT name)
		    = (fn (h, s) =>
		       (TextIO.print (name^"\n"); (h, Sem.nil_id::s)))

		and eval1_body (s_id, a_id, [], res_id)
		    = (fn (h, s) => (h, res_id :: s))
		  | eval1_body (s_id, a_id, e :: es, res_id)
		    = ((fn (h1, res1_id :: s) =>
			   eval1_body (s_id, a_id, es, res1_id) (h1, s)
		         | _ => raise CORE_DUMPED)
		       o (eval1 (s_id, a_id, e)))

		and invoke sel
		    = (fn (h, arg_id :: rcv_id :: s) =>
		       let val body = Sem.method (Sem.obj h rcv_id) sel
		       in  eval1_body (rcv_id, arg_id, body, Sem.nil_id) (h,s)
		       end
			| _ => raise CORE_DUMPED)
	    in  eval1 (s_id, a_id, e) (h, nil)
	    end
    end

structure Int_curry = Int(structure E = Eval_curry)

(* Int_fact: a factorized version of Int_curry *)

structure Eval_fact =
    struct
	exception CORE_DUMPED

	val nyl
	    = (fn (h, s) => (h, Sem.nil_id :: s))
	fun slf s_id
	    = (fn (h, s) => (h, s_id :: s))
	fun arg a_id
	    = (fn (h, s) => (h, a_id :: s))
	fun lit i
	    = (fn (h, s) => (h, (Sem.I_INT i) :: s))
	fun var (s_id, n)
	    = (fn (h, s) => (h, (Sem.var (Sem.obj h s_id) n) :: s))
	fun new (cs, name)
	    = (fn (h, s) =>
	       let val (ms, vs) = Sem.class cs name
		   val new_id = 1 + max_id h
		   val new_slots = Sem.create_slots vs
		   val new_h = Sem.Sto.extend (new_id,(ms,new_slots),h)
	       in  (new_h, (Sem.I_OBJ new_id)::s)
	       end)
	fun set (s_id, name)
	    = (fn (h, res_id :: s) =>
	          (Sem.update_heap (h, s_id, name, res_id), res_id :: s)
	        | _ => raise CORE_DUMPED)

	fun push id
	    = (fn (h, s) => (h, id :: s))

	fun eval1 (cs, s_id, a_id, Src.NIL) = nyl
	  | eval1 (cs, s_id, a_id, Src.SLF) = slf s_id
	  | eval1 (cs, s_id, a_id, Src.ARG) = arg a_id
	  | eval1 (cs, s_id, a_id, Src.LIT i) = lit i
	  | eval1 (cs, s_id, a_id, Src.VAR n) = var (s_id, n)
	  | eval1 (cs, s_id, a_id, Src.MSG (rcv, sel, arg))
	    = (invoke (cs, sel))
	    o (eval1 (cs, s_id, a_id, arg))
	    o (eval1 (cs, s_id, a_id, rcv))
	  | eval1 (cs, s_id, a_id, Src.NEW name) = new (cs, name)
	  | eval1 (cs, s_id, a_id, Src.SET (name, expr))
	    = (set (s_id, name))
	    o (eval1 (cs, s_id, a_id, expr))
	  | eval1 (cs, s_id, a_id, Src.CND (name1, name2, expr))
	    = (fn (h, s) =>
	       let val (h1, s1) = eval1 (cs, s_id, a_id, expr) (h, s)
		   fun cond (h, (Sem.I_INT 0)::s)
		       = new (cs, name2) (h, s)
		     | cond (h, _::s)
		       = new (cs, name1) (h, s)
		     | cond _
		       = raise CORE_DUMPED
	       in  cond (h1, s1)
	       end)
	  | eval1 (cs, s_id, a_id, Src.PRT name)
	    = (fn (h, s) => (TextIO.print (name^"\n"); (h, Sem.nil_id::s)))

	and eval1_body (cs, s_id, a_id, nil, res_id)
	    = push res_id
	  | eval1_body (cs, s_id, a_id, e :: es, _)
	    = (eval1_rest (cs, s_id, a_id, es))
	    o (eval1 (cs, s_id, a_id, e))

	and eval1_rest (cs, s_id, a_id, es)
	    = (fn (h, res_id :: s) =>
		  eval1_body (cs, s_id, a_id, es, res_id) (h,s)
	        | _ => raise CORE_DUMPED)

	and invoke (cs, sel)
	    (* NB! - body: Src.Body, i.e., this is not compositional *)
	    = (fn (h, arg_id :: rcv_id :: s) =>
	          let val body = Sem.method (Sem.obj h rcv_id) sel
		  in  eval1_body (cs, rcv_id, arg_id, body, Sem.nil_id) (h,s)
		  end
		| _ => raise CORE_DUMPED)

	fun eval (cs, h, s_id, a_id, e)
	    = eval1 (cs, s_id, a_id, e) (h, nil)
    end

structure Int_fact = Int(structure E = Eval_fact)