never executed always true always false

    1 module HelVM.HelMA.Automata.ETA.Automaton (
    2   run,
    3   newMemory,
    4 ) where
    5 
    6 import           HelVM.HelMA.Automata.ETA.Addressing
    7 import           HelVM.HelMA.Automata.ETA.OperandParsers
    8 import           HelVM.HelMA.Automata.ETA.Token
    9 
   10 import           HelVM.HelMA.Automaton.Trampoline        as Trampoline
   11 
   12 import           HelVM.HelMA.Automaton.IO.AutomatonIO
   13 
   14 import           HelVM.HelMA.Automaton.Combiner.ALU      as Stack
   15 
   16 import           Control.Monad.Extra
   17 import           Control.Type.Operator
   18 import           HelVM.HelMA.Automata.ETA.Symbol
   19 
   20 import qualified Data.Vector                             as Vector
   21 
   22 import           Prelude                                 hiding (divMod)
   23 
   24 run :: (SAutomatonIO e s m) => Maybe Natural -> Memory s -> m $ Memory s
   25 run = trampolineMWithLimit nextState
   26 
   27 nextState :: (SAutomatonIO e s m) => Memory s -> m $ MemorySame s
   28 nextState (Memory iu s) = build =<< nextIM iu where build (t , iu') = doInstruction t (Memory iu' s)
   29 
   30 doInstruction :: (SAutomatonIO e s m) => Maybe Token -> Memory s -> m $ MemorySame s
   31 -- | IO instructions
   32 doInstruction (Just O) u                        = Trampoline.continue . updateStack u <$> doOutputChar2 (memoryStack u)
   33 doInstruction (Just I) u                        = Trampoline.continue . updateStack u <$> doInputChar2 (memoryStack u)
   34 
   35 -- | Stack instructions
   36 doInstruction (Just N) (Memory iu s)            = build <$> parseNumber iu where build (symbol , iu') = Trampoline.continue (Memory iu' (push1 symbol s))
   37 doInstruction (Just H) u                        = Trampoline.continue . updateStack u <$> halibut (memoryStack u)
   38 
   39 -- | Arithmetic
   40 doInstruction (Just S) u                        = Trampoline.continue . updateStack u <$> sub (memoryStack u)
   41 doInstruction (Just E) u                        = Trampoline.continue . updateStack u <$> divMod (memoryStack u)
   42 
   43 -- | Control
   44 doInstruction (Just R) u                        = pure $ Trampoline.continue  u
   45 doInstruction (Just A) (Memory iu@(IM il ic) s) = pure $ Trampoline.continue  ((Memory iu . flipPush1 s . genericNextLabel il) ic)
   46 doInstruction (Just T) u                        = transfer u
   47 doInstruction Nothing u                         = end u
   48 
   49 transfer :: (SAutomatonIO e s m) => Memory s -> m $ MemorySame s
   50 transfer = branch <=< pop2ForStack where
   51   branch (_ , 0 , u) = pure $ Trampoline.continue  u
   52   branch (0 , _ , u) = end u
   53   branch (l , _ , u) = Trampoline.continue  . updateAddress u <$> genericFindAddress (memoryProgram u) l
   54 
   55 pop2ForStack :: (SAutomatonIO e s m) => Memory s -> m (e , e , Memory s)
   56 pop2ForStack u = build <$> pop2 (memoryStack u) where
   57   build (s1 , s2 , s') = (s1 , s2 , updateStack u s')
   58 
   59 -- | Terminate instruction
   60 end :: (SAutomatonIO e s m) => Memory s -> m $ MemorySame s
   61 end = pure . Trampoline.break
   62 
   63 -- | Memory methods
   64 
   65 newMemory :: TokenList -> s -> Memory s
   66 newMemory tl = Memory (IM (Vector.fromList tl) 0)
   67 
   68 updateStack :: Memory s -> s -> Memory s
   69 updateStack u s =  u {memoryStack = s}
   70 
   71 updateAddress :: Memory s -> InstructionCounter -> Memory s
   72 updateAddress u a =  u {memoryIM = updatePC (memoryIM u) a}
   73 
   74 memoryProgram :: Memory s -> TokenVector
   75 memoryProgram = program . memoryIM
   76 
   77 -- | Types
   78 
   79 type MemorySame s = Same (Memory s)
   80 
   81 data Memory s = Memory
   82   { memoryIM    :: !InstructionMemory
   83   , memoryStack :: s
   84   }
   85   deriving stock (Eq , Read , Show)