smallcheck-0.2.1: examples/imperative/Machine.hs

module Machine(Instruction(..), exec) where

import Array
import Behaviour
import Value

data Instruction
  = Push Value
  | Pop
  | Fetch Int
  | Store Int
  | Instr1 Op1
  | Instr2 Op2
  | Display
  | Jump Int
  | JumpUnless Int
  | Halt
 deriving (Eq, Show)
 
exec :: [Instruction] -> Trace Value
exec instrs = run 1 []
  where
  size   = length instrs
  memory = array (1,size) ([1..] `zip` instrs)
  run pc stack =
    if pc < 1 || size < pc then Crash
    else
      case (memory ! pc, stack) of
      (Push x	    , stack)          -> run pc' (x : stack)
      (Pop	    , _ : stack)      -> run pc' stack
      (Fetch n      , stack)	 
        | length stack >  n           -> run pc' (stack !! n : stack)
      (Store n      , x : stack)
        | length stack >= n           -> run pc' (take (n-1) stack ++
                                                  x : drop n stack)
      (Instr1 op1   , i : stack)      -> run pc' (uno op1 i : stack)
      (Instr2 op2   , i : j : stack)  -> run pc' (duo op2 j i : stack)
      (Display      , i : stack)      -> i :> run pc' stack
      (Jump n	    , stack)	      -> step n (run (pc' + n) stack)
      (JumpUnless n , Log b : stack)
        | b	                      -> run pc' stack
        | otherwise                   -> step n (run (pc' + n) stack)
      (Halt	    , stack)	      -> End
      _ 			      -> Crash
     where
      pc' = pc + 1

step :: Int -> Trace Value -> Trace Value    
step n t | n < 0     = Step t
         | otherwise = t