Add proper relative and label-relative addresses

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
 
 {-
 <value>       := <word> | <address>
@@ -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 (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
+signedNumber = signed (pure ()) number -- do not allow any space
-
-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)
 
 address :: Parser (Address Span)
 address =
-  fmap (uncurry AddressRelative) (withSpan signedNumber) <|>
+  fmap (uncurry AddressRelative) (withSpan $ between (char '[') (char ']') signedNumber) <|>
-  fmap (uncurry AddressAbsolute) (withSpan boundedNumber)
+  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

src/Mima/Asm/Phase2.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeFamilies        #-}
 
@@ -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 (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 (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
+intToBounded :: forall s n. (Bounded n, Integral n) => s -> Integer -> Weed (WeedError s) n
-p1ToP2Address (P1.AddressAbsolute s addr)   = OrgAddrAbsolute s addr
+intToBounded s val = do
-p1ToP2Address (P1.AddressRelative s offset) = OrgAddrRelative s offset
+  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
+p1ToP2Address :: P1.Address s -> WeedS1 s (OrgAddress s)
-p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) =
+p1ToP2Address (P1.AddressAbsolute s addr)   = lift $ OrgAddrAbsolute s <$> intToBounded s addr
-  Loc1Absolute 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
+  pure $ Loc1Relative s offset
-p1ToP2Location (P1.LocationLabel name) = Loc1Label $ p1ToP2Name name
+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.Instruction s -> WeedS1 s (Instruction 'S1 s)
-p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) =
+p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) = SmallInstruction so <$> p1ToP2Location loc
-  SmallInstruction so $ p1ToP2Location loc
+p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) = do
-p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) =
+  val <- case maybeSv of
-  LargeInstruction lo $ fmap (\(P1.SmallValue _ sv) -> sv) maybeSv
+    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.MimaWord s -> WeedS1 s (MimaWord 'S1 s)
-p1ToP2Word (P1.WordRaw _ w)      = WordRaw w
+p1ToP2Word (P1.WordRaw s w)      = lift $ WordRaw <$> intToBounded s w
-p1ToP2Word (P1.WordLocation loc) = WordLocation $ p1ToP2Location loc
+p1ToP2Word (P1.WordLocation loc) = WordLocation <$> p1ToP2Location loc
 
-p1ToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s
+p1ToP2RegDir :: P1.RegisterDirective s -> WeedS1 s (RegisterDirective 'S1 s)
-p1ToP2RegDir (P1.RegIar s _ loc)  = RegIar s $ p1ToP2Location loc
+p1ToP2RegDir (P1.RegIar s _ loc)  = RegIar s <$> p1ToP2Location loc
-p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s $ p1ToP2Word word
+p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s <$> p1ToP2Word word
-p1ToP2RegDir (P1.RegRa  s _ loc)  = RegRa  s $ p1ToP2Location loc
+p1ToP2RegDir (P1.RegRa  s _ loc)  = RegRa  s <$> p1ToP2Location loc
-p1ToP2RegDir (P1.RegSp  s _ loc)  = RegSp  s $ p1ToP2Location loc
+p1ToP2RegDir (P1.RegSp  s _ loc)  = RegSp  s <$> p1ToP2Location loc
-p1ToP2RegDir (P1.RegFp  s _ loc)  = RegFp  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) =
+s1AddP1Token (P1.TokenInstruction instr) = do
-  s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () $ p1ToP2Instruction instr
+  i <- p1ToP2Instruction instr
-s1AddP1Token (P1.TokenDirective (P1.Reg s _ regDir)) =
+  s1WithMetas $ s1AddToken $ TokenInstr (peel instr) () i
-  s1AddToken $ TokenReg s () $ p1ToP2RegDir regDir
+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
+  a <- p1ToP2Address addr
-s1AddP1Token (P1.TokenDirective (P1.Lit s _ w)) =
+  s1AddToken $ TokenOrg s a
-  s1WithMetas $ s1AddToken $ TokenLit s () $ p1ToP2Word w
+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)
+  val <- lift $ intToBounded s newAddr
-      maxAddr = toInteger (maxBound :: Vm.MimaAddress)
+  pure $ Loc2Absolute s val
-  when (newAddr < minAddr || newAddr > maxAddr) $
-    lift $ harmless $ errorWith s $ "address out of bounds: " ++ show newAddr
-  pure $ Loc2Absolute s $ fromInteger newAddr
 
 s2ConvertMimaWord :: Vm.MimaAddress -> MimaWord 'S1 s -> WeedS2 s (MimaWord 'S2 s)
 s2ConvertMimaWord baseAddr (WordLocation loc) =