Implement subphase 3
Also... - Parse .meta-global correctly - Keep .meta until subphase 3 - Add identity functions for some phase 2 types - Minor clean ups
This commit is contained in:
parent
6e1f3e213c
commit
cc6dadfd3e
6 changed files with 234 additions and 129 deletions
|
|
@ -63,11 +63,13 @@ formatDirective (Org _ _ addr) = ".org " <> formatAddress addr
|
|||
formatDirective (Lit _ _ val) = ".lit " <> formatMimaWord val
|
||||
formatDirective (Arr _ _ vals) =
|
||||
".arr [" <> T.intercalate ", " (map formatMimaWord vals) <> "]"
|
||||
formatDirective (Meta _ _ n val) =
|
||||
".meta " <> formatName n <> " " <> formatJsonValue val
|
||||
formatDirective (MetaGlobal _ _ n val) =
|
||||
".meta-global " <> formatName n <> " " <> formatJsonValue val
|
||||
formatDirective (MetaStart _ _ n val) =
|
||||
".meta-start " <> formatName n <> " " <> formatJsonValue val
|
||||
formatDirective (MetaStop _ _ n) = ".meta-stop " <> formatName n
|
||||
formatDirective (Meta _ _ n val) =
|
||||
".meta " <> formatName n <> " " <> formatJsonValue val
|
||||
|
||||
formatToken :: AsmToken a -> T.Text
|
||||
formatToken (TokenLabel n) = formatName n <> ":"
|
||||
|
|
|
|||
|
|
@ -138,15 +138,38 @@ registerDirective =
|
|||
singleDirective RegSp "SP" location <|>
|
||||
singleDirective RegFp "FP" location
|
||||
|
||||
jsonValue :: Parser (JsonValue Span)
|
||||
jsonValue = do
|
||||
(valueSpan, jsonText) <- withSpan $ takeWhile1P (Just "json value") (/= '\n')
|
||||
let jsonBS = BS.fromStrict $ T.encodeUtf8 jsonText
|
||||
case A.eitherDecode jsonBS of
|
||||
Left msg -> fail msg
|
||||
Right value -> pure $ JsonValue valueSpan value
|
||||
|
||||
metaValue
|
||||
:: (Span -> Span -> Name Span -> JsonValue Span -> Directive Span)
|
||||
-> T.Text
|
||||
-> Parser (Directive Span)
|
||||
metaValue constructor dirName = do
|
||||
(outerSpan, (dirSpan, metaName, value)) <- withSpan $ do
|
||||
(dirSpan, _) <- withSpan $ chunk dirName
|
||||
inlineSpace1
|
||||
metaName <- name
|
||||
inlineSpace1
|
||||
value <- jsonValue
|
||||
pure (dirSpan, metaName, value)
|
||||
pure $ constructor outerSpan dirSpan metaName value
|
||||
|
||||
directive :: Parser (Directive Span)
|
||||
directive =
|
||||
singleDirective Reg ".reg" registerDirective <|>
|
||||
singleDirective Org ".org" address <|>
|
||||
singleDirective Lit ".lit" mimaWord <|>
|
||||
arr <|>
|
||||
metaStart MetaStart ".meta-start" <|>
|
||||
metaValue MetaGlobal ".meta-global" <|>
|
||||
metaValue MetaStart ".meta-start" <|>
|
||||
singleDirective MetaStop ".meta-stop" name <|>
|
||||
metaStart Meta ".meta"
|
||||
metaValue Meta ".meta"
|
||||
where
|
||||
arr = do
|
||||
(outerSpan, (regSpan, mimaWords)) <- withSpan $ do
|
||||
|
|
@ -157,23 +180,6 @@ directive =
|
|||
pure (dirSpan, mimaWords)
|
||||
pure $ Arr outerSpan regSpan mimaWords
|
||||
|
||||
metaStart f keyword = do
|
||||
(outerSpan, (regSpan, metaName, jsonValue)) <- withSpan $ do
|
||||
(dirSpan, _) <- withSpan $ chunk keyword
|
||||
inlineSpace1
|
||||
metaName <- name
|
||||
inlineSpace1
|
||||
|
||||
(valueSpan, rawJsonValue) <- withSpan $ do
|
||||
metaValueBS <- BS.fromStrict . T.encodeUtf8
|
||||
<$> takeWhile1P (Just "json value") (/= '\n')
|
||||
case A.eitherDecode metaValueBS of
|
||||
Left msg -> fail msg
|
||||
Right value -> pure value
|
||||
|
||||
pure (dirSpan, metaName, JsonValue valueSpan rawJsonValue)
|
||||
pure $ f outerSpan regSpan metaName jsonValue
|
||||
|
||||
comment :: Bool -> Parser (AsmToken Span)
|
||||
comment inline = fmap (\(s, text) -> TokenComment s text inline) $ withSpan $
|
||||
char ';' *> takeWhileP (Just "comment") (/= '\n')
|
||||
|
|
|
|||
|
|
@ -136,9 +136,10 @@ data Directive a
|
|||
| Org a a (Address a)
|
||||
| Lit a a (MimaWord a)
|
||||
| Arr a a [MimaWord a]
|
||||
| Meta a a (Name a) (JsonValue a)
|
||||
| MetaGlobal a a (Name a) (JsonValue a)
|
||||
| MetaStart a a (Name a) (JsonValue a)
|
||||
| MetaStop a a (Name a)
|
||||
| Meta a a (Name a) (JsonValue a)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Directive where
|
||||
|
|
@ -146,9 +147,10 @@ instance Onion Directive where
|
|||
peel (Org a _ _) = a
|
||||
peel (Lit a _ _) = a
|
||||
peel (Arr a _ _) = a
|
||||
peel (Meta a _ _ _) = a
|
||||
peel (MetaGlobal a _ _ _) = a
|
||||
peel (MetaStart a _ _ _) = a
|
||||
peel (MetaStop a _ _) = a
|
||||
peel (Meta a _ _ _) = a
|
||||
|
||||
-- | A single token. The @s@ type parameter is the type of location annotations.
|
||||
data AsmToken a
|
||||
|
|
|
|||
|
|
@ -4,12 +4,7 @@ module Mima.Asm.Phase2.Subphase1
|
|||
( subphase1
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import Data.Traversable
|
||||
|
||||
import qualified Mima.Asm.Phase1 as P1
|
||||
import Mima.Asm.Phase2.Types
|
||||
|
|
@ -17,7 +12,7 @@ import Mima.Asm.Phase2.Util
|
|||
import Mima.Asm.Types
|
||||
import Mima.Asm.Weed
|
||||
|
||||
{- Converting phase 1 types to phase 2 types -}
|
||||
type WeedS1 s = Weed (WeedError s)
|
||||
|
||||
p1ToP2Name :: P1.Name s -> Name s
|
||||
p1ToP2Name (P1.Name s text) = Name s text
|
||||
|
|
@ -26,12 +21,13 @@ p1ToP2JsonValue :: P1.JsonValue s -> JsonValue s
|
|||
p1ToP2JsonValue (P1.JsonValue s value) = JsonValue s value
|
||||
|
||||
p1ToP2Address :: P1.Address s -> WeedS1 s (OrgAddress s)
|
||||
p1ToP2Address (P1.AddressAbsolute s addr) = lift $ OrgAddrAbsolute s <$> intToBounded s addr
|
||||
p1ToP2Address (P1.AddressAbsolute s addr) =
|
||||
OrgAddrAbsolute s <$> intToBounded s addr
|
||||
p1ToP2Address (P1.AddressRelative s offset) = pure $ OrgAddrRelative s offset
|
||||
|
||||
p1ToP2Location :: P1.Location s -> WeedS1 s (Location1 s)
|
||||
p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) =
|
||||
lift $ Loc1Absolute s <$> intToBounded s addr
|
||||
Loc1Absolute s <$> intToBounded s addr
|
||||
p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) =
|
||||
pure $ Loc1Relative s offset
|
||||
p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name
|
||||
|
|
@ -42,13 +38,11 @@ p1ToP2Instruction :: P1.Instruction s -> WeedS1 s (Instruction 'S1 s)
|
|||
p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) =
|
||||
SmallInstruction so <$> p1ToP2Location loc
|
||||
p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) = do
|
||||
val <- case maybeSv of
|
||||
Nothing -> pure Nothing
|
||||
Just (P1.SmallValue s v) -> lift $ Just <$> intToBounded s v
|
||||
val <- for maybeSv $ \(P1.SmallValue s v) -> intToBounded s v
|
||||
pure $ LargeInstruction lo val
|
||||
|
||||
p1ToP2Word :: P1.MimaWord s -> WeedS1 s (MimaWord 'S1 s)
|
||||
p1ToP2Word (P1.WordRaw s w) = lift $ WordRaw <$> intToBounded s w
|
||||
p1ToP2Word (P1.WordRaw s w) = WordRaw <$> intToBounded s w
|
||||
p1ToP2Word (P1.WordLocation loc) = WordLocation <$> p1ToP2Location loc
|
||||
|
||||
p1ToP2RegDir :: P1.RegisterDirective s -> WeedS1 s (RegisterDirective 'S1 s)
|
||||
|
|
@ -58,81 +52,36 @@ p1ToP2RegDir (P1.RegRa s _ loc) = RegRa s <$> p1ToP2Location loc
|
|||
p1ToP2RegDir (P1.RegSp s _ loc) = RegSp s <$> p1ToP2Location loc
|
||||
p1ToP2RegDir (P1.RegFp s _ loc) = RegFp s <$> p1ToP2Location loc
|
||||
|
||||
{- Subphase 1 -}
|
||||
|
||||
data SingleMeta s = SingleMeta s (P1.Name s) (P1.JsonValue s)
|
||||
deriving (Show)
|
||||
|
||||
instance Onion SingleMeta where
|
||||
peel (SingleMeta s _ _) = s
|
||||
|
||||
data StateS1 s = StateS1
|
||||
{ s1Metas :: Map.Map T.Text (SingleMeta s)
|
||||
, s1Tokens :: [AsmToken 'S1 s]
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS1 s = StateT (StateS1 s) (Weed (WeedError s))
|
||||
|
||||
addMeta :: s -> P1.Name s -> P1.JsonValue s -> WeedS1 s ()
|
||||
addMeta s name@(P1.Name namePos nameText) value = do
|
||||
s1 <- get
|
||||
when (nameText `Map.member` s1Metas s1) $
|
||||
lift $ harmless $ errorWith namePos "duplicate .meta names"
|
||||
let meta = SingleMeta s name value
|
||||
put s1{s1Metas = Map.insert nameText meta $ s1Metas s1}
|
||||
|
||||
takeMetas :: WeedS1 s [SingleMeta s]
|
||||
takeMetas = do
|
||||
s <- get
|
||||
put s{s1Metas = Map.empty}
|
||||
pure $ Map.elems $ s1Metas s
|
||||
|
||||
withMetas :: WeedS1 s () -> WeedS1 s ()
|
||||
withMetas f = do
|
||||
metas <- takeMetas
|
||||
for_ (reverse metas) $ \(SingleMeta s name value) ->
|
||||
addToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
f
|
||||
for_ metas $ \(SingleMeta s name _) ->
|
||||
addToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
|
||||
addToken :: AsmToken 'S1 s -> WeedS1 s ()
|
||||
addToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s}
|
||||
|
||||
addP1Token :: P1.AsmToken s -> WeedS1 s ()
|
||||
addP1Token (P1.TokenLabel name) =
|
||||
addToken $ TokenLabel (peel name) () $ p1ToP2Name name
|
||||
addP1Token (P1.TokenInstruction instr) = do
|
||||
i <- p1ToP2Instruction instr
|
||||
withMetas $ addToken $ TokenInstr (peel instr) () i
|
||||
addP1Token (P1.TokenDirective (P1.Reg s _ regDir)) = do
|
||||
p1ToP2Directive :: P1.Directive s -> WeedS1 s [AsmToken 'S1 s]
|
||||
p1ToP2Directive (P1.Reg s _ regDir) = do
|
||||
r <- p1ToP2RegDir regDir
|
||||
addToken $ TokenReg s () r
|
||||
addP1Token (P1.TokenDirective (P1.Org s _ addr)) = do
|
||||
withMetas $ pure ()
|
||||
pure [TokenReg s () r]
|
||||
p1ToP2Directive (P1.Org s _ addr) = do
|
||||
a <- p1ToP2Address addr
|
||||
addToken $ TokenOrg s a
|
||||
addP1Token (P1.TokenDirective (P1.Lit s _ word)) = do
|
||||
pure [TokenOrg s a]
|
||||
p1ToP2Directive (P1.Lit s _ word) = do
|
||||
w <- p1ToP2Word word
|
||||
withMetas $ addToken $ TokenLit s () w
|
||||
addP1Token (P1.TokenDirective (P1.Arr s _ ws)) =
|
||||
withMetas $ for_ ws $ \word -> do
|
||||
pure [TokenLit s () w]
|
||||
p1ToP2Directive (P1.Arr s _ ws) = for ws $ \word -> do
|
||||
w <- p1ToP2Word word
|
||||
addToken $ TokenLit s () w
|
||||
addP1Token (P1.TokenDirective (P1.Meta s _ name value)) =
|
||||
addMeta s name value
|
||||
addP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
|
||||
addToken $ TokenMeta s () $
|
||||
MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
|
||||
addP1Token (P1.TokenDirective (P1.MetaStop s _ name)) =
|
||||
addToken $ TokenMeta s () $ MetaStop s (p1ToP2Name name)
|
||||
addP1Token P1.TokenComment{} = pure ()
|
||||
pure $ TokenLit s () w
|
||||
p1ToP2Directive (P1.MetaGlobal s _ name value) =
|
||||
pure [TokenMeta s () $ MetaGlobal s (p1ToP2Name name) (p1ToP2JsonValue value)]
|
||||
p1ToP2Directive (P1.MetaStart s _ name value) =
|
||||
pure [TokenMeta s () $ MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)]
|
||||
p1ToP2Directive (P1.MetaStop s _ name) =
|
||||
pure [TokenMeta s () $ MetaStop s (p1ToP2Name name)]
|
||||
p1ToP2Directive (P1.Meta s _ name value) =
|
||||
pure [TokenMeta s () $ Meta s (p1ToP2Name name) (p1ToP2JsonValue value)]
|
||||
|
||||
p1ToP2Token :: P1.AsmToken s -> WeedS1 s [AsmToken 'S1 s]
|
||||
p1ToP2Token (P1.TokenLabel name) =
|
||||
pure [TokenLabel (peel name) () $ p1ToP2Name name]
|
||||
p1ToP2Token (P1.TokenInstruction instr) = do
|
||||
i <- p1ToP2Instruction instr
|
||||
pure [TokenInstr (peel instr) () i]
|
||||
p1ToP2Token (P1.TokenDirective dir) = p1ToP2Directive dir
|
||||
p1ToP2Token P1.TokenComment{} = pure []
|
||||
|
||||
subphase1 :: P1.Phase1 s -> Weed (WeedError s) (Phase2 'S1 s)
|
||||
subphase1 ts = do
|
||||
let initialS = StateS1 Map.empty []
|
||||
s <- flip execStateT initialS $ do
|
||||
traverse_ addP1Token ts
|
||||
withMetas $ pure ()
|
||||
pure $ reverse $ s1Tokens s
|
||||
subphase1 ts = concat <$> traverse p1ToP2Token ts
|
||||
|
|
|
|||
124
src/Mima/Asm/Phase2/Subphase3.hs
Normal file
124
src/Mima/Asm/Phase2/Subphase3.hs
Normal file
|
|
@ -0,0 +1,124 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Mima.Asm.Phase2.Subphase3
|
||||
( subphase3
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.State
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Void
|
||||
|
||||
import Mima.Asm.Phase2.Types
|
||||
import Mima.Asm.Weed
|
||||
import qualified Mima.Vm.Metadata as Vm
|
||||
import qualified Mima.Vm.Word as Vm
|
||||
|
||||
data SortedByIndex a = SortedByIndex Int a
|
||||
deriving (Show)
|
||||
|
||||
instance Eq (SortedByIndex a) where
|
||||
(SortedByIndex a _) == (SortedByIndex b _) = a == b
|
||||
|
||||
instance Ord (SortedByIndex a) where
|
||||
compare (SortedByIndex a _) (SortedByIndex b _) = compare a b
|
||||
|
||||
getValue :: SortedByIndex a -> a
|
||||
getValue (SortedByIndex _ a) = a
|
||||
|
||||
data StateS3 s = StateS3
|
||||
{ s3Labels :: Map.Map T.Text Vm.MimaAddress
|
||||
, s3GlobalMeta :: Vm.MetaInfo
|
||||
, s3LocalMeta :: [SortedByIndex Vm.Range]
|
||||
, s3OpenMetaRanges :: Map.Map T.Text [SortedByIndex (s, A.Value, Vm.MimaAddress)]
|
||||
, s3Index :: Int
|
||||
} deriving (Show)
|
||||
|
||||
type WeedS3 s = StateT (StateS3 s) (Weed (WeedError s))
|
||||
|
||||
nextIndex :: WeedS3 s Int
|
||||
nextIndex = do
|
||||
s3 <- get
|
||||
let i = s3Index s3
|
||||
put s3{s3Index = i + 1}
|
||||
pure i
|
||||
|
||||
addLabel :: Vm.MimaAddress -> Name s -> WeedS3 s ()
|
||||
addLabel addr (Name s nameText) = do
|
||||
s3 <- get
|
||||
let labels = s3Labels s3
|
||||
if nameText `Map.member` labels
|
||||
then lift $ harmless $ errorWith s "label already set previously"
|
||||
else put s3{s3Labels = Map.insert nameText addr labels}
|
||||
|
||||
addGlobalMeta :: Name s -> A.Value -> WeedS3 s ()
|
||||
addGlobalMeta (Name s nameText) val = do
|
||||
s3 <- get
|
||||
let globalMeta = s3GlobalMeta s3
|
||||
if nameText `Map.member` globalMeta
|
||||
then lift $ harmless $ errorWith s "global meta with this name already set"
|
||||
else put s3 {s3GlobalMeta = Map.insert nameText val globalMeta}
|
||||
|
||||
addRange :: Int -> Vm.Range -> WeedS3 s ()
|
||||
addRange i r =
|
||||
modify $ \s3 -> s3 {s3LocalMeta = SortedByIndex i r : s3LocalMeta s3}
|
||||
|
||||
addLocalMeta :: Vm.MimaAddress -> Name s -> A.Value -> WeedS3 s ()
|
||||
addLocalMeta addr (Name _ nameText) val = do
|
||||
i <- nextIndex
|
||||
addRange i $ Vm.RangeAt (Map.singleton nameText val) addr
|
||||
|
||||
startLocalMeta :: Vm.MimaAddress -> s -> Name s -> A.Value -> WeedS3 s ()
|
||||
startLocalMeta addr s (Name _ nameText) val = do
|
||||
i <- nextIndex
|
||||
s3 <- get
|
||||
let ranges = s3OpenMetaRanges s3
|
||||
tuple = SortedByIndex i (s, val, addr)
|
||||
ranges' = Map.alter (Just . (tuple :) . fromMaybe []) nameText ranges
|
||||
put s3{s3OpenMetaRanges = ranges'}
|
||||
|
||||
stopLocalMeta :: Vm.MimaAddress -> Name s -> WeedS3 s ()
|
||||
stopLocalMeta stopAddr (Name s nameText) = do
|
||||
s3 <- get
|
||||
let ranges = s3OpenMetaRanges s3
|
||||
case fromMaybe [] $ ranges Map.!? nameText of
|
||||
[] -> lift $ harmless $ errorWith s "closing unopened meta"
|
||||
(SortedByIndex i (_, val, startAddr):xs) -> do
|
||||
let range = Vm.RangeFromTo (Map.singleton nameText val) startAddr stopAddr
|
||||
ranges' = Map.insert nameText xs ranges
|
||||
put s3{s3OpenMetaRanges = ranges'}
|
||||
addRange i range
|
||||
|
||||
handleMeta :: Vm.MimaAddress -> Meta s -> WeedS3 s ()
|
||||
handleMeta _ (MetaGlobal _ name (JsonValue _ val)) = addGlobalMeta name val
|
||||
handleMeta addr (MetaStart s name (JsonValue _ val)) = startLocalMeta addr s name val
|
||||
handleMeta addr (MetaStop _ name) = stopLocalMeta addr name
|
||||
handleMeta addr (Meta _ name (JsonValue _ val)) = addLocalMeta addr name val
|
||||
|
||||
updateToken :: AsmToken 'S2 s -> WeedS3 s [AsmToken 'S3 s]
|
||||
updateToken (TokenOrg _ x) = absurd x
|
||||
updateToken (TokenLabel _ addr name) = [] <$ addLabel addr name
|
||||
updateToken (TokenMeta _ addr meta) = [] <$ handleMeta addr meta
|
||||
updateToken (TokenLit s addr word) = pure [TokenLit s addr $ idWord word]
|
||||
updateToken (TokenInstr s addr i) = pure [TokenInstr s addr $ idInstruction i]
|
||||
updateToken (TokenReg s addr reg) = pure [TokenReg s addr $ idRegDir reg]
|
||||
|
||||
type ResultS3 s = (Phase2 'S3 s, Map.Map T.Text Vm.MimaAddress, Vm.Metadata)
|
||||
|
||||
subphase3 :: Phase2 'S2 s -> Weed (WeedError s) (ResultS3 s)
|
||||
subphase3 tokens = do
|
||||
let initialS = StateS3 Map.empty Map.empty [] Map.empty 0
|
||||
(newTokens, finalS) <- runStateT (traverse updateToken tokens) initialS
|
||||
let labels = s3Labels finalS
|
||||
global = s3GlobalMeta finalS
|
||||
local = map getValue $ sort $ s3LocalMeta finalS
|
||||
metadata = Vm.Metadata global local
|
||||
openRanges = map getValue $ concat $ Map.elems $ s3OpenMetaRanges finalS
|
||||
for_ openRanges $ \(s, _, _) ->
|
||||
harmless $ errorWith s "meta range was not closed"
|
||||
pure (concat newTokens, labels, metadata)
|
||||
|
|
@ -27,10 +27,13 @@ module Mima.Asm.Phase2.Types
|
|||
, TokenMetaX
|
||||
-- ** Instruction token
|
||||
, MimaWord(..)
|
||||
, idWord
|
||||
, Instruction(..)
|
||||
, idInstruction
|
||||
, TokenInstrX
|
||||
-- ** Register token
|
||||
, RegisterDirective(..)
|
||||
, idRegDir
|
||||
, TokenRegX
|
||||
) where
|
||||
|
||||
|
|
@ -46,11 +49,11 @@ data Subphase
|
|||
-- ^ Freshly converted from 'Phase1'. Arrays are converted into multiple
|
||||
-- literal values. Comments are removed.
|
||||
| S2
|
||||
-- ^ After resolving all .org-s and relative positions and assigning each
|
||||
-- ^ After resolving all @.org@s and relative positions and assigning each
|
||||
-- token an address.
|
||||
| S3
|
||||
-- ^ After extracting and removing all labels and .meta-s. This step results
|
||||
-- in a map to resolve labels and a complete set of .meta-* metadata.
|
||||
-- ^ After extracting and removing all labels and @.meta@s. This step results
|
||||
-- in a map to resolve labels and a complete set of @.meta-*@ metadata.
|
||||
| S4
|
||||
-- ^ After resolving all labels. Instructions are converted into literal
|
||||
-- values.
|
||||
|
|
@ -139,13 +142,17 @@ instance Onion JsonValue where
|
|||
|
||||
-- | A representation for .meta-start and .meta-stop directives.
|
||||
data Meta s
|
||||
= MetaStart s (Name s) (JsonValue s)
|
||||
= Meta s (Name s) (JsonValue s)
|
||||
| MetaStart s (Name s) (JsonValue s)
|
||||
| MetaStop s (Name s)
|
||||
| MetaGlobal s (Name s) (JsonValue s)
|
||||
deriving (Show, Functor)
|
||||
|
||||
instance Onion Meta where
|
||||
peel (Meta s _ _) = s
|
||||
peel (MetaStart s _ _) = s
|
||||
peel (MetaStop s _) = s
|
||||
peel (MetaGlobal s _ _) = s
|
||||
|
||||
type family TokenMetaX (t :: Subphase) (s :: *)
|
||||
type instance TokenMetaX 'S1 s = Meta s
|
||||
|
|
@ -160,6 +167,10 @@ data MimaWord (t :: Subphase) (s :: *)
|
|||
= WordRaw Vm.MimaWord
|
||||
| WordLocation (LocationX t s)
|
||||
|
||||
idWord :: (LocationX a s ~ LocationX b s) => MimaWord a s -> MimaWord b s
|
||||
idWord (WordRaw word) = WordRaw word
|
||||
idWord (WordLocation loc) = WordLocation loc
|
||||
|
||||
deriving instance Show s => Show (MimaWord 'S1 s)
|
||||
deriving instance Show s => Show (MimaWord 'S2 s)
|
||||
deriving instance Show s => Show (MimaWord 'S3 s)
|
||||
|
|
@ -172,6 +183,10 @@ data Instruction (t :: Subphase) (s :: *)
|
|||
= SmallInstruction Vm.SmallOpcode (LocationX t s)
|
||||
| LargeInstruction Vm.LargeOpcode (Maybe Vm.SmallValue)
|
||||
|
||||
idInstruction :: (LocationX a s ~ LocationX b s) => Instruction a s -> Instruction b s
|
||||
idInstruction (SmallInstruction so loc) = SmallInstruction so loc
|
||||
idInstruction (LargeInstruction lo sv) = LargeInstruction lo sv
|
||||
|
||||
deriving instance Show s => Show (Instruction 'S1 s)
|
||||
deriving instance Show s => Show (Instruction 'S2 s)
|
||||
deriving instance Show s => Show (Instruction 'S3 s)
|
||||
|
|
@ -192,6 +207,13 @@ data RegisterDirective (t :: Subphase) (s :: *)
|
|||
| RegSp s (LocationX t s)
|
||||
| RegFp s (LocationX t s)
|
||||
|
||||
idRegDir :: (LocationX a s ~ LocationX b s) => RegisterDirective a s -> RegisterDirective b s
|
||||
idRegDir (RegIar s loc) = RegIar s loc
|
||||
idRegDir (RegAcc s word) = RegAcc s $ idWord word
|
||||
idRegDir (RegRa s loc) = RegRa s loc
|
||||
idRegDir (RegSp s loc) = RegSp s loc
|
||||
idRegDir (RegFp s loc) = RegFp s loc
|
||||
|
||||
deriving instance Show s => Show (RegisterDirective 'S1 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S2 s)
|
||||
deriving instance Show s => Show (RegisterDirective 'S3 s)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue