Implement WHILE loops

1 files changed, 29 insertions, 5 deletions

diff --git a/DSL.hs b/DSL.hs
index 06d895c..e5589ea 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -61,6 +61,7 @@ data Block
   = BLinear [Operation]
   | BIf [Block] [Block]
   | BIfElse [Block] [Block] [Block]
+  | BWhile [Block] [Block]
     deriving (Show)
 
 type Program = [Block]
@@ -73,6 +74,7 @@ data TokenData
   = T_WHITESPACE
   | T_IF
   | T_ELSE
+  | T_WHILE
   | T_DO
   | T_END
   | T_BOOL_LITERAL Bool
@@ -128,10 +130,11 @@ mainLexer = phrase $ mult1 $ firstOf subLexers
              ++ keywords
              ++ literals
              ++ intrinsics
-    keywords = map (uncurry keywordL) [ ("IF",   T_IF)
-                                      , ("ELSE", T_ELSE)
-                                      , ("DO",   T_DO)
-                                      , ("END",  T_END)
+    keywords = map (uncurry keywordL) [ ("IF",    T_IF)
+                                      , ("ELSE",  T_ELSE)
+                                      , ("WHILE", T_WHILE)
+                                      , ("DO",    T_DO)
+                                      , ("END",   T_END)
                                       ]
     literals = [ boolLiteralL
                , intLiteralL
@@ -207,8 +210,15 @@ ifElseP = do
   b2 <- mult blockP <* tokenDataP T_END
   return $ BIfElse c b1 b2
 
+whileP :: DSLParser Block
+whileP = do
+  c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO
+  b <- mult blockP <* tokenDataP T_END
+  return $ BWhile c b
+
 blockP :: DSLParser Block
-blockP = firstOf [ ifElseP
+blockP = firstOf [ whileP
+                 , ifElseP
                  , ifP
                  , linearP
                  ]
@@ -435,12 +445,26 @@ applyIfElse c b1 b2 m                   = do
     Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs }
     Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
 
+applyWhile :: [Block] -> [Block] -> Machine -> IO Machine
+applyWhile _ _ m@Machine{ ok=False } = return m
+applyWhile c b m                     = do
+  m' <- evalBlocks c m
+  case m' of
+    Machine{ ok=False }                 -> return m'
+    Machine{ stack=[] }                 -> hcf m' "WHILE: stack underflow"
+    Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
+    Machine{ stack=StackBool True:xs }  -> do
+      m'' <- evalBlocks b m'{ stack=xs }
+      applyWhile c b m''
+    Machine{ stack=_:_ }                -> hcf m' "WHILE: type mis-match"
+
 evalBlocks :: [Block] -> Machine -> IO Machine
 evalBlocks _ m@Machine{ ok=False } = return m
 evalBlocks [] m                    = return m
 evalBlocks (BLinear b:bs) m        = applyLinear m b >>= evalBlocks bs
 evalBlocks (BIf c b:bs) m          = applyIf c b m >>= evalBlocks bs
 evalBlocks (BIfElse c b1 b2:bs) m  = applyIfElse c b1 b2 m >>= evalBlocks bs
+evalBlocks (BWhile c b:bs) m       = applyWhile c b m >>= evalBlocks bs
 
 interpret :: Program -> IO ()
 interpret p = evalBlocks p newMachine >> return ()