Implement the while loop

.ruby-version

@@ -1 +1 @@
-3.3.5
+3.3.6

lib/Language/Elna/Backend/Allocator.hs

@@ -17,12 +17,21 @@ import Language.Elna.Location (Identifier(..))
 import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Trans.State (State, runState, modify')
 import GHC.Records (HasField(..))
-import Control.Monad.Trans.Class (MonadTrans(lift))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
+import Data.List ((!?))
 
 data Store r
     = RegisterStore r
     | StackStore Word32 r
 
+data AllocationError = AllocationError
+    deriving Eq
+
+instance Show AllocationError
+  where
+    show = const "Ran out of registers during register allocation"
+
 newtype MachineConfiguration r = MachineConfiguration
     { temporaryRegisters :: [r]
     }
@@ -32,7 +41,7 @@ newtype MachineState = MachineState
     } deriving (Eq, Show)
 
 newtype Allocator r a = Allocator
-    { runAllocator :: ReaderT (MachineConfiguration r) (State MachineState) a
+    { runAllocator :: ExceptT AllocationError (ReaderT (MachineConfiguration r) (State MachineState)) a
     }
 
 instance forall r. Functor (Allocator r)
@@ -52,19 +61,21 @@ allocate
     :: forall r
     . MachineConfiguration r
     -> HashMap Identifier (Vector (Quadruple Variable))
-    -> HashMap Identifier (ProcedureQuadruples (Store r))
-allocate machineConfiguration = fmap function
+    -> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
+allocate machineConfiguration = traverse function
   where
-    function :: Vector (Quadruple Variable) -> ProcedureQuadruples (Store r)
+    run = flip runState (MachineState{ stackSize = 0 })
+        . flip runReaderT machineConfiguration
+        . runExceptT
+        . runAllocator
+        . mapM quadruple
+    function :: Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
     function quadruples' =
-        let (result, lastState)
-                = flip runState (MachineState{ stackSize = 0 })
-                $ flip runReaderT machineConfiguration
-                $ runAllocator
-                $ mapM quadruple quadruples'
-         in ProcedureQuadruples
+        let (result, lastState) = run quadruples'
+         in makeResult lastState <$> result
+    makeResult MachineState{ stackSize } result = ProcedureQuadruples
         { quadruples = result
-            , stackSize = getField @"stackSize" lastState
+        , stackSize = stackSize
         }
 
 quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
@@ -131,11 +142,12 @@ operand (VariableOperand variableOperand) =
 
 storeVariable :: Variable -> Allocator r (Store r)
 storeVariable (TempVariable index) = do
-    temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
-    pure $ RegisterStore
-        $ temporaryRegisters' !! fromIntegral index
+    temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
+    maybe (Allocator $ throwE AllocationError) (pure . RegisterStore)
+        $ temporaryRegisters' !? fromIntegral index
+        
 storeVariable (LocalVariable index) = do
-    temporaryRegisters' <- Allocator $ asks $ getField @"temporaryRegisters"
-    Allocator $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize"
-    pure $ StackStore (index * 4)
-        $ temporaryRegisters' !! pred (length temporaryRegisters' - fromIntegral index)
+    temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
+    Allocator $ lift $ lift $ modify' $ MachineState . (+ 4) . getField @"stackSize"
+    maybe (Allocator $ throwE AllocationError) (pure . StackStore (index * 4))
+        $ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index)

lib/Language/Elna/Frontend/AST.hs

@@ -71,7 +71,7 @@ data Statement
     = EmptyStatement
     | IfStatement Condition Statement (Maybe Statement)
     | AssignmentStatement VariableAccess Expression
-    -- | WhileStatement Condition Statement
+    | WhileStatement Condition Statement
     | CompoundStatement [Statement]
     | CallStatement Identifier [Expression]
     deriving Eq
@@ -86,8 +86,8 @@ instance Show Statement
         ]
     show (AssignmentStatement lhs rhs) =
         concat [show lhs, " := ", show rhs, ";"]
-    {-show (WhileStatement expression statement) =
-        concat ["while (", show expression, ") ", show statement, ";"]-}
+    show (WhileStatement expression statement) =
+        concat ["while (", show expression, ") ", show statement, ";"]
     show (CompoundStatement statements) =
         concat ["{\n", unlines (show <$> statements), " }"]
     show (CallStatement name parameters) = show name <> "("

lib/Language/Elna/Frontend/NameAnalysis.hs

@@ -175,9 +175,9 @@ statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
 statement globalTable (AST.AssignmentStatement lvalue rvalue)
     = variableAccess globalTable lvalue
     >> expression globalTable rvalue
---statement globalTable (AST.WhileStatement whileCondition loop)
---    = condition globalTable whileCondition
---    >> statement globalTable loop
+statement globalTable (AST.WhileStatement whileCondition loop)
+    = condition globalTable whileCondition
+    >> statement globalTable loop
 
 condition :: SymbolTable -> AST.Condition -> NameAnalysis ()
 condition globalTable (AST.EqualCondition lhs rhs)

lib/Language/Elna/Frontend/Parser.hs

@@ -188,7 +188,7 @@ statementP
     <|> ifElseP
     <|> CompoundStatement <$> blockP (many statementP)
     <|> try assignmentP
-    -- <|> try whileP
+    <|> try whileP
     <|> callP
     <?> "statement"
   where
@@ -200,9 +200,9 @@ statementP
         <$> (symbol "if" *> parensP conditionP)
         <*> statementP
         <*> optional (symbol "else" *> statementP)
-    {-whileP = WhileStatement
+    whileP = WhileStatement
         <$> (symbol "while" *> parensP conditionP)
-        <*> statementP -}
+        <*> statementP
     assignmentP = AssignmentStatement
         <$> variableAccessP
         <* symbol ":="

lib/Language/Elna/Frontend/TypeAnalysis.hs

@@ -101,11 +101,11 @@ statement globalTable = \case
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
         unless (rhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
-    {- AST.WhileStatement whileCondition whileStatement -> do
+    AST.WhileStatement whileCondition whileStatement -> do
         conditionType <- condition globalTable whileCondition
         unless (conditionType == booleanType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
-        statement globalTable whileStatement -}
+        statement globalTable whileStatement
     AST.IfStatement ifCondition ifStatement elseStatement -> do
         conditionType <- condition globalTable ifCondition
         unless (conditionType == booleanType)

lib/Language/Elna/Glue.hs

@@ -131,7 +131,7 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
                 . AssignQuadruple rhsOperand
                 <$> lookupLocal identifier
     pure $ rhsStatements <> lhsStatements
-{- statement localTable (AST.WhileStatement whileCondition whileStatement) = do
+statement localTable (AST.WhileStatement whileCondition whileStatement) = do
     (conditionStatements, jumpConstructor) <- condition localTable whileCondition
     startLabel <- createLabel
     endLabel <- createLabel
@@ -141,7 +141,7 @@ statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
         <> conditionStatements
         <> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
         <> whileStatements
-        <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel] -}
+        <> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
 
 createTemporary :: Glue Variable
 createTemporary = do

src/Main.hs

@@ -25,6 +25,7 @@ import Control.Exception (IOException, catch)
 -- 3 - Parse error.
 -- 4 - Name analysis error.
 -- 5 - Type error.
+-- 6 - Register allocation error.
 
 main :: IO ()
 main = execParser commandLine >>= withCommandLine
@@ -45,9 +46,9 @@ main = execParser commandLine >>= withCommandLine
         | Just typeError <- typeAnalysis symbolTable program =
             printAndExit 5 typeError
         | otherwise =
-            let instructions = generateRiscV
+            let makeObject = elfObject output . riscv32Elf . generateRiscV
+             in either (printAndExit 6) makeObject
                 $ allocate riscVConfiguration
                 $ glue symbolTable program
-             in elfObject output $ riscv32Elf instructions
     printAndExit :: Show b => forall a. Int -> b -> IO a
     printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode)

tests/expectations/print_after_loop.txt

@@ -0,0 +1 @@
+2

tests/vm/print_after_loop.elna

@@ -0,0 +1,9 @@
+proc main() {
+  var x: int;
+
+  x := 0;
+  while (x < 2) {
+    x := x + 1;
+  }
+  printi(x);
+}