type index = int 
type noi   = int                (* number of instructions      *)
type noa   = int                (* number of arguments         *)
type nog   = int                (* number of globals           *)
type ca    = int                (* code address                *)

datatype instruction =
    con     of int             
  | add                         (* addition                    *)
  | sub                         (* substraction                *)
  | mul                         (* multiplication              *)
  | leq                         (* less or equal test          *)
  | branch  of noi              (* unconditional branch        *)
  | cbranch of noi              (* conditional branch          *)
  | getS    of index            (* push value from stack       *)
  | putS    of index            (* update value in stack       *)
  | halt                        (* halt machine                *)
  | proc    of noa * noi        (* begin of procedure code     *)
  | getF    of index            (* push value from frame       *)
  | call    of ca               (* call procedure              *)
  | return                      (* return from procedure call  *)
  | callR   of ca               (* call procedure and return   *)
  | new     of noa              (* push new block              *)
  | getH    of index            (* push block field            *)
  | putH    of index            (* update block field          *)
  | eq                          (* equality test               *)
  | procH   of noa * noi * nog  (* begin of heap procedure code   *)
  | callH                       (* call heap procedure            *)
  | callRH                      (* call heap procedure and return *)


type code = instruction list

structure VM :>  (* ****************************************** *)
  sig
    exception Error of string
    val run : code -> int  (* Error *)
  end
=
struct

  exception Error of string

  structure ProgramStore :>  (* ***** *)
    sig
      val load  : code -> unit
      val instr : ca -> instruction
    end
  = 
  struct
    val size  = 100	    
    val store = Array.array(size, halt)

    fun instr ca = if 0<=ca andalso ca<size
		     then Array.sub(store, ca)
		   else raise Error "illegal program address"

    fun load'(x,i) = if i < size 
		       then i+1 before Array.update(store,i,x)
		     else raise Error "program too large"

    fun load code = (foldl load' 0 code; ())

  end (* ProgramStore  *************** *)

  structure Store :>  (* ************* *)
    sig
      val pushI   : int   -> unit
      val popI    : unit  -> int
      val pushS   : index -> unit
      val updateS : index -> unit
      val pushF   : noa   -> unit
      val pushFF  : index -> unit
      val popF    : noa   -> unit
      val clear   : unit  -> unit
      val pushB   : noa   -> unit
      val pushH   : index -> unit
      val updateH : index -> unit
      val pushEq  : unit  -> unit
      val dup     : unit  -> unit
    end
  = 
  struct
    val stackSize = 100	    
    val heapSize  = 100
    val stack     = Array.array(stackSize, 0)
    val sp        = ref ~1  (* points to topmost cell *)
    val fp        = ref ~1  (* frame pointer          *)
    val heap      = Array.array(2*heapSize, 0)
    val fha       = valOf(Int.maxInt)-2*heapSize+1  (* first heap address *)
    val bp        = ref fha  (* points to first cell in current heap section *)
    val hp        = ref(fha-1)  (* points to topmost allocated cell *)

    fun clear () = (sp:= ~1 ; fp:= ~1 ; bp:= fha ; hp:= fha-1)

    fun getS sa    = Array.sub(stack, sa)
    fun putS(sa,v) = Array.update(stack, sa, v)
    fun getH ha    = Array.sub(heap, ha-fha)
    fun putH(ha,v) = Array.update(heap, ha-fha, v)

    fun check sa = if 0<=sa andalso sa <= !sp then sa
		   else raise Error "illegal stack address"

    fun push v = if !sp+1 >= stackSize 
		     then raise Error "stack overflow"
		 else (sp:= !sp+1 ; putS(!sp, v))

    fun pop () = getS(check(!sp)) before sp:= !sp-1

    fun isI v  = v<fha

    fun pushI v = if isI v then push v
		  else raise Error "number overflow"

    fun popI () = let val v = pop() 
		  in  if isI v then v
		      else raise Error "number expected"
		  end

    fun pushS i   = push(getS(check i))
    fun updateS i = putS(check i, pop())

    fun pushF noa = (pushI noa ; pushI(!fp) ; fp:= !sp)

    fun pushFF i  = if ~(getS(!fp-1)) <= i andalso i <= !sp
		    then push(getS(!fp+i+(if i<0 then ~1 else 1)))
		    else raise Error "illegal frame address"
    
    val wc  = ref ~1  (* counter for while loop  *)

    fun moveS (start, noa) = (wc:= start ;
			      while !wc <= start+noa-1 do
			        (push(getS(!wc)) ; wc:= !wc+1))

    fun popF noa = if !fp>=0 then 
                     let
		       val start = !sp-noa+1
		     in 
		       sp:= !fp-2-getS(!fp-1) ;
		       fp:= getS(!fp) ; 
		       moveS(start, noa)
		     end
		   else raise Error "illegal pop frame"

    fun pushEq () = pushI(if pop()=pop() then 1 else 0)
    fun dup ()    = push(getS(!sp))

    fun alloc v = (hp:= !hp+1 ; putH(!hp,v))

    fun pushH i = let val a = pop() 
		      val l = getH a
		  in  if 0<i andalso i<l then push(getH(a+i))
		      else raise Error "illegal block index (get)"
		  end

    fun updateH i = let val a = pop() 
			val l = getH a
		    in  if 0<i andalso i<l then putH(a+i, pop())
			else raise Error "illegal block index (put)"
		    end

    val iwc = ref ~1  (* counter for inner while loop  *)

    fun heap2heap(ha,n) = (iwc:= ha ;
			   while !iwc < ha+n do
			     (alloc(getH(!iwc)) ; iwc:= !iwc+1) )

    fun gcCopyBlock oldba =
      if not(isI(getH oldba)) then getH oldba
      else let 
	     val newba = !hp+1
	   in
	     heap2heap(oldba, getH oldba) ; 
	     putH(oldba,newba) ; 
	     newba 
	   end 

    fun gcCopyStack () = 
      (wc:= 0 ;              (* wc points to stack cell *)
       while !wc <= !sp do
	 (if isI(getS(!wc)) then () else putS(!wc, gcCopyBlock(getS(!wc))) ;
	  wc:= !wc+1 ) )

    fun gcCopyHeap () = 
      (wc:= !bp ;            (* wc points to heap cell *)
       while !wc <= !hp do
	 (if isI(getH(!wc)) then () else putH(!wc, gcCopyBlock(getH(!wc))) ;
	  wc:= !wc+1 ) )

    fun gc () = (bp:= !bp + (if !bp=fha then 1 else ~1) * heapSize ;
		 hp:= !bp-1 ;
		 gcCopyStack() ; 
		 gcCopyHeap() )

    fun pushB' noa = if !hp-heapSize > !bp-noa-2
		       then raise Error "heap overflow"
		     else (alloc(noa+1) ;
			   wc:= noa ;
			   while !wc>0 do 
			     (alloc(pop()) ; wc:= !wc-1) ;
			   push(!hp-noa) )
	
    fun pushB noa = if 0<noa andalso noa<heapSize
		      then pushB' noa handle _ => (gc() ; pushB' noa)
		    else raise Error "illegal block allocation"   

  end  (* Store ******************* *)

  open ProgramStore Store

  val pc = ref 0

  exception Halt of int

  fun getNoa ca = case instr ca of 
                    proc(noa,_) => noa
		  | _ => raise Error "wrong program address (call) "

  fun getNoaCa () = let val ca = (dup(); pushH 1 ; popI())
		    in  case instr ca of 
		          procH(noa,_,_) => (noa,ca)
			| _ => raise Error "wrong program address (callH)"
		    end

  fun getRA () = (pushFF 0 ; popI())
	
  fun execute instruction =
    case instruction of
      con i          => (pushI i ; pc:= !pc+1)
    | add            => (pushI (popI() + popI()) ; pc:= !pc+1)
    | sub            => (pushI (popI() - popI()) ; pc:= !pc+1)
    | mul            => (pushI (popI() * popI()) ; pc:= !pc+1)
    | leq            => (pushI (if popI()<=popI() then 1 else 0) ; pc:= !pc+1)
    | branch noi     => pc:= !pc+noi
    | cbranch noi    => if popI()=0 then pc:= !pc+noi else pc:= !pc+1
    | getS i         => (pushS i ; pc:= !pc+1)
    | putS i         => (updateS i ; pc:= !pc+1)
    | halt           => raise Halt(popI())
    | getF i         => (pushFF i ; pc:= !pc+1)
    | proc(noa, noi) => pc:= !pc+noi
    | call ca        => (pushF(getNoa ca) ; pushI(!pc) ; pc:= ca+1)
    | return         => (pc:= getRA()+1 ; popF 1)
    | callR ca       => let val ra = getRA()
			    val noa = getNoa ca
			in  popF noa ; pushF noa; pushI ra ; pc:=ca+1
			end
    | new noa        => (pushB noa ; pc:= !pc+1)
    | getH i         => (pushH i   ; pc:= !pc+1)
    | putH i         => (updateH i ; pc:= !pc+1)
    | eq             => (pushEq()  ; pc:= !pc+1)
    | procH(noa, noi, nog) => (pushI(!pc) ; pushB(1+nog); pc:= !pc+noi)
    | callH          => let val (noa,ca) = getNoaCa()
			in pushF(noa+1) ; pushI(!pc) ; pc:= ca+1
			end
    | callRH         => let val ra = getRA()
			    val (noa,ca) = getNoaCa()
			in  popF(noa+1) ; pushF(noa+1) ; pushI ra ; pc:=ca+1
			end

  fun run code =
    (load code ;
     pc:=0 ;
     clear() ;
     while true do execute(instr(!pc)) ;
     0 )
    handle Halt n   => n
         | Overflow => raise Error "Overflow"

end (* VM ************************************************ *)

open VM

;

run 
[con 15, con 7, add, halt]
;

run
[con 2, con 1, leq, cbranch 5,    (* if 1<=2   *)
 con 3, con 4, sub, branch 4,     (* then 4-3  *)
 con 5, con 7, mul,               (* else 7*5  *)
 halt]
;

run
[con 12,                             (* val n = ref 12  [0] *)
 con 1,                              (* val a = ref 1   [1] *)
 getS 0, con 2,  leq,  cbranch 10,   (* while 2 <= !n do    *)
 getS 0, getS 1, mul, putS 1,        (*   a := !a * !n ;    *)
 con 1,  getS 0, sub, putS 0,        (*   n := !n - 1       *)       
 branch ~12,           
 halt]
;

fun exp (x,n) = if n<=0 then 1 else x*exp(x,n-1)

;
run
[proc(2,15),                      (* fun exp(x,n) =       *)
 con 0, getF ~2, leq, cbranch 3,  (* if n<=0              *)
 con 1, branch 8,                 (* then 1               *)
 con 1, getF ~2, sub,             (* else x*exp(x,n-1)    *)
 getF ~1, call 0, getF ~1, mul,
 return,                  
 con 10, con 2, call 0,           (* exp(2,10)            *)
 halt]
;

fun gcd(x,y) = if x<=y 
               then if y<=x then x else gcd(x, y-x)
	       else gcd(x-y, y)
;
run
[proc(2,23),                                    (* fun gcd(x,y) =  *)
 getF~2, getF~1, leq, cbranch 13,               (* if x<=y         *)
 getF~1, getF~2, leq, cbranch 3,                (* then if y<=x    *)
 getF~1, branch 12,                             (* then x          *)
 getF~1, getF~2, sub, getF~1, call 0, branch 6, (* else gcd(x,y-x) *)
 getF~2, getF~2, getF~1, sub, call 0,           (* else gcd(x-y,y) *) 
 return,
 con 216, con 723, call 0,                      (* gcd(216,723) ==> 3 *)
 halt
 ]
;

run
[proc(2,21),                               (* fun gcd(x,y) =  *)
 getF~2, getF~1, leq, cbranch 12,          (* if x<=y         *)
 getF~1, getF~2, leq, cbranch 3,           (* then if y<=x    *)
 getF~1, return,                           (* then x          *)
 getF~1, getF~2, sub, getF~1, callR 0,     (* else gcd(x,y-x) *)
 getF~2, getF~2, getF~1, sub, callR 0,     (* else gcd(x-y,y) *) 
 con 216, con 723, call 0,                 (* gcd(216,723) ==> 3 *)
 halt
 ]
;

fun fib n = if n<2 then n else fib(n-2) + fib(n-1)

;
run
[proc(1,17),
 con 1, getF~1, leq, cbranch 3,
 getF~1, return,
 con 1, getF~1, sub, call 0, 
 con 2, getF~1, sub, call 0, 
 add, return,
 con 20, call 0,   (* fib 20  ==> 6765 *)
 halt]
;

fun fibi'(n,a,b) = if n<=0 then a else fibi'(n-1, b, a+b)

fun fibi n = fibi'(n,0,1)

;
run
[proc(3,15),
 con 0, getF ~1, leq, cbranch 3,
 getF ~2, return,
 getF ~3, getF ~2, add, getF ~3, con 1, getF ~1, sub, callR 0,
 proc(1,5),
 con 1, con 0, getF ~1, callR 0,
 con 20, call 15, halt]
;

datatype tree =
    L of int
  | N of int * tree * tree


;
run
[con 7, new 1, getH 1, new 1, getH 1, new 1, getH 1, halt]
;

fun tree n = if n<=0 then L 0
             else let val t = tree(n-1) in N(n,t,t) end

;
run
[proc(1,18),                       (* fun tree n =               *)
 con 0, getF~1, leq, cbranch 5,    (* if n<=0                    *)
 con 0, con 1, new 2, return,      (* then L 0                   *)
 con 1, getF~1, sub, call 0,       (* else let val t = tree(n-1) *)
 getF 1, getF~1, con 2, new 4,     (*      in N(n,t,t) end       *)
 return,
 con 3, call 0, getH 2, halt]
;

fun top (L x)       = x
  | top (N(x,_,_)) = x

;
run
[proc(1,4), getF~1, getH 2, return,
 con 7, con 1, new 2, getS 0, con 27, con 2, new 4, call 0,
 halt]
;

fun sum (L x)       = x
  | sum (N(x,t,t')) = x + sum t + sum t'

fun sum (L x) = x
  | sum (N b) = #1b + sum(#2b) + sum(#3b)

;
run
[proc(1,18),                       (* fun tree n =               *)
 con 0, getF~1, leq, cbranch 5,    (* if n<=0                    *)
 con 0, con 1, new 2, return,      (* then L 0                   *)
 con 1, getF~1, sub, call 0,       (* else let val t = tree(n-1) *)
 getF 1, getF~1, con 2, new 4,     (*      in N(n,t,t) end       *)
 return,
 proc(1,20),                           (* fun                *)
 getF~1, getH 1, con 1, eq, cbranch 4, (* sum L x =          *)
 getF~1, getH 2, return,               (*           x        *)
                                       (* | sum(N(x,t,t')) = *)
 getF~1, getH 4, call 18,              (*             sum t' *)
 getF~1, getH 3, call 18,              (*     sum t          *)
 getF~1, getH 2, add, add,             (* x +       +        *)
 return, 
 con 7, call 0, call 18, halt] 
;

				    
fun equal (L x, L x')                 = x=x'
  | equal (N(x,t1,t2), N(x',t1',t2')) = x=x' andalso equal(t1,t1')
                                        andalso equal(t2,t2')
  | equal            _                = false

(* 

   fun equal(t,t') = if t=L x 
                     then if t'=L x'
			  then x=x'
                          else false
                     else if t'=N(x,t1',t2')
			  then t=N(x,t1,t2) =>
                               x=x' andalso equal(t1,t1')
                                    andalso equal(t2,t2')
                          else false
*)

;
run
[proc(1,18),                       (* fun tree n =               *)
 con 0, getF~1, leq, cbranch 5,    (* if n<=0                    *)
 con 0, con 1, new 2, return,      (* then L 0                   *)
 con 1, getF~1, sub, call 0,       (* else let val t = tree(n-1) *)
 getF 1, getF~1, con 2, new 4,     (*      in N(n,t,t) end       *)
 return,
 proc(2,44),
 getF~1, getH 1, con 1, eq, cbranch 14,
 getF~2, getH 1, con 1, eq, cbranch 7,
 getF~2, getH 2, getF~1, getH 2, eq, return,
 con 0, return,                               (* return false *)
 getF~2, getH 1, con 2, eq, cbranch~6,
 getF~2, getH 2, getF~1, getH 2, eq, cbranch~12,
 getF~2, getH 3, getF~1, getH 3, call 18, cbranch~18,
 getF~2, getH 4, getF~1, getH 4, call 18, cbranch~24,
 con 1, return,
 con 8, call 0, con 8, call 0, call 18, halt]  (* equal(tree 2, tree 2) *)
;

fun double r = !r before r:= 2 * !r

;
run
[proc(1,9),
 getF~1, getH 1, getF 1, con 2, mul, getF~1, putH 1, return,
 con 13, new 1, getS 0, call 0, getS 0, call 0, getS 0, getH 1, halt]
;

fun f x = fn y => x+y

;
run
[proc(1,9),
 getF~1,
 procH(1,6,1),
 getF~2, getF~1, getH 2, add, return,
 return,
 con 9, con 7, call 0, callH, halt]
;

fun exp x = fn n => if n<=0 then 1 else x * exp x (n-1)

;
run
[proc(1,19),
 getF~1,
 procH(1,16,1),
   con 0, getF~2, leq, cbranch 3,
   con 1, return,
   con 1, getF~2, sub, getF~1, callH,
   getF~1, getH 1, mul, return,
 return,
 con 10, con 2, call 0, callH, halt]
;


fun exp x = let 
	      fun exp' (n,a) = if n<=0 then a else exp'(n-1, a*x)
	    in
	      fn n => exp'(n,1)
	    end

;
run
[proc(1,25),
 getF~1,
 procH(2,16,1),
   con 0, getF~2, leq, cbranch 3,
   getF~3, return,
   getF~1, getH 2, getF~3, mul, 
   con 1, getF~2, sub,
   getF~1, callRH,
 procH(1,6,1),
   con 1, getF~2, getF~1, getH 2, callRH,
 return,
 con 10, con 2, call 0, callH, halt]
;