Finish weeding assembly

src/Mima/Parse/Assembly.hs

@@ -6,14 +6,15 @@ module Mima.Parse.Assembly
   ) where
 
 import           Control.Monad
-import qualified Data.Map as Map
 import qualified Data.Text as T
 import           Text.Megaparsec
 
 import           Mima.Flag
+import           Mima.Instruction
 import           Mima.Label
 import           Mima.Parse.Assembly.Common
 import           Mima.Parse.Assembly.Lexeme
+import           Mima.Parse.Assembly.RawInstruction
 import           Mima.Parse.Assembly.Statement
 import           Mima.Parse.Assembly.Weed.Common
 import           Mima.Parse.Assembly.Weed.Resolve
@@ -29,10 +30,17 @@ parseAssembly = space *> many lNewline *> lStatements <* eof
 weedAssembly :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult MimaAddress)
 weedAssembly = weedStatements >=> resolveLabels
 
-formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, Map.Map Char AddressRange)
+almostWordToWord :: AlmostWord MimaAddress -> MimaWord
-formatAssembly = undefined
+almostWordToWord (AInstruction i) = instructionToWord $ cookInstruction i
+almostWordToWord (ALiteral w)     = w
 
-readAssembly :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, LabelSpec, Map.Map Char AddressRange)
+formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags)
+formatAssembly res =
+  let mem = fmap almostWordToWord $ wrMemory res
+      s = registersToState (wrRegisters res) (mapToMemory mem)
+  in  (s, wrLabels res, wrFlags res)
+
+readAssembly :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, LabelSpec, RawFlags)
 readAssembly filename input = do
   unweeded <- parse parseAssembly filename input
   weeded <- runWeedBundle filename input $ weedAssembly unweeded

src/Mima/Parse/Assembly/Weed/Common.hs

@@ -1,16 +1,19 @@
 module Mima.Parse.Assembly.Weed.Common
   ( Registers(..)
   , emptyRegisters
+  , registersToState
   , AlmostWord(..)
   , WeedResult(..)
   , emptyResult
   ) where
 
 import qualified Data.Map as Map
+import           Data.Maybe
 
 import           Mima.Flag
 import           Mima.Label
 import           Mima.Parse.Assembly.RawInstruction
+import           Mima.State
 import           Mima.Word
 
 data Registers a = Registers
@@ -30,6 +33,10 @@ emptyRegisters = Registers
   , rFP  = Nothing
   }
 
+registersToState :: Registers MimaAddress -> MimaMemory -> MimaState
+registersToState r mem = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r)
+  (fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r) mem
+
 data AlmostWord a
   = AInstruction (RawInstruction a)
   | ALiteral MimaWord
@@ -39,7 +46,7 @@ data WeedResult a = WeedResult
   { wrRegisters :: Registers a
   , wrMemory    :: Map.Map MimaAddress (AlmostWord a)
   , wrLabels    :: Map.Map LabelName MimaAddress
-  , wrFlags     :: Map.Map Char [AddressRange]
+  , wrFlags     :: RawFlags
   } deriving (Show)
 
 emptyResult :: WeedResult a

src/Mima/Parse/Assembly/Weed/Statement.hs

@@ -4,10 +4,10 @@ module Mima.Parse.Assembly.Weed.Statement
   ( weedStatements
   ) where
 
+import           Control.Monad
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.State
 import qualified Data.Map as Map
-import           Data.Maybe
 import qualified Data.Set as Set
 
 import           Mima.Flag
@@ -21,18 +21,20 @@ import           Mima.Parse.Weed
 import           Mima.Word
 
 data WeedState = WeedState
-  { wsAt        :: MimaAddress
+  { wsAt          :: MimaAddress
-  , wsOccupied  :: Bool
+  , wsOccupied    :: Bool
-  , wsOpenFlags :: Map.Map Char MimaAddress
+  , wsLastFlagsAt :: MimaAddress
-  , wsResult    :: WeedResult Address
+  , wsOpenFlags   :: Set.Set Char
+  , wsResult      :: WeedResult Address
   } deriving (Show)
 
 initialState :: WeedState
 initialState = WeedState
-  { wsAt        = minBound
+  { wsAt          = 0
-  , wsOccupied  = False
+  , wsOccupied    = False
-  , wsOpenFlags = Map.empty
+  , wsLastFlagsAt = 0
-  , wsResult    = emptyResult
+  , wsOpenFlags   = Set.empty
+  , wsResult      = emptyResult
   }
 
 -- Sweet!
@@ -58,7 +60,7 @@ toNextFree :: WithOffset a -> SWeed MimaAddress
 toNextFree thing = do
   s@WeedState{..} <- get
   if wsOccupied
-    then if wsAt >= maxBound 
+    then if wsAt >= maxBound
          then lift $ critical $ errorAt thing "No more space in memory, already at max address"
          else let next = wsAt + 1 in next <$ put s{wsAt = next, wsOccupied = False}
     else pure wsAt
@@ -100,30 +102,38 @@ addLabel thing l = do
     Nothing -> modifyResult (\r -> r{wrLabels = Map.insert l addr (wrLabels r)})
     Just _  -> lift $ harmless $ errorAt thing "Label was already defined earlier"
 
-addFlagRange :: Char -> AddressRange -> SWeed()
+pushFlags :: Set.Set Char -> SWeed ()
-addFlagRange c r =
+pushFlags newFlags = do
-  modifyResult (\res -> res{wrFlags = Map.alter (Just . (r:) . fromMaybe []) c (wrFlags res)})
+  WeedState{..} <- get
+  unless (Set.null wsOpenFlags) $ do
+    let r = range wsLastFlagsAt wsAt
+    modifyResult (\res -> res{wrFlags = Map.insert r wsOpenFlags (wrFlags res)})
+    modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt})
 
-setFlag :: WithOffset a -> Char -> SWeed ()
+setFlags :: WithOffset a -> Set.Set Char -> SWeed ()
-setFlag thing c = do
+setFlags thing flags = do
-  addr <- toNextFree thing
+  void $ toNextFree thing
-  addFlagRange c $ range addr addr
+  WeedState{..} <- get
+  unless (flags `Set.isSubsetOf` wsOpenFlags) $ do
+    let withFlags = Set.union wsOpenFlags flags
+    pushFlags withFlags
+    pushFlags wsOpenFlags
 
-turnFlagOn :: WithOffset a -> Char -> SWeed ()
+turnFlagsOn :: WithOffset a -> Set.Set Char -> SWeed ()
-turnFlagOn thing c = do
+turnFlagsOn thing flags = do
-  s@WeedState{..} <- get
+  WeedState{..} <- get
-  case wsOpenFlags Map.!? c of
+  let newFlags = Set.union wsOpenFlags flags
-    Just _  -> lift $ harmless $ errorAt thing "Flag is already active at this address"
+  when (flags == newFlags) $
-    Nothing -> put s{wsOpenFlags = Map.insert c wsAt wsOpenFlags}
+    lift $ harmless $ errorAt thing "All flags already active at this address"
+  pushFlags newFlags
 
-turnFlagOff :: WithOffset a -> Char -> SWeed ()
+turnFlagsOff :: WithOffset a -> Set.Set Char -> SWeed ()
-turnFlagOff thing c = do
+turnFlagsOff thing flags = do
-  s@WeedState{..} <- get
+  WeedState{..} <- get
-  case wsOpenFlags Map.!? c of
+  let newFlags = wsOpenFlags Set.\\ flags
-    Nothing    -> lift $ harmless $ errorAt thing "Flag is not active at this address"
+  when (flags == newFlags) $
-    Just start -> do
+    lift $ harmless $ errorAt thing "All flags already inactive at this address"
-      put s {wsOpenFlags = Map.delete c wsOpenFlags}
+  pushFlags newFlags
-      addFlagRange c $ range start wsAt
 
 {- Weeding at a larger scale -}
 
@@ -134,9 +144,9 @@ weedDirective thing d = do
     DOrg addr      -> setAddressTo thing addr
     DLit w         -> addAlmostWord thing (ALiteral w)
     DArr ws        -> mapM_ (addAlmostWord thing . ALiteral) ws
-    DFlag chars    -> mapM_ (setFlag thing)     (Set.toList chars)
+    DFlag flags    -> setFlags thing flags
-    DFlagOn chars  -> mapM_ (turnFlagOn thing)  (Set.toList chars)
+    DFlagOn flags  -> turnFlagsOn thing flags
-    DFlagOff chars -> mapM_ (turnFlagOff thing) (Set.toList chars)
+    DFlagOff flags -> turnFlagsOff thing flags
 
 weedInstruction :: WithOffset a -> RawInstruction Address -> SWeed ()
 weedInstruction thing i = addAlmostWord thing $ AInstruction i