From 7f59fd16534fc4fe417640130c415107008a638c Mon Sep 17 00:00:00 2001
From: Aleksey Veresov <aleksey@veresov.pro>
Date: Tue, 16 Feb 2021 13:11:37 +0300
Subject: Now Machine is in Emulator which is a monad. =)

---
 src/Commands.hs | 99 +++++++++++++++++++++++++++------------------------------
 1 file changed, 47 insertions(+), 52 deletions(-)

(limited to 'src/Commands.hs')

diff --git a/src/Commands.hs b/src/Commands.hs
index 6d99b00..e22981e 100644
--- a/src/Commands.hs
+++ b/src/Commands.hs
@@ -1,74 +1,69 @@
+-- This module describes the semantics of machine commands.
 module Commands where
 
-import Control.Lens
+import Prelude hiding (Word)
 import Machine
 import Utils
+import Data.IORef
 
-doNothing :: Machine -> Machine
-doNothing m = Machine (Registers (pc r + 2) (sr r) (drs r)
-                                 (ars r) (usp r) (ssp r))
-                      (ram m) (rom m)
-    where r = regs m
 
-_doUnlink :: Int -> Machine -> Machine
-_doUnlink 7 m = let r = regs m in if isSupervisor m
-    then Machine (Registers (pc r + 2) (sr r) (drs r) (ars r)
-                            (usp r) (getLong m (fromIntegral $ ssp r) + 4))
-                 (ram m) (rom m)
-    else Machine (Registers (pc r + 2) (sr r) (drs r) (ars r)
-                            (getLong m (fromIntegral $ usp r) + 4) (ssp r))
-                 (ram m) (rom m)
-_doUnlink a m = let
-        r = regs m
-        av = getLong m (fromIntegral (ars r !! a))
-        newars = ars r & element (fromIntegral a) .~ av
-    in if isSupervisor m
-    then Machine (Registers (pc r + 2) (sr r) (drs r)
-                            newars (usp r) (av + 4))
-                 (ram m) (rom m)
-    else Machine (Registers (pc r + 2) (sr r) (drs r)
-                            newars (av + 4) (ssp r))
-                 (ram m) (rom m)
-doUnlink :: [Int] -> Machine -> Machine
+doNothing :: Emulator ()
+doNothing = with pc $ \pc -> do
+    pcval <- readIORef pc
+    writeIORef pc (pcval + 2)
+
+_doUnlink :: Int -> Emulator ()
+_doUnlink a = do
+    addr <- readA a
+    val <- getLong addr
+    with pc $ \pc -> do
+        pcval <- readIORef pc
+        writeIORef pc (pcval + 2)
+    isSupervisor >>= \sup -> if sup
+    then with ssp $ \sp -> do
+        writeIORef sp (val + 4)
+    else with usp $ \sp -> do
+        writeIORef sp (val + 4)
+doUnlink :: [Int] -> Emulator ()
 doUnlink = _doUnlink . fromBits
 
-doReset :: Machine -> Machine
-doReset = id
+doReset :: Emulator ()
+doReset = return ()
 
-doStop :: Machine -> Machine
-doStop = id
+doStop :: Emulator ()
+doStop = return ()
 
-doRTE :: Machine -> Machine
-doRTE = id
+doRTE :: Emulator ()
+doRTE = return ()
 
-doRTS :: Machine -> Machine
-doRTS = id
+doRTS :: Emulator ()
+doRTS = return ()
 
-doTrapV :: Machine -> Machine
-doTrapV = id
+doTrapV :: Emulator ()
+doTrapV = return ()
 
-doRTR :: Machine -> Machine
-doRTR = id
+doRTR :: Emulator ()
+doRTR = return ()
 
-doIllegal :: Machine -> Machine
-doIllegal = id
+doIllegal :: Emulator ()
+doIllegal = return ()
 
-_doTAS :: Int -> Int -> Machine -> Machine
-_doTAS _ _ = id
-doTAS :: [Int] -> [Int] -> Machine -> Machine
+_doTAS :: Int -> Int -> Emulator ()
+_doTAS _ _ = return ()
+doTAS :: [Int] -> [Int] -> Emulator ()
 doTAS = args2 _doTAS
 
-_doTST :: Int -> Int -> Int -> Machine -> Machine
-_doTST _ _ _ = id
-doTST :: [Int] -> [Int] -> [Int] -> Machine -> Machine
+_doTST :: Int -> Int -> Int -> Emulator ()
+_doTST _ _ _ = return ()
+doTST :: [Int] -> [Int] -> [Int] -> Emulator ()
 doTST = args3 _doTST
 
-_doTrap :: Int -> Machine -> Machine
-_doTrap _ = id
-doTrap :: [Int] -> Machine -> Machine
+_doTrap :: Int -> Emulator ()
+_doTrap _ = return ()
+doTrap :: [Int] -> Emulator ()
 doTrap = _doTrap . fromBits
 
-_doLink :: Int -> Machine -> Machine
-_doLink _ = id
-doLink :: [Int] -> Machine -> Machine
+_doLink :: Int -> Emulator ()
+_doLink _ = return ()
+doLink :: [Int] -> Emulator ()
 doLink = _doLink . fromBits
-- 
cgit v1.2.3