diff --git a/lib/Language/Elna/AST.hs b/lib/Language/Elna/AST.hs index 189fcb5..ac86e63 100644 --- a/lib/Language/Elna/AST.hs +++ b/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] - show (LessExpression lhs rhs) = concat [show lhs, " < ", show rhs] - show (GreaterExpression lhs rhs) = concat [show lhs, " > ", show rhs] - show (LessOrEqualExpression lhs rhs) = concat [show lhs, " <= ", show rhs] - show (GreaterOrEqualExpression lhs rhs) = concat [show lhs, " >= ", show rhs] - show (ArrayExpression arrayExpression indexExpression) = - concat [show arrayExpression, "[", show indexExpression, "]"] + +data Condition + = EqualCondition Expression Expression + | NonEqualCondition Expression Expression + | LessCondition Expression Expression + | GreaterCondition Expression Expression + | LessOrEqualCondition Expression Expression + | 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 - | IfStatement Expression Statement (Maybe Statement) - | WhileStatement Expression Statement + | AssignmentStatement VariableAccess Expression + | IfStatement Condition Statement (Maybe Statement) + | WhileStatement Condition Statement | CompoundStatement [Statement] | CallStatement Identifier [Expression] deriving Eq 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 diff --git a/lib/Language/Elna/NameAnalysis.hs b/lib/Language/Elna/NameAnalysis.hs index 7078691..0034628 100644 --- a/lib/Language/Elna/NameAnalysis.hs +++ b/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) - = expression globalTable condition +statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement) + = condition globalTable ifCondition >> statement globalTable ifStatement >> maybe (pure ()) (statement globalTable) elseStatement -statement globalTable (AST.WhileStatement condition loop) - = expression globalTable condition +statement globalTable (AST.WhileStatement whileCondition loop) + = 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 identifier globalTable = +checkSymbol :: SymbolTable -> Identifier -> NameAnalysis () +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) = - checkSymbol identifier globalTable +expression globalTable (AST.VariableExpression variableExpression) = + 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 - >> expression globalTable rhs -expression globalTable (AST.NonEqualExpression lhs rhs) - = 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 + +variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis () +variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) + = variableAccess 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 diff --git a/lib/Language/Elna/Parser.hs b/lib/Language/Elna/Parser.hs index cee533e..aa7c315 100644 --- a/lib/Language/Elna/Parser.hs +++ b/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,19 +126,23 @@ 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 = + unaryOperator = [ prefix "-" NegationExpression , prefix "+" id ] @@ -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 diff --git a/lib/Language/Elna/TypeAnalysis.hs b/lib/Language/Elna/TypeAnalysis.hs index c390196..0d939e3 100644 --- a/lib/Language/Elna/TypeAnalysis.hs +++ b/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) - $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError lhs - AST.IfStatement condition ifStatement elseStatement -> do - conditionType <- expression globalTable condition + AST.IfStatement ifCondition ifStatement elseStatement -> do + conditionType <- condition globalTable ifCondition unless (conditionType == booleanType) $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType statement globalTable ifStatement maybe (pure ()) (statement globalTable) elseStatement - AST.WhileStatement condition whileStatement -> do - conditionType <- expression globalTable condition + AST.WhileStatement whileCondition whileStatement -> do + 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 - 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 + AST.VariableExpression variableExpression -> do + variableAccess globalTable variableExpression 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