diff --git a/src/Mima/Asm/Phase1.hs b/src/Mima/Asm/Phase1.hs index 6ff8609..45a80fb 100644 --- a/src/Mima/Asm/Phase1.hs +++ b/src/Mima/Asm/Phase1.hs @@ -41,7 +41,6 @@ import Text.Megaparsec.Char.Lexer hiding (space) import Mima.Asm.Types import Mima.Format import qualified Mima.Vm.Instruction as Vm -import qualified Mima.Vm.Word as Vm {- := |
@@ -71,7 +70,7 @@ instance Onion Name where peel (Name a _) = a data Address a - = AddressAbsolute a Vm.MimaAddress + = AddressAbsolute a Integer | AddressRelative a Integer deriving (Show, Functor) @@ -82,11 +81,14 @@ instance Onion Address where data Location a = LocationAddress (Address a) | LocationLabel (Name a) + | LocationLabelRel a (Name a) a Integer + -- ^ @Lo LocationLabelRel completeSpan name offsetSpan offset@ deriving (Show, Functor) instance Onion Location where - peel (LocationAddress a) = peel a - peel (LocationLabel a) = peel a + peel (LocationAddress a) = peel a + peel (LocationLabel a) = peel a + peel (LocationLabelRel a _ _ _) = a data SmallOpcode a = SmallOpcode a Vm.SmallOpcode deriving (Show, Functor) @@ -101,7 +103,7 @@ instance Onion LargeOpcode where peel (LargeOpcode a _) = a data MimaWord a - = WordRaw a Vm.MimaWord + = WordRaw a Integer | WordLocation (Location a) deriving (Show, Functor) @@ -109,7 +111,7 @@ instance Onion MimaWord where peel (WordRaw a _) = a peel (WordLocation a) = peel a -data SmallValue a = SmallValue a Vm.SmallValue +data SmallValue a = SmallValue a Integer deriving (Show, Functor) instance Onion SmallValue where @@ -223,31 +225,26 @@ number = (chunk "0x" *> hexadecimal) <|> decimal -optionallySignedNumber :: (Num a) => Parser a -optionallySignedNumber = signed (pure ()) number -- do not allow any space - signedNumber :: (Num a) => Parser a -signedNumber = lookAhead (char '+' <|> char '-') *> optionallySignedNumber - -boundedNumber :: (Bounded n, Num n) => Parser n -boundedNumber = do - n <- optionallySignedNumber :: Parser Integer - when (n < minVal || n > maxVal) $ fail $ - "invalid range: " ++ - show n ++ " is not between " ++ - show minVal ++ " and " ++ show maxVal - pure $ fromInteger n - where - maxVal = toInteger (maxBound :: Vm.MimaWord) - minVal = -(maxVal + 1) +signedNumber = signed (pure ()) number -- do not allow any space address :: Parser (Address Span) address = - fmap (uncurry AddressRelative) (withSpan signedNumber) <|> - fmap (uncurry AddressAbsolute) (withSpan boundedNumber) + fmap (uncurry AddressRelative) (withSpan $ between (char '[') (char ']') signedNumber) <|> + fmap (uncurry AddressAbsolute) (withSpan signedNumber) + +labelWithOffset :: Parser (Location Span) +labelWithOffset = do + (completeSpan, (n, offsetSpan, offset)) <- withSpan $ do + n <- name + (offsetSpan, offset) <- withSpan $ between (char '[') (char ']') signedNumber + pure (n, offsetSpan, offset) + + pure $ LocationLabelRel completeSpan n offsetSpan offset location :: Parser (Location Span) -location = (LocationAddress <$> address) <|> (LocationLabel <$> name) +location = + (LocationAddress <$> address) <|> try labelWithOffset <|> (LocationLabel <$> name) smallOpcode :: Parser (SmallOpcode Span) smallOpcode = asum $ map parseOpcode [minBound..maxBound] @@ -265,10 +262,10 @@ largeOpcode = asum $ map parseOpcode [minBound..maxBound] mimaWord :: Parser (MimaWord Span) mimaWord = - (uncurry WordRaw <$> withSpan boundedNumber) <|> (WordLocation <$> location) + (uncurry WordRaw <$> withSpan signedNumber) <|> (WordLocation <$> location) smallValue :: Parser (SmallValue Span) -smallValue = uncurry SmallValue <$> withSpan boundedNumber +smallValue = uncurry SmallValue <$> withSpan signedNumber instruction :: Parser (Instruction Span) instruction = small <|> large @@ -363,7 +360,7 @@ labels = do ls <- many $ try $ inlineSpace1 *> label_ pure $ l : ls where - label_ = (TokenLabel <$> name) <* (inlineSpace <* char ':') + label_ = (TokenLabel <$> name) <* char ':' -- | Parses a single line consisting of zero or more tokens: -- inlineSpace, zero or more labels, zero or more instructions/directives, @@ -398,6 +395,8 @@ formatAddress (AddressRelative _ rel) formatLocation :: Location a -> T.Text formatLocation (LocationAddress addr) = formatAddress addr formatLocation (LocationLabel l) = formatName l +formatLocation (LocationLabelRel _ l _ offset) + = formatName l <> "[" <> toDec offset <> "]" formatSmallOpcode :: SmallOpcode a -> T.Text formatSmallOpcode (SmallOpcode _ opcode) = T.pack $ show opcode diff --git a/src/Mima/Asm/Phase2.hs b/src/Mima/Asm/Phase2.hs index 35c32e3..1511ada 100644 --- a/src/Mima/Asm/Phase2.hs +++ b/src/Mima/Asm/Phase2.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Mima.Asm.Phase2 ( phaseS1 -- TODO only leave the proper types @@ -53,22 +54,26 @@ data Location1 s = Loc1Absolute s Vm.MimaAddress | Loc1Relative s Integer | Loc1Label (Name s) + | Loc1LabelRel s (Name s) s Integer deriving (Show, Functor) instance Onion Location1 where - peel (Loc1Absolute s _) = s - peel (Loc1Relative s _) = s - peel (Loc1Label l) = peel l + peel (Loc1Absolute s _) = s + peel (Loc1Relative s _) = s + peel (Loc1Label l) = peel l + peel (Loc1LabelRel s _ _ _) = s -- | A location defined by an absolute address or by a label. data Location2 s = Loc2Absolute s Vm.MimaAddress | Loc2Label (Name s) + | Loc2LabelRel s (Name s) s Integer deriving (Show, Functor) instance Onion Location2 where - peel (Loc2Absolute s _) = s - peel (Loc2Label l) = peel l + peel (Loc2Absolute s _) = s + peel (Loc2Label l) = peel l + peel (Loc2LabelRel s _ _ _) = s -- | A type family for locations in various stages of resolution. type family LocationX (t :: Subphase) (s :: *) @@ -224,33 +229,45 @@ p1ToP2Name (P1.Name s text) = Name s text p1ToP2JsonValue :: P1.JsonValue s -> JsonValue s p1ToP2JsonValue (P1.JsonValue s value) = JsonValue s value -p1ToP2Address :: P1.Address s -> OrgAddress s -p1ToP2Address (P1.AddressAbsolute s addr) = OrgAddrAbsolute s addr -p1ToP2Address (P1.AddressRelative s offset) = OrgAddrRelative s offset +intToBounded :: forall s n. (Bounded n, Integral n) => s -> Integer -> Weed (WeedError s) n +intToBounded s val = do + when (val < minVal || val > maxVal) $ + harmless $ errorWith s "value out of bounds" + pure $ fromInteger val + where + maxVal = toInteger (maxBound :: n) + minVal = -maxVal - 1 -p1ToP2Location :: P1.Location s -> Location1 s -p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) = - Loc1Absolute s addr +p1ToP2Address :: P1.Address s -> WeedS1 s (OrgAddress s) +p1ToP2Address (P1.AddressAbsolute s addr) = lift $ 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 p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) = - Loc1Relative s offset -p1ToP2Location (P1.LocationLabel name) = Loc1Label $ p1ToP2Name name + pure $ Loc1Relative s offset +p1ToP2Location (P1.LocationLabel name) = pure $ Loc1Label $ p1ToP2Name name +p1ToP2Location (P1.LocationLabelRel s name s1 offset) + = pure $ Loc1LabelRel s (p1ToP2Name name) s1 offset -p1ToP2Instruction :: P1.Instruction s -> Instruction 'S1 s -p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) = - SmallInstruction so $ p1ToP2Location loc -p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) = - LargeInstruction lo $ fmap (\(P1.SmallValue _ sv) -> sv) maybeSv +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 + pure $ LargeInstruction lo val -p1ToP2Word :: P1.MimaWord s -> MimaWord 'S1 s -p1ToP2Word (P1.WordRaw _ w) = WordRaw w -p1ToP2Word (P1.WordLocation loc) = WordLocation $ p1ToP2Location loc +p1ToP2Word :: P1.MimaWord s -> WeedS1 s (MimaWord 'S1 s) +p1ToP2Word (P1.WordRaw s w) = lift $ WordRaw <$> intToBounded s w +p1ToP2Word (P1.WordLocation loc) = WordLocation <$> p1ToP2Location loc -p1ToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s -p1ToP2RegDir (P1.RegIar s _ loc) = RegIar s $ p1ToP2Location loc -p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s $ p1ToP2Word word -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 +p1ToP2RegDir :: P1.RegisterDirective s -> WeedS1 s (RegisterDirective 'S1 s) +p1ToP2RegDir (P1.RegIar s _ loc) = RegIar s <$> p1ToP2Location loc +p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s <$> p1ToP2Word word +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 -} @@ -297,17 +314,23 @@ s1AddToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s} s1AddP1Token :: P1.AsmToken s -> WeedS1 s () s1AddP1Token (P1.TokenLabel name) = s1AddToken $ TokenLabel (peel name) () $ p1ToP2Name name -s1AddP1Token (P1.TokenInstruction instr) = - s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () $ p1ToP2Instruction instr -s1AddP1Token (P1.TokenDirective (P1.Reg s _ regDir)) = - s1AddToken $ TokenReg s () $ p1ToP2RegDir regDir +s1AddP1Token (P1.TokenInstruction instr) = do + i <- p1ToP2Instruction instr + s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () i +s1AddP1Token (P1.TokenDirective (P1.Reg s _ regDir)) = do + r <- p1ToP2RegDir regDir + s1AddToken $ TokenReg s () r s1AddP1Token (P1.TokenDirective (P1.Org s _ addr)) = do s1WithMetas $ pure () - s1AddToken $ TokenOrg s $ p1ToP2Address addr -s1AddP1Token (P1.TokenDirective (P1.Lit s _ w)) = - s1WithMetas $ s1AddToken $ TokenLit s () $ p1ToP2Word w + a <- p1ToP2Address addr + s1AddToken $ TokenOrg s a +s1AddP1Token (P1.TokenDirective (P1.Lit s _ word)) = do + w <- p1ToP2Word word + s1WithMetas $ s1AddToken $ TokenLit s () w s1AddP1Token (P1.TokenDirective (P1.Arr s _ ws)) = - s1WithMetas $ for_ ws $ s1AddToken . TokenLit s () . p1ToP2Word + s1WithMetas $ for_ ws $ \word -> do + w <- p1ToP2Word word + pure $ s1AddToken $ TokenLit s () w s1AddP1Token (P1.TokenDirective (P1.Meta s _ name value)) = s1AddMeta s name value s1AddP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) = @@ -359,13 +382,12 @@ s2NextAddress s = do s2ConvertLocation :: Vm.MimaAddress -> LocationX 'S1 s -> WeedS2 s (LocationX 'S2 s) s2ConvertLocation _ (Loc1Absolute s addr) = pure $ Loc2Absolute s addr s2ConvertLocation _ (Loc1Label name) = pure $ Loc2Label name +s2ConvertLocation _ (Loc1LabelRel s name s1 offset) + = pure $ Loc2LabelRel s name s1 offset s2ConvertLocation baseAddr (Loc1Relative s delta) = do let newAddr = toInteger baseAddr + delta - minAddr = toInteger (minBound :: Vm.MimaAddress) - maxAddr = toInteger (maxBound :: Vm.MimaAddress) - when (newAddr < minAddr || newAddr > maxAddr) $ - lift $ harmless $ errorWith s $ "address out of bounds: " ++ show newAddr - pure $ Loc2Absolute s $ fromInteger newAddr + val <- lift $ intToBounded s newAddr + pure $ Loc2Absolute s val s2ConvertMimaWord :: Vm.MimaAddress -> MimaWord 'S1 s -> WeedS2 s (MimaWord 'S2 s) s2ConvertMimaWord baseAddr (WordLocation loc) =