{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}

-- | Inspired by https://www.greenarraychips.com/home/documents/greg/DB001-221113-F18a.pdf
module Wrench.Isa.F32a (
    F32aIsa (..),
    F32aSt (..),
    f32aMnemonics,
) where

import Data.Bits (Bits (..), clearBit, complement, setBit, shiftL, shiftR, testBit, (.&.))
import Data.Default (def)
import Data.List (lookup)
import Relude
import Text.Megaparsec (anySingleBut, choice, getSourcePos, try)
import Text.Megaparsec.Char (char, hspace, hspace1, string)
import Wrench.Machine.Memory
import Wrench.Machine.Types
import Wrench.Machine.Word
import Wrench.Report
import Wrench.Report.View (Format (..), Stat (..), format, lit, mkView)
import Wrench.Translator.Parser.Misc
import Wrench.Translator.Parser.Types
import Wrench.Translator.Types

data F32aIsa w l
    = -- | > ; ( -- )
      --
      -- Return: pops the return stack into P.
      Return
    | -- | > <address: i32> ( -- )
      --
      -- Call, written as a bare label: pushes the address of the next
      -- instruction onto the return stack and jumps.
      Call l
    | -- | > lit <value: i32> ( -- value: i32 )
      --
      -- Push a literal. A bare number is the same instruction.
      Lit l
    | -- | > next <address: i32> ( -- )
      --
      -- Loop: pops R; falls through when it was @0@, otherwise pushes
      -- @R-1@ back and jumps.
      Next l
    | -- | > <address: i32> ; ( -- )
      --
      -- Jump, written as a label followed by @;@.
      Jump l
    | -- | > if <address: i32> ( flag: i32 -- )
      --
      -- Pops T: continues with the next instruction word if it was
      -- non-zero, jumps if it was zero.
      If l
    | -- | > -if <address: i32> ( value: i32 -- )
      --
      -- Minus-if. Pops T: continues with the next instruction word if it
      -- was negative (T[31] set), jumps if it was non-negative.
      MinusIf l
    | -- | > a! ( value: i32 -- )
      --
      -- A-Store. Stores T into register A, popping the data stack.
      AStore
    | -- | > b! ( value: i32 -- )
      --
      -- B-Store. Stores T into register B, popping the data stack.
      BStore
    | -- | > @p <address: i32> ( -- value: i32 )
      --
      -- Pushes the data stack, reads [P] into T, and increments P.
      FetchP l
    | -- | > @+ ( -- value: i32 )
      --
      -- Fetch-plus. Pushes the data stack, reads [A] into T, and
      -- increments A.
      FetchPlus
    | -- | > @b ( -- value: i32 )
      --
      -- Fetch-B. Pushes the data stack and reads [B] into T.
      FetchB
    | -- | > @ ( -- value: i32 )
      --
      -- Fetch. Pushes the data stack and reads [A] into T.
      Fetch
    | -- | > !p <address: i32> ( value: i32 -- )
      --
      -- Store-P. Writes T into [P], pops the data stack, and increments P.
      StoreP l
    | -- | > !b ( value: i32 -- )
      --
      -- Store-B. Writes T into [B] and pops the data stack.
      StoreB
    | -- | > !+ ( value: i32 -- )
      --
      -- Store-plus. Writes T into [A], pops the data stack, and increments
      -- A.
      StorePlus
    | -- | > ! ( value: i32 -- )
      --
      -- Writes T into [A] and pops the data stack.
      Store
    | -- | > +* ( s: i32, t: i32 -- s: i32, t: i32 )
      --
      -- Multiply step. Leaves S alone, replaces T, and shifts A: one
      -- iteration of a shift-and-add multiply.
      MulStep
    | -- | > +/ ( remainder: i32, quotient: i32 -- remainder: i32, quotient: i32 )
      --
      -- Divide step: A holds the dividend, [B] the divisor, T the quotient
      -- so far and S the remainder (details:
      -- example\/step-by-step-div.py).
      DivStep
    | -- | > 2* ( value: i32 -- shifted: i32 )
      --
      -- Left shift.
      LShift
    | -- | > 2/ ( value: i32 -- shifted: i32 )
      --
      -- Right shift (signed).
      RShift
    | -- | > inv ( value: i32 -- inverted: i32 )
      --
      -- Invert all bits (was @~@).
      Inv
    | -- | > + ( s: i32, t: i32 -- sum: i32 )
      --
      -- Add, or add with carry in extended arithmetic mode.
      Add
    | -- | > eam ( flag: i32 -- )
      --
      -- Set arithmetic mode: pops T, extended iff it was non-zero.
      Eam
    | -- | > and ( s: i32, t: i32 -- bits: i32 )
      And
    | -- | > xor ( s: i32, t: i32 -- bits: i32 )
      --
      -- Exclusive Or. Replaces T with the Boolean XOR of S and T. Pops the
      -- data stack.
      Xor
    | -- | > drop ( value: i32 -- )
      --
      -- Drop. Pops the data stack.
      Drop
    | -- | > dup ( value: i32 -- value: i32, value: i32 )
      --
      -- Dup. Duplicates T on the data stack.
      Dup
    | -- | > r> ( -- value: i32 )
      --
      -- Moves R into T, popping the return stack and pushing the data
      -- stack.
      RIntoT
    | -- | > >r ( value: i32 -- )
      --
      -- Moves T into R, pushing the return stack and popping the data
      -- stack.
      TIntoR
    | -- | > over ( s: i32, t: i32 -- s: i32, t: i32, s: i32 )
      --
      -- Copies S over the top of the data stack.
      Over
    | -- | > a ( -- value: i32 )
      --
      -- Fetches the contents of register A into T, pushing the data stack.
      AFetch
    | -- | > halt ( -- )
      Halt
    deriving (Int -> F32aIsa w l -> ShowS
[F32aIsa w l] -> ShowS
F32aIsa w l -> [Char]
(Int -> F32aIsa w l -> ShowS)
-> (F32aIsa w l -> [Char])
-> ([F32aIsa w l] -> ShowS)
-> Show (F32aIsa w l)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall w l. Show l => Int -> F32aIsa w l -> ShowS
forall w l. Show l => [F32aIsa w l] -> ShowS
forall w l. Show l => F32aIsa w l -> [Char]
$cshowsPrec :: forall w l. Show l => Int -> F32aIsa w l -> ShowS
showsPrec :: Int -> F32aIsa w l -> ShowS
$cshow :: forall w l. Show l => F32aIsa w l -> [Char]
show :: F32aIsa w l -> [Char]
$cshowList :: forall w l. Show l => [F32aIsa w l] -> ShowS
showList :: [F32aIsa w l] -> ShowS
Show)

-- | Every word the 'MnemonicParser' instance accepts as an instruction.
f32aMnemonics :: [Text]
f32aMnemonics :: [Text]
f32aMnemonics =
    [ Text
"lit"
    , Text
"next"
    , Text
"if"
    , Text
"-if"
    , Text
"a!"
    , Text
"b!"
    , Text
"+*"
    , Text
"+/"
    , Text
"2*"
    , Text
"2/"
    , Text
"inv"
    , Text
"+"
    , Text
"eam"
    , Text
"and"
    , Text
"xor"
    , Text
"drop"
    , Text
"dup"
    , Text
"over"
    , Text
"a"
    , Text
"@p"
    , Text
"@+"
    , Text
"@b"
    , Text
"@"
    , Text
"!p"
    , Text
"!b"
    , Text
"!+"
    , Text
"!"
    , Text
"r>"
    , Text
">r"
    , Text
"halt"
    , Text
";"
    ]

instance CommentStart (F32aIsa w l) where
    commentStart :: [Char]
commentStart = [Char]
"\\"

instance (IsWord w) => MnemonicParser (F32aIsa w (Ref w)) where
    mnemonic :: Parser (F32aIsa w (Ref w))
mnemonic =
        [Parser (F32aIsa w (Ref w))] -> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
Lit (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"lit"
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
Next (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"next"
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
If (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"if"
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
MinusIf (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"-if"
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"a!" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
AStore
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"b!" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
BStore
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"+*" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
MulStep
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"+/" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
DivStep
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"2*" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
LShift
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"2/" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
RShift
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"inv" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Inv
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"+" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Add
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"eam" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Eam
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"and" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
And
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"xor" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Xor
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"drop" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Drop
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"dup" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Dup
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"over" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Over
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"a" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
AFetch
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
FetchP (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"@p"
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"@+" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
FetchPlus
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"@b" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
FetchB
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"@" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Fetch
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
StoreP (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
"!p"
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"!b" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
StoreB
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"!+" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
StorePlus
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"!" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Store
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"r>" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
RIntoT
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
">r" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
TIntoR
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
"halt" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Halt
            , [Char] -> Parser ()
cmdMnemonic0 [Char]
";" Parser ()
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> F32aIsa w (Ref w) -> Parser (F32aIsa w (Ref w))
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return F32aIsa w (Ref w)
forall w l. F32aIsa w l
Return
            , Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a.
ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w)))
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b. (a -> b) -> a -> b
$ do
                label <- ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => Parser (Ref w)
reference
                hspace1
                void $ string ";"
                return $ Jump label
            , Ref w -> F32aIsa w (Ref w)
forall w l. l -> F32aIsa w l
Lit (Ref w -> F32aIsa w (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> Parser (F32aIsa w (Ref w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => Parser (Ref w)
bareLiteral
            , Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a.
ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w)))
-> Parser (F32aIsa w (Ref w)) -> Parser (F32aIsa w (Ref w))
forall a b. (a -> b) -> a -> b
$ do
                label <- ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => Parser (Ref w)
reference
                hspace1 <|> eol' "\\"
                return $ Call label
            ]

bareLiteral :: (IsWord w) => Parser (Ref w)
bareLiteral :: forall w. IsWord w => Parser (Ref w)
bareLiteral = ParsecT Void [Char] Identity (Ref w)
-> ParsecT Void [Char] Identity (Ref w)
forall a.
ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void [Char] Identity (Ref w)
 -> ParsecT Void [Char] Identity (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> ParsecT Void [Char] Identity (Ref w)
forall a b. (a -> b) -> a -> b
$ do
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
    pos <- ParsecT Void [Char] Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    ref <-
        choice
            [ do
                void $ char '\''
                c <- anySingleBut '\''
                void $ char '\''
                return $ ValueR id pos $ fromIntegral $ ord c
            , ValueR id pos <$> wordLiteral
            ]
    hspace1 <|> eol' "\\"
    return ref

cmdMnemonic0 :: String -> Parser ()
cmdMnemonic0 :: [Char] -> Parser ()
cmdMnemonic0 [Char]
mnemonic = Parser () -> Parser ()
forall a.
ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
    ParsecT Void [Char] Identity (Tokens [Char]) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char]
Tokens [Char]
mnemonic)
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 Parser () -> Parser () -> Parser ()
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Parser ()
eol' [Char]
"\\"

cmdMnemonic1 :: (IsWord w) => String -> Parser (Ref w)
cmdMnemonic1 :: forall w. IsWord w => [Char] -> Parser (Ref w)
cmdMnemonic1 [Char]
mnemonic = ParsecT Void [Char] Identity (Ref w)
-> ParsecT Void [Char] Identity (Ref w)
forall a.
ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void [Char] Identity (Ref w)
 -> ParsecT Void [Char] Identity (Ref w))
-> ParsecT Void [Char] Identity (Ref w)
-> ParsecT Void [Char] Identity (Ref w)
forall a b. (a -> b) -> a -> b
$ do
    Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
    ParsecT Void [Char] Identity (Tokens [Char]) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Char]
Tokens [Char]
mnemonic)
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1
    ref <- ParsecT Void [Char] Identity (Ref w)
forall w. IsWord w => Parser (Ref w)
reference
    hspace1 <|> eol' "\\"
    return ref

instance DerefMnemonic (F32aIsa w) w where
    derefMnemonic :: (Text -> Maybe w) -> w -> F32aIsa w (Ref w) -> F32aIsa w w
derefMnemonic Text -> Maybe w
f w
_offset F32aIsa w (Ref w)
i =
        case F32aIsa w (Ref w)
i of
            Lit Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
Lit ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            Call Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
Call ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            F32aIsa w (Ref w)
Return -> F32aIsa w w
forall w l. F32aIsa w l
Return
            Jump Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
Jump ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            Next Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
Next ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            If Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
If ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            MinusIf Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
MinusIf ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            F32aIsa w (Ref w)
AStore -> F32aIsa w w
forall w l. F32aIsa w l
AStore
            F32aIsa w (Ref w)
BStore -> F32aIsa w w
forall w l. F32aIsa w l
BStore
            F32aIsa w (Ref w)
AFetch -> F32aIsa w w
forall w l. F32aIsa w l
AFetch
            FetchP Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
FetchP ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            F32aIsa w (Ref w)
Fetch -> F32aIsa w w
forall w l. F32aIsa w l
Fetch
            F32aIsa w (Ref w)
FetchPlus -> F32aIsa w w
forall w l. F32aIsa w l
FetchPlus
            F32aIsa w (Ref w)
FetchB -> F32aIsa w w
forall w l. F32aIsa w l
FetchB
            StoreP Ref w
l -> w -> F32aIsa w w
forall w l. l -> F32aIsa w l
StoreP ((w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
forall w. (w -> Either Text w) -> (Text -> Maybe w) -> Ref w -> w
resolveRef w -> Either Text w
forall a b. b -> Either a b
Right Text -> Maybe w
f Ref w
l)
            F32aIsa w (Ref w)
StoreB -> F32aIsa w w
forall w l. F32aIsa w l
StoreB
            F32aIsa w (Ref w)
StorePlus -> F32aIsa w w
forall w l. F32aIsa w l
StorePlus
            F32aIsa w (Ref w)
Store -> F32aIsa w w
forall w l. F32aIsa w l
Store
            F32aIsa w (Ref w)
RIntoT -> F32aIsa w w
forall w l. F32aIsa w l
RIntoT
            F32aIsa w (Ref w)
TIntoR -> F32aIsa w w
forall w l. F32aIsa w l
TIntoR
            F32aIsa w (Ref w)
MulStep -> F32aIsa w w
forall w l. F32aIsa w l
MulStep
            F32aIsa w (Ref w)
DivStep -> F32aIsa w w
forall w l. F32aIsa w l
DivStep
            F32aIsa w (Ref w)
LShift -> F32aIsa w w
forall w l. F32aIsa w l
LShift
            F32aIsa w (Ref w)
RShift -> F32aIsa w w
forall w l. F32aIsa w l
RShift
            F32aIsa w (Ref w)
Inv -> F32aIsa w w
forall w l. F32aIsa w l
Inv
            F32aIsa w (Ref w)
Add -> F32aIsa w w
forall w l. F32aIsa w l
Add
            F32aIsa w (Ref w)
Eam -> F32aIsa w w
forall w l. F32aIsa w l
Eam
            F32aIsa w (Ref w)
And -> F32aIsa w w
forall w l. F32aIsa w l
And
            F32aIsa w (Ref w)
Xor -> F32aIsa w w
forall w l. F32aIsa w l
Xor
            F32aIsa w (Ref w)
Drop -> F32aIsa w w
forall w l. F32aIsa w l
Drop
            F32aIsa w (Ref w)
Dup -> F32aIsa w w
forall w l. F32aIsa w l
Dup
            F32aIsa w (Ref w)
Over -> F32aIsa w w
forall w l. F32aIsa w l
Over
            F32aIsa w (Ref w)
Halt -> F32aIsa w w
forall w l. F32aIsa w l
Halt

instance ByteSize (F32aIsa w l) where
    -- NOTE: in f18a multiple instructions can be fitted in one machine word.
    -- Here we simplify it: args -- is just a muchine word. Opcode -- one byte.
    byteSize :: F32aIsa w l -> Int
byteSize (Lit l
_) = Int
5
    byteSize (Call l
_) = Int
5
    byteSize (Jump l
_) = Int
5
    byteSize (Next l
_) = Int
5
    byteSize (If l
_) = Int
5
    byteSize (MinusIf l
_) = Int
5
    byteSize (FetchP l
_) = Int
5
    byteSize (StoreP l
_) = Int
5
    byteSize F32aIsa w l
_ = Int
1

data F32aSt w = F32aSt
    { forall w. F32aSt w -> Int
p :: Int
    , forall w. F32aSt w -> w
a :: w
    , forall w. F32aSt w -> w
b :: w
    , forall w. F32aSt w -> IoMem (F32aIsa w w) w
ram :: IoMem (F32aIsa w w) w
    , forall w. F32aSt w -> [(Int, F32aIsa w w)]
ir :: [(Int, F32aIsa w w)]
    -- ^ Instruction register: the instructions of the last fetched words, by address.
    , forall w. F32aSt w -> [w]
dataStack :: [w]
    , forall w. F32aSt w -> [w]
returnStack :: [w]
    , forall w. F32aSt w -> Int
dataStackMax :: !Int
    -- ^ High-water mark of the data stack depth over the run (for f32a:data-stack-max).
    , forall w. F32aSt w -> Int
returnStackMax :: !Int
    -- ^ High-water mark of the return stack depth over the run (for f32a:return-stack-max).
    , forall w. F32aSt w -> Bool
stopped :: Bool
    , forall w. F32aSt w -> Bool
extendedArithmeticMode :: Bool
    , forall w. F32aSt w -> Bool
carryFlag :: Bool
    , forall w. F32aSt w -> Maybe Text
internalError :: Maybe Text
    }
    deriving (Int -> F32aSt w -> ShowS
[F32aSt w] -> ShowS
F32aSt w -> [Char]
(Int -> F32aSt w -> ShowS)
-> (F32aSt w -> [Char]) -> ([F32aSt w] -> ShowS) -> Show (F32aSt w)
forall w. Show w => Int -> F32aSt w -> ShowS
forall w. Show w => [F32aSt w] -> ShowS
forall w. Show w => F32aSt w -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall w. Show w => Int -> F32aSt w -> ShowS
showsPrec :: Int -> F32aSt w -> ShowS
$cshow :: forall w. Show w => F32aSt w -> [Char]
show :: F32aSt w -> [Char]
$cshowList :: forall w. Show w => [F32aSt w] -> ShowS
showList :: [F32aSt w] -> ShowS
Show)

type instance MemOf (F32aSt w) = IoMem (F32aIsa w w) w

instance (IsWord w) => InitState (F32aSt w) where
    initState :: Int -> MemOf (F32aSt w) -> StdGen -> F32aSt w
initState Int
pc MemOf (F32aSt w)
dump StdGen
_randomGen =
        F32aSt
            { p :: Int
p = Int
pc
            , a :: w
a = w
forall a. Default a => a
def
            , b :: w
b = w
forall a. Default a => a
def
            , dataStack :: [w]
dataStack = []
            , returnStack :: [w]
returnStack = []
            , dataStackMax :: Int
dataStackMax = Int
0
            , returnStackMax :: Int
returnStackMax = Int
0
            , ram :: IoMem (F32aIsa w w) w
ram = IoMem (F32aIsa w w) w
MemOf (F32aSt w)
dump
            , ir :: [(Int, F32aIsa w w)]
ir = []
            , stopped :: Bool
stopped = Bool
False
            , extendedArithmeticMode :: Bool
extendedArithmeticMode = Bool
False
            , carryFlag :: Bool
carryFlag = Bool
False
            , internalError :: Maybe Text
internalError = Maybe Text
forall a. Maybe a
Nothing
            }

setP :: forall w. Int -> State (F32aSt w) ()
setP :: forall w. Int -> State (F32aSt w) ()
setP Int
addr = (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ())
-> (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{p = addr}

raiseInternalError :: Text -> State (F32aSt w) ()
raiseInternalError :: forall w. Text -> State (F32aSt w) ()
raiseInternalError Text
msg = (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ())
-> (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{internalError = Just msg}

getWord :: Int -> StateT (F32aSt b) Identity b
getWord Int
addr = do
    st@F32aSt{ram} <- StateT (F32aSt b) Identity (F32aSt b)
forall s (m :: * -> *). MonadState s m => m s
get
    case readWord ram addr of
        Right (IoMem (F32aIsa b b) b
ram', b
w) -> do
            F32aSt b -> StateT (F32aSt b) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put F32aSt b
st{ram = ram'}
            b -> StateT (F32aSt b) Identity b
forall a. a -> StateT (F32aSt b) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return b
w
        Left Text
err -> do
            Text -> StateT (F32aSt b) Identity ()
forall w. Text -> State (F32aSt w) ()
raiseInternalError (Text -> StateT (F32aSt b) Identity ())
-> Text -> StateT (F32aSt b) Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"memory access error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            b -> StateT (F32aSt b) Identity b
forall a. a -> StateT (F32aSt b) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. Default a => a
def

setWord :: Int -> w -> StateT (F32aSt w) Identity ()
setWord Int
addr w
w = do
    st@F32aSt{ram} <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    case writeWord ram addr w of
        Right IoMem (F32aIsa w w) w
ram' -> F32aSt w -> StateT (F32aSt w) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put F32aSt w
st{ram = ram'}
        Left Text
err -> Text -> StateT (F32aSt w) Identity ()
forall w. Text -> State (F32aSt w) ()
raiseInternalError (Text -> StateT (F32aSt w) Identity ())
-> Text -> StateT (F32aSt w) Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"memory access error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err

dataPush :: w -> StateT (F32aSt w) Identity ()
dataPush w
w = do
    Bool -> StateT (F32aSt w) Identity ()
forall w. Bool -> State (F32aSt w) ()
setCarryFlag Bool
False
    st@F32aSt{dataStack, dataStackMax} <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    let dataStack' = w
w w -> [w] -> [w]
forall a. a -> [a] -> [a]
: [w]
dataStack
    put st{dataStack = dataStack', dataStackMax = max dataStackMax (length dataStack')}

dataPop :: (IsWord w) => State (F32aSt w) w
dataPop :: forall w. IsWord w => State (F32aSt w) w
dataPop = do
    st@F32aSt{dataStack} <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    case dataStack of
        [] -> do
            Text -> State (F32aSt w) ()
forall w. Text -> State (F32aSt w) ()
raiseInternalError Text
"empty data stack"
            w -> StateT (F32aSt w) Identity w
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
forall a. Default a => a
def
        (w
x : [w]
xs) -> do
            F32aSt w -> State (F32aSt w) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put F32aSt w
st{dataStack = xs}
            w -> StateT (F32aSt w) Identity w
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
x

returnPush :: w -> m ()
returnPush w
w = do
    st@F32aSt{returnStack, returnStackMax} <- m (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    let returnStack' = w
w w -> [w] -> [w]
forall a. a -> [a] -> [a]
: [w]
returnStack
    put st{returnStack = returnStack', returnStackMax = max returnStackMax (length returnStack')}

returnPop :: (IsWord w) => State (F32aSt w) w
returnPop :: forall w. IsWord w => State (F32aSt w) w
returnPop = do
    st@F32aSt{returnStack} <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    case returnStack of
        [] -> do
            Text -> State (F32aSt w) ()
forall w. Text -> State (F32aSt w) ()
raiseInternalError Text
"empty return stack"
            w -> StateT (F32aSt w) Identity w
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
forall a. Default a => a
def
        (w
x : [w]
xs) -> do
            F32aSt w -> State (F32aSt w) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put F32aSt w
st{returnStack = xs}
            w -> StateT (F32aSt w) Identity w
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return w
x

setExtendedArithmeticMode :: Bool -> State (F32aSt w) ()
setExtendedArithmeticMode :: forall w. Bool -> State (F32aSt w) ()
setExtendedArithmeticMode Bool
flag = (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ())
-> (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{extendedArithmeticMode = flag}

setCarryFlag :: Bool -> State (F32aSt w) ()
setCarryFlag :: forall w. Bool -> State (F32aSt w) ()
setCarryFlag Bool
flag = (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ())
-> (F32aSt w -> F32aSt w) -> StateT (F32aSt w) Identity ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{carryFlag = flag}

getCarryFlag :: State (F32aSt w) Bool
getCarryFlag :: forall w. State (F32aSt w) Bool
getCarryFlag = StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get StateT (F32aSt w) Identity (F32aSt w)
-> (F32aSt w -> Bool) -> StateT (F32aSt w) Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> F32aSt w -> Bool
forall w. F32aSt w -> Bool
carryFlag

setA :: w -> m ()
setA w
w = (F32aSt w -> F32aSt w) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> m ()) -> (F32aSt w -> F32aSt w) -> m ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{a = w}

setB :: w -> m ()
setB w
w = (F32aSt w -> F32aSt w) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> m ()) -> (F32aSt w -> F32aSt w) -> m ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{b = w}

getA :: State (F32aSt w) w
getA :: forall w. State (F32aSt w) w
getA = do
    F32aSt{a} <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
    return a

getB :: State (F32aSt w) w
getB :: forall w. State (F32aSt w) w
getB = StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get StateT (F32aSt w) Identity (F32aSt w)
-> (F32aSt w -> w) -> StateT (F32aSt w) Identity w
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> F32aSt w -> w
forall w. F32aSt w -> w
b

instance (IsWord w) => Inspectable (F32aSt w) where
    type WordOf (F32aSt w) = w
    type IsaOf (F32aSt w) = F32aIsa w w

    programCounter :: F32aSt w -> Int
programCounter F32aSt{Int
p :: forall w. F32aSt w -> Int
p :: Int
p} = Int
p
    memoryDump :: F32aSt w -> MemOf (F32aSt w)
memoryDump F32aSt{IoMem (F32aIsa w w) w
ram :: forall w. F32aSt w -> IoMem (F32aIsa w w) w
ram :: IoMem (F32aIsa w w) w
ram} = IoMem (F32aIsa w w) w
MemOf (F32aSt w)
ram
    ioStreams :: F32aSt w -> IntMap ([WordOf (F32aSt w)], [WordOf (F32aSt w)])
ioStreams F32aSt{ram :: forall w. F32aSt w -> IoMem (F32aIsa w w) w
ram = IoMem{IntMap ([w], [w])
mIoStreams :: IntMap ([w], [w])
mIoStreams :: forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams}} = IntMap ([w], [w])
IntMap ([WordOf (F32aSt w)], [WordOf (F32aSt w)])
mIoStreams
    isHalted :: F32aSt w -> Bool
isHalted F32aSt{Bool
stopped :: forall w. F32aSt w -> Bool
stopped :: Bool
stopped} = Bool
stopped
    views :: [View (StateEnv (F32aSt w))]
views =
        [ Text
-> Text -> (StateEnv (F32aSt w) -> w) -> View (StateEnv (F32aSt w))
forall a env.
(Integral a, Show a) =>
Text -> Text -> (env -> a) -> View env
valueView Text
"A" Text
"Register `A`." (F32aSt w -> w
forall w. F32aSt w -> w
a (F32aSt w -> w)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text
-> Text -> (StateEnv (F32aSt w) -> w) -> View (StateEnv (F32aSt w))
forall a env.
(Integral a, Show a) =>
Text -> Text -> (env -> a) -> View env
valueView Text
"B" Text
"Register `B`." (F32aSt w -> w
forall w. F32aSt w -> w
b (F32aSt w -> w)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text
-> Text -> (StateEnv (F32aSt w) -> w) -> View (StateEnv (F32aSt w))
forall a env.
(Integral a, Show a) =>
Text -> Text -> (env -> a) -> View env
valueView Text
"T" Text
"Top of the data stack, `0` if empty." (w -> Maybe w -> w
forall a. a -> Maybe a -> a
fromMaybe w
0 (Maybe w -> w)
-> (StateEnv (F32aSt w) -> Maybe w) -> StateEnv (F32aSt w) -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([w] -> Int -> Maybe w
forall a. [a] -> Int -> Maybe a
!!? Int
0) ([w] -> Maybe w)
-> (StateEnv (F32aSt w) -> [w]) -> StateEnv (F32aSt w) -> Maybe w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> [w]
forall w. F32aSt w -> [w]
dataStack (F32aSt w -> [w])
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text
-> Text -> (StateEnv (F32aSt w) -> w) -> View (StateEnv (F32aSt w))
forall a env.
(Integral a, Show a) =>
Text -> Text -> (env -> a) -> View env
valueView Text
"S" Text
"Second on the data stack, `0` if absent." (w -> Maybe w -> w
forall a. a -> Maybe a -> a
fromMaybe w
0 (Maybe w -> w)
-> (StateEnv (F32aSt w) -> Maybe w) -> StateEnv (F32aSt w) -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([w] -> Int -> Maybe w
forall a. [a] -> Int -> Maybe a
!!? Int
1) ([w] -> Maybe w)
-> (StateEnv (F32aSt w) -> [w]) -> StateEnv (F32aSt w) -> Maybe w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> [w]
forall w. F32aSt w -> [w]
dataStack (F32aSt w -> [w])
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text
-> Text -> (StateEnv (F32aSt w) -> w) -> View (StateEnv (F32aSt w))
forall a env.
(Integral a, Show a) =>
Text -> Text -> (env -> a) -> View env
valueView Text
"R" Text
"Top of the return stack, `0` if empty." (w -> Maybe w -> w
forall a. a -> Maybe a -> a
fromMaybe w
0 (Maybe w -> w)
-> (StateEnv (F32aSt w) -> Maybe w) -> StateEnv (F32aSt w) -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([w] -> Int -> Maybe w
forall a. [a] -> Int -> Maybe a
!!? Int
0) ([w] -> Maybe w)
-> (StateEnv (F32aSt w) -> [w]) -> StateEnv (F32aSt w) -> Maybe w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> [w]
forall w. F32aSt w -> [w]
returnStack (F32aSt w -> [w])
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text -> Text -> (F32aSt w -> [w]) -> View (StateEnv (F32aSt w))
forall {a} {t}.
(Integral a, Show a) =>
Text -> Text -> (t -> [a]) -> View (StateEnv t)
stack Text
"stack" Text
"Data stack, top first: `a:b:c`." F32aSt w -> [w]
forall w. F32aSt w -> [w]
dataStack
        , Text -> Text -> (F32aSt w -> [w]) -> View (StateEnv (F32aSt w))
forall {a} {t}.
(Integral a, Show a) =>
Text -> Text -> (t -> [a]) -> View (StateEnv t)
stack Text
"rstack" Text
"Return stack, top first: `a:b:c`." F32aSt w -> [w]
forall w. F32aSt w -> [w]
returnStack
        , Text
-> Text
-> (StateEnv (F32aSt w) -> Text)
-> View (StateEnv (F32aSt w))
forall env. Text -> Text -> (env -> Text) -> View env
flagView Text
"EAM" Text
"Extended arithmetic mode, `1` or `0`." (Bool -> Text
forall {a}. IsString a => Bool -> a
bit (Bool -> Text)
-> (StateEnv (F32aSt w) -> Bool) -> StateEnv (F32aSt w) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> Bool
forall w. F32aSt w -> Bool
extendedArithmeticMode (F32aSt w -> Bool)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        , Text
-> Text
-> (StateEnv (F32aSt w) -> Text)
-> View (StateEnv (F32aSt w))
forall env. Text -> Text -> (env -> Text) -> View env
flagView Text
"C" Text
"Carry flag, `1` or `0`." (Bool -> Text
forall {a}. IsString a => Bool -> a
bit (Bool -> Text)
-> (StateEnv (F32aSt w) -> Bool) -> StateEnv (F32aSt w) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> Bool
forall w. F32aSt w -> Bool
carryFlag (F32aSt w -> Bool)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seState)
        ]
        where
            stack :: Text -> Text -> (t -> [a]) -> View (StateEnv t)
stack Text
name Text
doc t -> [a]
f = Spec Format
-> Text -> (StateEnv t -> Format -> Text) -> View (StateEnv t)
forall a env. Spec a -> Text -> (env -> a -> Text) -> View env
mkView (Text -> Spec ()
lit Text
name Spec () -> Spec Format -> Spec Format
forall a b. Spec a -> Spec b -> Spec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Format] -> Format -> Spec Format
format [Format
Dec, Format
Hex] Format
Dec) Text
doc ((StateEnv t -> Format -> Text) -> View (StateEnv t))
-> (StateEnv t -> Format -> Text) -> View (StateEnv t)
forall a b. (a -> b) -> a -> b
$ \StateEnv{t
seState :: forall st. StateEnv st -> st
seState :: t
seState} Format
fmt -> Format -> [a] -> Text
forall a. (Integral a, Show a) => Format -> [a] -> Text
showValues Format
fmt (t -> [a]
f t
seState)
            bit :: Bool -> a
bit Bool
f = if Bool
f then a
"1" else a
"0"

    isaStats :: [Stat (StateEnv (F32aSt w))]
isaStats =
        [ Text
-> Text
-> (StateEnv (F32aSt w) -> Text)
-> Stat (StateEnv (F32aSt w))
forall env. Text -> Text -> (env -> Text) -> Stat env
Stat Text
"f32a:data-stack-max" Text
"Deepest data stack of the run." (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text)
-> (StateEnv (F32aSt w) -> Int) -> StateEnv (F32aSt w) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> Int
forall w. F32aSt w -> Int
dataStackMax (F32aSt w -> Int)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seFinal)
        , Text
-> Text
-> (StateEnv (F32aSt w) -> Text)
-> Stat (StateEnv (F32aSt w))
forall env. Text -> Text -> (env -> Text) -> Stat env
Stat Text
"f32a:return-stack-max" Text
"Deepest return stack of the run." (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text)
-> (StateEnv (F32aSt w) -> Int) -> StateEnv (F32aSt w) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F32aSt w -> Int
forall w. F32aSt w -> Int
returnStackMax (F32aSt w -> Int)
-> (StateEnv (F32aSt w) -> F32aSt w) -> StateEnv (F32aSt w) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateEnv (F32aSt w) -> F32aSt w
forall st. StateEnv st -> st
seFinal)
        ]

instance (IsWord w) => Machine (F32aSt w) (F32aIsa w w) w where
    instructionFetch :: State (F32aSt w) (Either Text (Int, F32aIsa w w))
instructionFetch = do
        st <- StateT (F32aSt w) Identity (F32aSt w)
forall s (m :: * -> *). MonadState s m => m s
get
        case st of
            F32aSt{stopped :: forall w. F32aSt w -> Bool
stopped = Bool
True} -> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, F32aIsa w w)
 -> State (F32aSt w) (Either Text (Int, F32aIsa w w)))
-> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Int, F32aIsa w w)
forall a b. a -> Either a b
Left Text
halted
            F32aSt{internalError :: forall w. F32aSt w -> Maybe Text
internalError = Just Text
err} -> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, F32aIsa w w)
 -> State (F32aSt w) (Either Text (Int, F32aIsa w w)))
-> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Int, F32aIsa w w)
forall a b. a -> Either a b
Left Text
err
            F32aSt{Int
p :: forall w. F32aSt w -> Int
p :: Int
p, [(Int, F32aIsa w w)]
ir :: forall w. F32aSt w -> [(Int, F32aIsa w w)]
ir :: [(Int, F32aIsa w w)]
ir}
                | Just F32aIsa w w
instruction <- Int -> [(Int, F32aIsa w w)] -> Maybe (F32aIsa w w)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
p [(Int, F32aIsa w w)]
ir -> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, F32aIsa w w)
 -> State (F32aSt w) (Either Text (Int, F32aIsa w w)))
-> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a b. (a -> b) -> a -> b
$ (Int, F32aIsa w w) -> Either Text (Int, F32aIsa w w)
forall a b. b -> Either a b
Right (Int
p, F32aIsa w w
instruction)
            F32aSt{Int
p :: forall w. F32aSt w -> Int
p :: Int
p, IoMem (F32aIsa w w) w
ram :: forall w. F32aSt w -> IoMem (F32aIsa w w) w
ram :: IoMem (F32aIsa w w) w
ram} ->
                case IoMem (F32aIsa w w) w
-> Int
-> Either Text (IoMem (F32aIsa w w) w, NonEmpty (Int, F32aIsa w w))
forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w
-> Int -> Either Text (IoMem isa w, NonEmpty (Int, isa))
readInstructions IoMem (F32aIsa w w) w
ram Int
p of
                    Left Text
err -> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, F32aIsa w w)
 -> State (F32aSt w) (Either Text (Int, F32aIsa w w)))
-> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Int, F32aIsa w w)
forall a b. a -> Either a b
Left Text
err
                    Right (IoMem (F32aIsa w w) w
ram', fetched :: NonEmpty (Int, F32aIsa w w)
fetched@((Int
_, F32aIsa w w
instruction) :| [(Int, F32aIsa w w)]
_)) -> do
                        F32aSt w -> State (F32aSt w) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put F32aSt w
st{ram = ram', ir = toList fetched}
                        Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a. a -> StateT (F32aSt w) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Int, F32aIsa w w)
 -> State (F32aSt w) (Either Text (Int, F32aIsa w w)))
-> Either Text (Int, F32aIsa w w)
-> State (F32aSt w) (Either Text (Int, F32aIsa w w))
forall a b. (a -> b) -> a -> b
$ (Int, F32aIsa w w) -> Either Text (Int, F32aIsa w w)
forall a b. b -> Either a b
Right (Int
p, F32aIsa w w
instruction)
    instructionExecute :: Int -> F32aIsa w w -> State (F32aSt w) ()
instructionExecute Int
p F32aIsa w w
instruction =
        case F32aIsa w w
instruction of
            Lit w
l -> do
                w -> State (F32aSt w) ()
forall {w}. w -> StateT (F32aSt w) Identity ()
dataPush w
l
                State (F32aSt w) ()
nextP
            F32aIsa w w
Return -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
returnPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> State (F32aSt w) ()
forall w. Int -> State (F32aSt w) ()
setP (Int -> State (F32aSt w) ())
-> (w -> Int) -> w -> State (F32aSt w) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Int
forall a. Enum a => a -> Int
fromEnum
            Call w
l -> do
                w -> State (F32aSt w) ()
forall {m :: * -> *} {w}. MonadState (F32aSt w) m => w -> m ()
returnPush (w -> State (F32aSt w) ()) -> w -> State (F32aSt w) ()
forall a b. (a -> b) -> a -> b
$ Int -> w
forall a. Enum a => Int -> a
toEnum Int
next
                Int -> State (F32aSt w) ()
forall w. Int -> State (F32aSt w) ()
setP (w -> Int
forall a. Enum a => a -> Int
fromEnum w
l)
            Jump w
l -> do
                Int -> State (F32aSt w) ()
forall w. Int -> State (F32aSt w) ()
setP (w -> Int
forall a. Enum a => a -> Int
fromEnum w
l)
            Next w
l -> do
                r <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
returnPop
                if r == 0
                    then nextP
                    else do
                        returnPush (r - 1)
                        setP (fromEnum l)
            If w
l -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                if w == 0
                    then setP (fromEnum l)
                    else nextP
            MinusIf w
l -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                if w >= 0
                    then setP (fromEnum l)
                    else nextP
            F32aIsa w w
AStore -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {w} {m :: * -> *}. MonadState (F32aSt w) m => w -> m ()
setA State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
BStore -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {w} {m :: * -> *}. MonadState (F32aSt w) m => w -> m ()
setB State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
AFetch -> State (F32aSt w) w
forall w. State (F32aSt w) w
getA State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {w}. w -> StateT (F32aSt w) Identity ()
dataPush State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            -- [    T   ][    A   ] >> 1
            --      ^            |
            --      |            |
            --      +?<----------+ lower bit
            --      ^
            --      |
            -- [    S   ]
            F32aIsa w w
MulStep -> do
                a <- State (F32aSt w) w
forall w. State (F32aSt w) w
getA
                t <- dataPop
                s <- dataPop
                let t' = w
t w -> w -> w
forall a. Num a => a -> a -> a
+ if w -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit w
a Int
0 then w
s else w
0
                    a' = w
a w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
                    t'' = w
t' w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
                    a'' = if w -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit w
t' Int
0 then w -> Int -> w
forall a. Bits a => a -> Int -> a
setBit w
a' Int
31 else w -> Int -> w
forall a. Bits a => a -> Int -> a
clearBit w
a' Int
31
                dataPush s
                dataPush t''
                setA a''
                nextP
            -- A <- dividend
            -- [B] <- divisor
            -- T -> quotient
            -- S -> remainder
            F32aIsa w w
DivStep -> do
                quotient1 <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                remainder1 <- dataPop
                dividend1 <- getA
                divisor <- getB >>= getWord . fromEnum
                let remainder2 = w
remainder1 w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
                    dividenUpperBit = if w -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit w
dividend1 Int
31 then w
1 else w
0
                    dividend2 = w
dividend1 w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
                    remainder3 = w
remainder2 w -> w -> w
forall a. Bits a => a -> a -> a
.|. w
dividenUpperBit
                    quotient2 = w
quotient1 w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftL` Int
1
                    (remainder4, quotient3) =
                        if remainder3 >= divisor
                            then (remainder3 - divisor, quotient2 .|. 1)
                            else (remainder3, quotient2)
                setA dividend2
                dataPush remainder4
                dataPush quotient3
                nextP
            F32aIsa w w
LShift -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                dataPush (w `shiftL` 1)
                nextP
            F32aIsa w w
RShift -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                dataPush (w `shiftR` 1)
                nextP
            F32aIsa w w
Inv -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                dataPush (complement w)
                nextP
            F32aIsa w w
FetchPlus -> do
                a <- State (F32aSt w) w
forall w. State (F32aSt w) w
getA
                w <- getWord $ fromEnum a
                dataPush w
                setA (a + 1)
                nextP
            F32aIsa w w
FetchB -> do
                b <- State (F32aSt w) w
forall w. State (F32aSt w) w
getB
                w <- getWord $ fromEnum b
                dataPush w
                nextP
            FetchP w
l -> Int -> State (F32aSt w) w
forall {b}.
(FiniteBits b, ByteSize b, Default b, Hashable b, Read b,
 WordParts b, FromSign b, Bounded b, Integral b, Show b) =>
Int -> StateT (F32aSt b) Identity b
getWord (w -> Int
forall a. Enum a => a -> Int
fromEnum w
l) State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {w}. w -> StateT (F32aSt w) Identity ()
dataPush State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
Fetch -> do
                a <- State (F32aSt w) w
forall w. State (F32aSt w) w
getA
                w <- getWord $ fromEnum a
                dataPush w
                nextP
            StoreP w
l -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> w -> State (F32aSt w) ()
forall {w}.
(FiniteBits w, ByteSize w, Default w, Hashable w, Read w,
 WordParts w, FromSign w, Bounded w, Integral w, Show w) =>
Int -> w -> StateT (F32aSt w) Identity ()
setWord (w -> Int
forall a. Enum a => a -> Int
fromEnum w
l) State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
StorePlus -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                a <- getA
                setWord (fromEnum a) w
                setA (a + 1)
                nextP
            F32aIsa w w
StoreB -> do
                w <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                b <- getB
                setWord (fromEnum b) w
                nextP
            F32aIsa w w
Store -> do
                a <- State (F32aSt w) w
forall w. State (F32aSt w) w
getA
                w <- dataPop
                setWord (fromEnum a) w
                nextP
            F32aIsa w w
RIntoT -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
returnPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {w}. w -> StateT (F32aSt w) Identity ()
dataPush State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
TIntoR -> State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop State (F32aSt w) w
-> (w -> State (F32aSt w) ()) -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> (a -> StateT (F32aSt w) Identity b)
-> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> State (F32aSt w) ()
forall {m :: * -> *} {w}. MonadState (F32aSt w) m => w -> m ()
returnPush State (F32aSt w) () -> State (F32aSt w) () -> State (F32aSt w) ()
forall a b.
StateT (F32aSt w) Identity a
-> StateT (F32aSt w) Identity b -> StateT (F32aSt w) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (F32aSt w) ()
nextP
            F32aIsa w w
Add -> do
                t <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                s <- dataPop
                F32aSt{extendedArithmeticMode, carryFlag} <- get
                let Ext{value = v1, carry = c1} = addExt s t
                    (result, carry) =
                        if extendedArithmeticMode && carryFlag
                            then
                                let Ext{value = v2, carry = c2} = addExt v1 1
                                 in (v2, c1 || c2)
                            else (v1, c1)
                dataPush result
                setCarryFlag carry
                nextP
            F32aIsa w w
Eam -> do
                t <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                setExtendedArithmeticMode (t /= 0)
                nextP
            F32aIsa w w
And -> do
                t <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                s <- dataPop
                dataPush (s .&. t)
                nextP
            F32aIsa w w
Xor -> do
                t <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                s <- dataPop
                dataPush (s `xor` t)
                nextP
            F32aIsa w w
Drop -> do
                State (F32aSt w) w -> State (F32aSt w) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                Bool -> State (F32aSt w) ()
forall w. Bool -> State (F32aSt w) ()
setCarryFlag Bool
False
                State (F32aSt w) ()
nextP
            F32aIsa w w
Dup -> do
                carryFlag <- State (F32aSt w) Bool
forall w. State (F32aSt w) Bool
getCarryFlag
                w <- dataPop
                dataPush w
                dataPush w
                setCarryFlag carryFlag
                nextP
            F32aIsa w w
Over -> do
                t <- State (F32aSt w) w
forall w. IsWord w => State (F32aSt w) w
dataPop
                s <- dataPop
                dataPush s
                dataPush t
                dataPush s
                nextP
            F32aIsa w w
Halt -> (F32aSt w -> F32aSt w) -> State (F32aSt w) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((F32aSt w -> F32aSt w) -> State (F32aSt w) ())
-> (F32aSt w -> F32aSt w) -> State (F32aSt w) ()
forall a b. (a -> b) -> a -> b
$ \F32aSt w
st -> F32aSt w
st{stopped = True}
        where
            next :: Int
next = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ F32aIsa w w -> Int
forall t. ByteSize t => t -> Int
byteSize F32aIsa w w
instruction
            nextP :: State (F32aSt w) ()
nextP = Int -> State (F32aSt w) ()
forall w. Int -> State (F32aSt w) ()
setP Int
next