; load "Int"; type index = int type noi = int (* number of instructions *) type noa = int (* number of arguments *) 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 *) 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 (* ************* *) 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 end = struct val size = 1000 val store = Array.array(size, 0) val sp = ref ~1 (* points to topmost cell *) val fp = ref ~1 (* frame pointer *) fun clear () = (sp:= ~1 ; fp:= ~1) fun getS sa = Array.sub(store, sa) fun putS(sa,v) = Array.update(store, sa, v) fun check sa = if 0<=sa andalso sa <= !sp then sa else raise Error "illegal stack address" fun pushI v = if !sp+1 >= size then raise Error "stack overflow" else (sp:= !sp+1 ; putS(!sp, v)) fun popI () = getS(check(!sp)) before sp:= !sp-1 fun pushS i = pushI(getS(check i)) fun updateS i = putS(check i, popI()) fun pushF noa = (pushI noa ; pushI(!fp) ; fp:= !sp) fun pushFF i = if ~(getS(!fp-1)) <= i andalso i <= !sp then pushI(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 (pushI(getS(!wc)) ; wc:= !wc+1)) fun popF noa = let val start = !sp-noa+1 in sp:= !fp-2-getS(!fp-1) ; fp:= getS(!fp) ; moveS(start, noa) end end (* Stack ******************* *) open ProgramStore Stack val pc = ref 0 exception Halt of int fun getNoa ca = case instr ca of proc(noa,_) => noa | _ => raise Error "wrong program address" fun getFF i = (pushFF i ; 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:= 1+getFF 0 ; popF 1) | callR ca => let val ra = getFF 0 val noa = getNoa ca in popF noa ; pushF noa; 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 at PC "^Int.toString(!pc)) | Error s => raise Error (s^" at PC "^Int.toString(!pc)) end