Access multidimensional arrays

1 files changed, 101 insertions, 4 deletions

diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs
index 8c4fec8..9245fb4 100644
--- a/lib/Language/Elna/Intermediate.hs
+++ b/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