Access multidimensional arrays

lib/Language/Elna/AST.hs

@@ -1,5 +1,7 @@
 module Language.Elna.AST
-    ( Declaration(..)
+    ( VariableAccess(..)
+    , Condition(..)
+    , Declaration(..)
     , Expression(..)
     , Identifier(..)
     , Literal(..)
@@ -44,21 +46,25 @@ instance Show Literal
         | boolean = "true"
         | otherwise = "false"
 
+data VariableAccess
+    = VariableAccess Identifier
+    | ArrayAccess VariableAccess Expression
+    deriving Eq
+
+instance Show VariableAccess
+  where
+    show (VariableAccess variableName) = show variableName
+    show (ArrayAccess arrayAccess elementIndex) =
+        concat [show arrayAccess, "[", show elementIndex, "]"]
+
 data Expression
-    = VariableExpression Identifier
+    = VariableExpression VariableAccess
     | LiteralExpression Literal
     | NegationExpression Expression
     | SumExpression Expression Expression
     | SubtractionExpression Expression Expression
     | ProductExpression Expression Expression
     | DivisionExpression Expression Expression
-    | EqualExpression Expression Expression
-    | NonEqualExpression Expression Expression
-    | LessExpression Expression Expression
-    | GreaterExpression Expression Expression
-    | LessOrEqualExpression Expression Expression
-    | GreaterOrEqualExpression Expression Expression
-    | ArrayExpression Expression Expression
     deriving Eq
 
 instance Show Expression
@@ -70,20 +76,30 @@ instance Show Expression
     show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs]
     show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
     show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs]
-    show (EqualExpression lhs rhs) = concat [show lhs, " = ", show rhs]
+
-    show (NonEqualExpression lhs rhs) = concat [show lhs, " # ", show rhs]
+data Condition
-    show (LessExpression lhs rhs) = concat [show lhs, " < ", show rhs]
+    = EqualCondition Expression Expression
-    show (GreaterExpression lhs rhs) = concat [show lhs, " > ", show rhs]
+    | NonEqualCondition Expression Expression
-    show (LessOrEqualExpression lhs rhs) = concat [show lhs, " <= ", show rhs]
+    | LessCondition Expression Expression
-    show (GreaterOrEqualExpression lhs rhs) = concat [show lhs, " >= ", show rhs]
+    | GreaterCondition Expression Expression
-    show (ArrayExpression arrayExpression indexExpression) =
+    | LessOrEqualCondition Expression Expression
-        concat [show arrayExpression, "[", show indexExpression, "]"]
+    | GreaterOrEqualCondition Expression Expression
+    deriving Eq
+
+instance Show Condition
+  where
+    show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs]
+    show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs]
+    show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs]
+    show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs]
+    show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs]
+    show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs]
 
 data Statement
     = EmptyStatement
-    | AssignmentStatement Expression Expression
+    | AssignmentStatement VariableAccess Expression
-    | IfStatement Expression Statement (Maybe Statement)
+    | IfStatement Condition Statement (Maybe Statement)
-    | WhileStatement Expression Statement
+    | WhileStatement Condition Statement
     | CompoundStatement [Statement]
     | CallStatement Identifier [Expression]
     deriving Eq

lib/Language/Elna/Intermediate.hs

@@ -3,28 +3,37 @@ module Language.Elna.Intermediate
     , Operand(..)
     , Quadruple(..)
     , Variable(..)
+    , intermediate
     ) where
 
 import Data.Int (Int32)
-import Data.Word (Word32)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
+import Data.Word (Word32)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import qualified Language.Elna.AST as AST
+import Language.Elna.Types (Type(..))
+import Language.Elna.SymbolTable (SymbolTable, Info(..))
+import qualified Language.Elna.SymbolTable as SymbolTable
 
 data Operand
-    = VariableOperand Text
+    = VariableOperand Variable
     | IntOperand Int32
     deriving (Eq, Show)
 
 newtype Label = Label Text
     deriving (Eq, Show)
 
-newtype Variable = Variable Text
+data Variable = Variable Text | TempVariable
     deriving (Eq, Show)
 
 data Quadruple
     = StartQuadruple
     | GoToQuadruple Label
     | AssignQuadruple Operand Variable
-    | ArrayQuadruple Variable Word32 Variable
+    | ArrayQuadruple Variable Operand Variable
     | ArrayAssignQuadruple Operand Word32 Variable
     | AddQuadruple Operand Operand Variable
     | SubtractionQuadruple Operand Operand Variable
@@ -42,3 +51,91 @@ data Quadruple
     | CallQuadruple Variable Word32
     | StopQuadruple
     deriving (Eq, Show)
+
+intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
+intermediate globalTable (AST.Program declarations) =
+    foldr go HashMap.empty declarations
+  where
+    go (AST.TypeDefinition _ _) accumulator = accumulator
+    go (AST.ProcedureDefinition procedureName _ _ statements) accumulator =
+        let translatedStatements
+                = Vector.cons StartQuadruple
+                $ flip Vector.snoc StopQuadruple
+                $ foldMap (statement globalTable) statements
+         in HashMap.insert procedureName translatedStatements accumulator
+
+statement :: SymbolTable -> AST.Statement -> Vector Quadruple
+statement _ AST.EmptyStatement = mempty
+statement globalTable (AST.CompoundStatement statements) =
+    foldMap (statement globalTable) statements
+
+variableAccess
+    :: SymbolTable
+    -> AST.VariableAccess
+    -> Maybe Operand
+    -> Type
+    -> Vector Quadruple
+    -> (AST.Identifier, Maybe Operand, Vector Quadruple)
+variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
+    (identifier, accumulatedIndex, accumulatedStatements)
+variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ =
+    let (indexPlace, statements) = expression localTable index1
+     in variableAccess localTable access1 (Just indexPlace) baseType statements
+variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements =
+    let (indexPlace, statements') = expression localTable arrayIndex
+        resultVariable = TempVariable
+        resultOperand = VariableOperand resultVariable
+        indexCalculation = Vector.fromList
+            [ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
+            , AddQuadruple indexPlace resultOperand resultVariable
+            ]
+     in variableAccess localTable arrayAccess' (Just resultOperand) baseType
+        $ statements <> indexCalculation <> statements'
+variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
+
+variableType :: AST.VariableAccess -> SymbolTable -> Type
+variableType (AST.VariableAccess identifier) symbolTable
+    | Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
+    | otherwise = error "Undefined type."
+variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
+    variableType arrayAccess' symbolTable
+
+expression :: SymbolTable -> AST.Expression -> (Operand, Vector Quadruple)
+expression localTable = \case
+    (AST.VariableExpression variableExpression) ->
+        let variableType' = variableType variableExpression localTable
+         in case variableAccess localTable variableExpression Nothing variableType' mempty of
+            (AST.Identifier identifier, Nothing, statements) ->
+                (VariableOperand (Variable identifier), statements)
+            (AST.Identifier identifier, Just operand, statements) ->
+                let arrayAddress = TempVariable
+                    arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
+                 in (VariableOperand arrayAddress, Vector.snoc statements arrayStatement)
+    (AST.LiteralExpression literal') -> (literal literal', mempty)
+    (AST.NegationExpression negation) ->
+        let (operand, statements) = expression localTable negation
+            tempVariable = TempVariable
+            negationQuadruple = NegationQuadruple operand tempVariable
+         in (VariableOperand tempVariable, Vector.snoc statements negationQuadruple)
+    (AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
+    (AST.SubtractionExpression lhs rhs) ->
+        binaryExpression SubtractionQuadruple lhs rhs
+    (AST.ProductExpression lhs rhs) ->
+        binaryExpression ProductQuadruple lhs rhs
+    (AST.DivisionExpression lhs rhs) ->
+        binaryExpression DivisionQuadruple lhs rhs
+  where
+    binaryExpression f lhs rhs = 
+        let (lhsOperand, lhsStatements) = expression localTable lhs
+            (rhsOperand, rhsStatements) = expression localTable rhs
+            tempVariable = TempVariable
+            newQuadruple = f lhsOperand rhsOperand tempVariable
+         in (VariableOperand tempVariable, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple)
+
+literal :: AST.Literal -> Operand
+literal (AST.IntegerLiteral integer) = IntOperand integer
+literal (AST.HexadecimalLiteral integer) = IntOperand integer
+literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character
+literal (AST.BooleanLiteral boolean)
+    | boolean = IntOperand 1
+    | otherwise = IntOperand 0

lib/Language/Elna/NameAnalysis.hs

@@ -83,23 +83,23 @@ declaration globalTable (AST.ProcedureDefinition identifier parameters variables
 statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
 statement _ AST.EmptyStatement = pure ()
 statement globalTable (AST.AssignmentStatement lvalue rvalue)
-    = expression globalTable lvalue
+    = variableAccess globalTable lvalue
     >> expression globalTable rvalue
-statement globalTable (AST.IfStatement condition ifStatement elseStatement)
+statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
-    = expression globalTable condition
+    = condition globalTable ifCondition
     >> statement globalTable ifStatement
     >> maybe (pure ()) (statement globalTable) elseStatement
-statement globalTable (AST.WhileStatement condition loop)
+statement globalTable (AST.WhileStatement whileCondition loop)
-    = expression globalTable condition
+    = condition globalTable whileCondition
     >> statement globalTable loop
 statement globalTable (AST.CompoundStatement statements) =
     traverse_ (statement globalTable) statements
 statement globalTable (AST.CallStatement name arguments)
-    = checkSymbol name globalTable
+    = checkSymbol globalTable name
     >> traverse_ (expression globalTable) arguments
 
-checkSymbol :: Identifier -> SymbolTable -> NameAnalysis ()
+checkSymbol :: SymbolTable -> Identifier -> NameAnalysis ()
-checkSymbol identifier globalTable =
+checkSymbol globalTable identifier =
     let undefinedSymbolError = NameAnalysis
             $ lift
             $ throwE
@@ -109,8 +109,8 @@ checkSymbol identifier globalTable =
         >>= (flip unless undefinedSymbolError . (isDefined ||))
 
 expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
-expression globalTable (AST.VariableExpression identifier) =
+expression globalTable (AST.VariableExpression variableExpression) =
-    checkSymbol identifier globalTable
+    variableAccess globalTable variableExpression
 expression _ (AST.LiteralExpression _) = pure ()
 expression globalTable (AST.NegationExpression negation) =
     expression globalTable negation
@@ -126,27 +126,33 @@ expression globalTable (AST.ProductExpression lhs rhs)
 expression globalTable (AST.DivisionExpression lhs rhs)
     = expression globalTable lhs
     >> expression globalTable rhs
-expression globalTable (AST.EqualExpression lhs rhs)
+
-    = expression globalTable lhs
+variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis ()
-    >> expression globalTable rhs
+variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression)
-expression globalTable (AST.NonEqualExpression lhs rhs)
+    = variableAccess globalTable arrayExpression
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.LessExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.GreaterExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.LessOrEqualExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.GreaterOrEqualExpression lhs rhs)
-    = expression globalTable lhs
-    >> expression globalTable rhs
-expression globalTable (AST.ArrayExpression arrayExpression indexExpression)
-    = expression globalTable arrayExpression
     >> expression globalTable indexExpression
+variableAccess globalTable (AST.VariableAccess identifier) =
+    checkSymbol globalTable identifier
+
+condition :: SymbolTable -> AST.Condition -> NameAnalysis ()
+condition globalTable (AST.EqualCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
+condition globalTable (AST.NonEqualCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
+condition globalTable (AST.LessCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
+condition globalTable (AST.GreaterCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
+condition globalTable (AST.LessOrEqualCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
+condition globalTable (AST.GreaterOrEqualCondition lhs rhs)
+    = expression globalTable lhs
+    >> expression globalTable rhs
 
 enter :: Identifier -> Info -> SymbolTable -> NameAnalysis SymbolTable
 enter identifier info table

lib/Language/Elna/Parser.hs

@@ -9,7 +9,9 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Void (Void)
 import Language.Elna.AST
-    ( Declaration(..)
+    ( VariableAccess(..)
+    , Condition(..)
+    , Declaration(..)
     , Expression(..)
     , Identifier(..)
     , Literal(..)
@@ -21,12 +23,12 @@ import Language.Elna.AST
     )
 import Text.Megaparsec
     ( Parsec
+    , MonadParsec(..)
     , (<?>)
     , optional
     , between
     , sepBy
     , choice
-    , MonadParsec(..)
     )
 import Text.Megaparsec.Char
     ( alphaNumChar
@@ -124,16 +126,20 @@ termP :: Parser Expression
 termP = choice
     [ parensP expressionP
     , LiteralExpression <$> literalP
-    , VariableExpression <$> identifierP
+    , VariableExpression <$> variableAccessP
     ]
 
+variableAccessP :: Parser VariableAccess
+variableAccessP = do
+    identifier <- identifierP
+    indices <- many $ bracketsP expressionP
+    pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices
+
 operatorTable :: [[Operator Parser Expression]]
 operatorTable =
-    [ [Postfix (flip ArrayExpression <$> bracketsP expressionP)]
+    [ unaryOperator
-    , unaryOperator
     , factorOperator
     , termOperator
-    , comparisonOperator
     ]
   where
     unaryOperator =
@@ -148,20 +154,27 @@ operatorTable =
         [ binary "+" SumExpression
         , binary "-" SubtractionExpression
         ]
-    comparisonOperator =
-        [ binary "<" LessExpression
-        , binary "<=" LessOrEqualExpression
-        , binary ">" GreaterExpression
-        , binary ">=" GreaterOrEqualExpression
-        , binary "=" EqualExpression
-        , binary "#" NonEqualExpression
-        ]
     prefix name f = Prefix (f <$ symbol name)
     binary name f = InfixL (f <$ symbol name)
 
 expressionP :: Parser Expression
 expressionP = makeExprParser termP operatorTable
 
+conditionP :: Parser Condition
+conditionP = do
+    lhs <- expressionP
+    conditionCons <- choice comparisonOperator
+    conditionCons lhs <$> expressionP
+  where
+    comparisonOperator =
+        [ symbol "<" >> pure LessCondition
+        , symbol "<=" >> pure LessOrEqualCondition
+        , symbol ">" >> pure GreaterCondition
+        , symbol ">=" >> pure GreaterOrEqualCondition
+        , symbol "=" >> pure EqualCondition
+        , symbol "#" >> pure NonEqualCondition
+        ]
+
 statementP :: Parser Statement
 statementP
     = EmptyStatement <$ semicolonP
@@ -173,18 +186,18 @@ statementP
     <?> "statement"
   where
     ifElseP = IfStatement
-        <$> (symbol "if" *> parensP expressionP)
+        <$> (symbol "if" *> parensP conditionP)
         <*> statementP
         <*> optional (symbol "else" *> statementP)
     whileP = WhileStatement
-        <$> (symbol "while" *> parensP expressionP)
+        <$> (symbol "while" *> parensP conditionP)
         <*> statementP
     callP = CallStatement
         <$> identifierP
         <*> parensP (sepBy expressionP commaP)
         <* semicolonP
     assignmentP = AssignmentStatement
-        <$> expressionP
+        <$> variableAccessP
         <* symbol ":="
         <*> expressionP
         <* semicolonP

lib/Language/Elna/TypeAnalysis.hs

@@ -76,22 +76,20 @@ statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
 statement globalTable = \case
     AST.EmptyStatement -> pure ()
     AST.AssignmentStatement lhs rhs -> do
-        lhsType <- expression globalTable lhs
+        lhsType <- variableAccess globalTable lhs
         rhsType <- expression globalTable rhs
         unless (lhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
         unless (rhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
-        unless (isLvalue lhs)
+    AST.IfStatement ifCondition ifStatement elseStatement -> do
-            $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError lhs
+        conditionType <- condition globalTable ifCondition
-    AST.IfStatement condition ifStatement elseStatement -> do
-        conditionType <- expression globalTable condition
         unless (conditionType == booleanType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
         statement globalTable ifStatement
         maybe (pure ()) (statement globalTable) elseStatement
-    AST.WhileStatement condition whileStatement -> do
+    AST.WhileStatement whileCondition whileStatement -> do
-        conditionType <- expression globalTable condition
+        conditionType <- condition globalTable whileCondition
         unless (conditionType == booleanType)
             $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
         statement globalTable whileStatement
@@ -116,20 +114,32 @@ statement globalTable = \case
             $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
         when (isReferenceParameter && not (isLvalue argument))
             $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument
-    isLvalue (AST.ArrayExpression arrayExpression _) = isLvalue arrayExpression
     isLvalue (AST.VariableExpression _) = True
     isLvalue _ = False
 
+variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type
+variableAccess globalTable (AST.VariableAccess identifier) = do
+    localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier
+    case localLookup <|> SymbolTable.lookup identifier globalTable of
+        Just (VariableInfo _ variableType) -> pure variableType
+        Just anotherInfo -> TypeAnalysis $ lift $ throwE
+            $ UnexpectedVariableInfoError anotherInfo
+        Nothing -> TypeAnalysis $ lift $ throwE
+            $ UndefinedSymbolError identifier
+variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do
+        arrayType <- variableAccess globalTable arrayExpression
+        indexType <- expression globalTable indexExpression
+        unless (indexType == intType)
+            $ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType
+        case arrayType of
+            ArrayType _ baseType -> pure baseType
+            nonArrayType -> TypeAnalysis $ lift $ throwE
+                $ ArrayAccessError nonArrayType
+
 expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type
 expression globalTable = \case
-    AST.VariableExpression identifier -> do
+    AST.VariableExpression variableExpression -> do
-        localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier
+        variableAccess globalTable variableExpression
-        case localLookup <|> SymbolTable.lookup identifier globalTable of
-            Just (VariableInfo _ variableType) -> pure variableType
-            Just anotherInfo -> TypeAnalysis $ lift $ throwE
-                $ UnexpectedVariableInfoError anotherInfo
-            Nothing -> TypeAnalysis $ lift $ throwE
-                $ UndefinedSymbolError identifier
     AST.LiteralExpression literal' -> literal literal'
     AST.NegationExpression negation -> do
         operandType <- expression globalTable negation
@@ -140,21 +150,6 @@ expression globalTable = \case
     AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs
     AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs
     AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs
-    AST.EqualExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.NonEqualExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.LessExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.GreaterExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.LessOrEqualExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.GreaterOrEqualExpression lhs rhs -> comparisonExpression lhs rhs
-    AST.ArrayExpression arrayExpression indexExpression -> do
-        arrayType <- expression globalTable arrayExpression
-        indexType <- expression globalTable indexExpression
-        unless (indexType == intType)
-            $ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType
-        case arrayType of
-            ArrayType _ baseType -> pure baseType
-            nonArrayType -> TypeAnalysis $ lift $ throwE
-                $ ArrayAccessError nonArrayType
   where
     arithmeticExpression lhs rhs = do
         lhsType <- expression globalTable lhs
@@ -164,10 +159,20 @@ expression globalTable = \case
         unless (rhsType == intType)
             $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType
         pure intType
+
+condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type
+condition globalTable = \case
+    AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs
+    AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs
+    AST.LessCondition lhs rhs -> comparisonExpression lhs rhs
+    AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs
+    AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
+    AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
+  where
     comparisonExpression lhs rhs = do
         lhsType <- expression globalTable lhs
         rhsType <- expression globalTable rhs
-        if lhsType == intType && rhsType ==intType
+        if lhsType == intType && rhsType == intType
         then pure booleanType
         else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType