(* Interpreter for simple expression language. *)

(* Abstract Syntax for expressions. *)
structure Ast =
struct
  datatype exp =
    INT of int
  | ADD of exp * exp
  | SUB of exp * exp 
  | MUL of exp * exp
  | DIV of exp * exp 
  | REM of exp * exp

  fun expToString (exp:exp) : string =
    case exp of
      INT i => Int.toString i
    | ADD(e1,e2) => "(+ " ^ (expToString e1) ^ " " ^ (expToString e2) ^ ")"
    | SUB(e1,e2) => "(- " ^ (expToString e1) ^ " " ^ (expToString e2) ^ ")"
    | MUL(e1,e2) => "(* " ^ (expToString e1) ^ " " ^ (expToString e2) ^ ")"
    | DIV(e1,e2) => "(/ " ^ (expToString e1) ^ " " ^ (expToString e2) ^ ")"
    | REM(e1,e2) => "(% " ^ (expToString e1) ^ " " ^ (expToString e2) ^ ")"

end (* Ast *)

(* Parsing module. *)
structure Parse :> 
  sig type lineno = int
      exception ParseFailed of string * lineno
      val parse : string -> Ast.exp  
  end =
struct
  open Ast

  type lineno = int

  datatype token = 
    NUM of int
  | OPER of string
  | LP
  | RP
  | EOF

  exception Impossible  (* for internal errors *)
  exception ParseFailed of string * lineno

  fun tokenize (s:string) : (lineno * token) list =
      let fun isOperChar (c:char) : bool = List.exists (fn c' => c = c') [#"+",#"-",#"*",#"/",#"%"]
	  fun mkNum (lineno:lineno,acc:char list) : (lineno * token) = 
	      let val s = String.implode(rev acc)
	      in case (Int.fromString s handle Overflow => NONE) of
		   SOME i => (lineno,NUM i)
		 | NONE => raise ParseFailed ("Invalid number: " ^ s,lineno)
	      end
          fun mkOper (lineno:lineno,acc:char list) : (lineno * token) = 
	      (lineno,OPER (String.implode (rev acc)))
	  fun tok (lineno,comment_level,c::rest,result) =
	      if c = #"\n" then
		  tok(lineno+1,comment_level,rest,result)
	      else if c = #"{" then
		  tok(lineno,comment_level+1,rest,result)
	      else if c = #"}" then
		  if comment_level > 0 then
		    tok(lineno,comment_level-1,rest,result)
		  else 
		    raise ParseFailed("Unmatched close comment", lineno)
	      else if comment_level > 0 then
		  tok(lineno,comment_level,rest,result)
	      else if Char.isSpace c then
		  tok (lineno,comment_level,rest,result)
	      else 
              (case c of
  	         #"(" => tok(lineno,comment_level,rest,(lineno,LP)::result)
 	       | #")" => tok(lineno,comment_level,rest,(lineno,RP)::result)
	       |_ => if Char.isDigit c then
		       more (lineno,comment_level,Char.isDigit,mkNum,result) (rest,[c])
	             else if isOperChar c then
		       more (lineno,comment_level,isOperChar,mkOper,result) (rest,[c])
     	             else raise ParseFailed ("Invalid character: " ^ Char.toString c, lineno))
	    | tok (lineno,0,nil,result) = (lineno,EOF) :: result
	    | tok (lineno,_,nil,result) = 
		  raise ParseFailed ("Unmatched open comment",lineno)
	  and more (lineno,comment_level,test,build,result) =
	      let fun m (cs as (c::rest),acc) =
		      if test c then 
		        m (rest,c::acc)
		      else
		        tok(lineno,comment_level,cs,build (lineno,acc)::result)
		    | m (nil,acc) = (lineno,EOF)::build (lineno,acc)::result
	      in m
	      end
      in rev (tok (1,0,String.explode s,[]))
      end

  fun parseExp ((_,NUM i)::rest) = (INT i,rest)
    | parseExp ((_,LP)::rest) = 
        let val (e,rest) = 
	      case rest of
	        (lineno,OPER operator)::rest =>
		    let val (e1,rest) = parseExp rest
			val (e2,rest) = parseExp rest
			val e = 
			  case operator of
			    "+" => ADD(e1,e2)
			  | "-" => SUB(e1,e2)
			  | "*" => MUL(e1,e2)
			  | "/" => DIV(e1,e2)
			  | "%" => REM(e1,e2)
			  | _ => raise ParseFailed("Invalid operator: " ^ operator,lineno)
		    in (e,rest)
		    end
	      | (lineno,_)::rest => raise ParseFailed("Missing or invalid expression", lineno)
	      | _ => raise Impossible
	    val rest = 
	       case rest of
		 (_,RP)::rest => rest
	       | (lineno,_)::_ => raise ParseFailed ("Missing )",lineno)
	       | _ => raise Impossible
	 in (e,rest)
	 end
    | parseExp ((lineno,_)::_) = raise ParseFailed ("Missing or invalid expression",lineno)
    | parseExp _ = raise Impossible

  fun parse (s:string) : exp =
    case parseExp (tokenize s) of
      (exp,[(_,EOF)]) => exp
    | (_,(lineno,_)::_) => raise ParseFailed ("Extraneous characters at end of program",lineno)
    | _ => raise Impossible

end (* Parse *)

(* Stack Abstract Data Type *)
structure Stack :> 
  sig
    type 'a stack
    exception Empty
    val empty : 'a stack
    val isEmpty : 'a stack -> bool
    val push : 'a stack * 'a -> 'a stack
    val pop : 'a stack -> 'a * 'a stack
    val toString : ('a -> string) -> 'a stack -> string
  end =
struct
  type 'a stack = 'a list
  exception Empty
  val empty = []
  fun isEmpty [] = true
    | isEmpty _ = false
  fun push (s,x) = x::s
  fun pop [] = raise Empty
    | pop (x::s) = (x,s)
  fun toString toS [] = ""
    | toString toS (x::s) = (toS x) ^ " " ^ (toString toS s)
end

(* Stack Machine *)
structure Machine :>
sig
  datatype instr = CONST of int | PLUS | TIMES | NEGATE | DIVREM | POP | SWAP
  type prog = instr list
  val exec : prog -> int 
  val progToString : prog -> string
end = 
struct
  open Stack
      
  datatype instr = CONST of int | PLUS | TIMES | NEGATE | DIVREM | POP | SWAP
  type prog = instr list
      
  fun instrToString instr : string =
      case instr of
	CONST i => "CONST " ^ (Int.toString i) 
      | PLUS => "PLUS"
      | TIMES => "TIMES"
      | NEGATE => "NEGATE"
      | DIVREM => "DIVREM"
      | POP => "POP"
      | SWAP => "SWAP"

  fun progToString (instrs:instr list) : string  =
      case instrs of
	[] => ""
      | instr::instrs => (instrToString instr) ^ "\n" ^ (progToString instrs) 

  (* Execute a single stack machine instruction *)
  fun step (stk:int stack,instr:instr) : int stack = 
      case instr of
	CONST v => push (stk,v) 
      | PLUS =>
	  let val (v2,stk) = pop stk
	      val (v1,stk) = pop stk
	  in push(stk,v1 + v2)
	  end
      | TIMES =>
	  let val (v2,stk) = pop stk
	      val (v1,stk) = pop stk
	  in push(stk,v1 * v2)
	  end
      | NEGATE => 
	  let val (v,stk) = pop stk
	  in push(stk,~v)
	  end
      | DIVREM => 
	  let val (v2,stk) = pop stk
	      val (v1,stk) = pop stk
	      val d = Int.quot (v1,v2)
	      val r = Int.rem (v1,v2)
	  in push (push (stk, d),r)
	  end
      | POP => 
	  let val (_,stk) = pop stk
	  in stk
	  end
      | SWAP => 
	  let val (v2,stk) = pop stk
	      val (v1,stk) = pop stk
	  in push (push(stk,v2),v1)
	  end

  (* Execute a sequence of stack machine instructions. *)
  fun exec (instrs:instr list) : int =
      let fun steps(stk:int stack,instrs:instr list) : int =
	  case instrs of
	    [] => 
	      let val (result,_) = pop stk
	      in result
	      end
	  | instr::instrs => 
	      let val stk' = step(stk,instr)
              in print ("*" ^ (instrToString instr) ^ " : " ^ (Stack.toString Int.toString stk') ^ "\n");
	         steps(stk',instrs)
	      end
      in steps(Stack.empty,instrs)
      end
end

(* Compiler Module *)
structure Compile :>
sig
  val compile : Ast.exp -> Machine.prog
end = 
struct
  open Ast Machine

  fun compile exp =
      case exp of
        INT i => [CONST i]
      | ADD(e1,e2) => (compile e1) @ (compile e2) @ [PLUS]
      | SUB(e1,e2) => (compile e1) @ (compile e2) @ [NEGATE,PLUS]
      | MUL(e1,e2) => (compile e1) @ (compile e2) @ [TIMES]
      | DIV(e1,e2) => (compile e1) @ (compile e2) @ [DIVREM,POP]
      | REM(e1,e2) => (compile e1) @ (compile e2) @ [DIVREM,SWAP,POP]
end


(* Top-level module *)
structure Interp =
struct
  fun interp (filename:string) : unit =
      let val inchan = TextIO.openIn filename
	  val s = TextIO.inputAll inchan
      in TextIO.closeIn inchan;
	 let val exp = Parse.parse s 
	     val _ = print ("Expression: " ^ (Ast.expToString exp) ^ "\n")
	     val prog = Compile.compile exp
	     val _ = print ("Compiles to:\n" ^ (Machine.progToString prog));
	     val _ = print ("Evaluating:\n");
	     val result = Machine.exec prog
	 in print ("Evaluates to: " ^ (Int.toString result) ^ "\n")
	 end handle Parse.ParseFailed (s,lineno) =>
	               (print ("Parse failed: Line " ^ (Int.toString lineno) ^ ": " ^ s ^ "\n"))
      end

end (* Top *)