summaryrefslogtreecommitdiff
path: root/lib/Language/Elna/Frontend
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Language/Elna/Frontend')
-rw-r--r--lib/Language/Elna/Frontend/AST.hs169
-rw-r--r--lib/Language/Elna/Frontend/NameAnalysis.hs216
-rw-r--r--lib/Language/Elna/Frontend/Parser.hs223
-rw-r--r--lib/Language/Elna/Frontend/SymbolTable.hs88
-rw-r--r--lib/Language/Elna/Frontend/TypeAnalysis.hs186
-rw-r--r--lib/Language/Elna/Frontend/Types.hs29
6 files changed, 911 insertions, 0 deletions
diff --git a/lib/Language/Elna/Frontend/AST.hs b/lib/Language/Elna/Frontend/AST.hs
new file mode 100644
index 0000000..738ddcc
--- /dev/null
+++ b/lib/Language/Elna/Frontend/AST.hs
@@ -0,0 +1,169 @@
+module Language.Elna.Frontend.AST
+ ( Declaration(..)
+ , Identifier(..)
+ , Parameter(..)
+ , Program(..)
+ , Statement(..)
+ , TypeExpression(..)
+ , VariableDeclaration(..)
+ {-, VariableAccess(..)
+ , Condition(..)-}
+ , Expression(..)
+ , Literal(..)
+ ) where
+
+import Data.Int (Int32)
+import Data.List (intercalate)
+import Data.Word ({-Word16, -}Word32)
+import Language.Elna.Location (Identifier(..), showArrayType)
+
+newtype Program = Program [Declaration]
+ deriving Eq
+
+instance Show Program
+ where
+ show (Program declarations) = unlines (show <$> declarations)
+
+data Declaration
+ = ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement]
+ -- | TypeDefinition Identifier TypeExpression
+ deriving Eq
+
+instance Show Declaration
+ where
+ {- show (TypeDefinition identifier typeExpression) =
+ concat ["type ", show identifier, " = ", show typeExpression, ";"] -}
+ show (ProcedureDeclaration procedureName parameters variables body)
+ = "proc " <> show procedureName <> showParameters parameters <> " {\n"
+ <> unlines ((" " <>) . show <$> variables)
+ <> unlines ((" " <>) . show <$> body)
+ <> "}"
+
+data Parameter = Parameter Identifier TypeExpression Bool
+ deriving Eq
+
+instance Show Parameter
+ where
+ show (Parameter identifier typeName ref) = concat
+ [ if ref then "ref " else ""
+ , show identifier, ": ", show typeName
+ ]
+
+showParameters :: [Parameter] -> String
+showParameters parameters =
+ "(" <> intercalate ", " (show <$> parameters) <> ")"
+
+data TypeExpression
+ = NamedType Identifier
+ | ArrayType Word32 TypeExpression
+ deriving Eq
+
+instance Show TypeExpression
+ where
+ show (NamedType typeName) = show typeName
+ show (ArrayType elementCount typeName) = showArrayType elementCount typeName
+
+data Statement
+ = EmptyStatement
+ {-| AssignmentStatement VariableAccess Expression
+ | IfStatement Condition Statement (Maybe Statement)
+ | WhileStatement Condition Statement
+ | CompoundStatement [Statement]-}
+ | CallStatement Identifier [Expression]
+ deriving Eq
+
+instance Show Statement
+ where
+ show EmptyStatement = ";"
+ {-show (AssignmentStatement lhs rhs) =
+ concat [show lhs, " := ", show rhs, ";"]
+ show (IfStatement condition if' else') = concat
+ [ "if (", show condition, ") "
+ , show if'
+ , maybe "" ((<> " else ") . show) else'
+ ]
+ show (WhileStatement expression statement) =
+ concat ["while (", show expression, ") ", show statement, ";"]
+ show (CompoundStatement statements) =
+ concat ["{\n", unlines (show <$> statements), " }"]-}
+ show (CallStatement name parameters) = show name <> "("
+ <> intercalate ", " (show <$> parameters) <> ")"
+
+data VariableDeclaration =
+ VariableDeclaration Identifier TypeExpression
+ deriving Eq
+
+newtype Literal
+ = IntegerLiteral Int32
+ {- | HexadecimalLiteral Int32
+ | CharacterLiteral Word16
+ | BooleanLiteral Bool -}
+ deriving Eq
+
+instance Show Literal
+ where
+ show (IntegerLiteral integer) = show integer
+ {- show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
+ show (CharacterLiteral character) =
+ '\'' : chr (fromEnum character) : ['\'']
+ show (BooleanLiteral boolean)
+ | boolean = "true"
+ | otherwise = "false" -}
+
+instance Show VariableDeclaration
+ where
+ show (VariableDeclaration identifier typeExpression) =
+ concat ["var ", show identifier, ": " <> show typeExpression, ";"]
+
+data Expression
+ = LiteralExpression Literal
+ | SumExpression Expression Expression
+ | SubtractionExpression Expression Expression
+ | NegationExpression Expression
+{- | VariableExpression VariableAccess
+ | ProductExpression Expression Expression
+ | DivisionExpression Expression Expression -}
+ deriving Eq
+
+instance Show Expression
+ where
+ show (LiteralExpression literal) = show literal
+ show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs]
+ show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs]
+ show (NegationExpression negation) = '-' : show negation
+ {- show (VariableExpression variable) = show variable
+ show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
+ show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs] -}
+{-
+import Data.Char (chr)
+import Numeric (showHex)
+
+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 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]
+-}
diff --git a/lib/Language/Elna/Frontend/NameAnalysis.hs b/lib/Language/Elna/Frontend/NameAnalysis.hs
new file mode 100644
index 0000000..2915331
--- /dev/null
+++ b/lib/Language/Elna/Frontend/NameAnalysis.hs
@@ -0,0 +1,216 @@
+module Language.Elna.Frontend.NameAnalysis
+ ( nameAnalysis
+ , Error(..)
+ ) where
+
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Vector as Vector
+import qualified Language.Elna.Frontend.AST as AST
+import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
+import Language.Elna.Frontend.SymbolTable
+ ( SymbolTable
+ , Info(..)
+ , ParameterInfo(..)
+ )
+import Control.Monad.Trans.Except (Except, runExcept, throwE)
+import Data.Functor ((<&>))
+import Language.Elna.Location (Identifier(..))
+import Language.Elna.Frontend.Types (Type(..))
+import Data.Foldable (traverse_)
+import Control.Monad (foldM, unless)
+
+data Error
+ = UndefinedTypeError Identifier
+ | UnexpectedTypeInfoError Info
+ | IdentifierAlreadyDefinedError Identifier
+ | UndefinedSymbolError Identifier
+ | UnexpectedArrayByValue Identifier
+ deriving Eq
+
+instance Show Error
+ where
+ show (UndefinedTypeError identifier) =
+ concat ["Type \"", show identifier, "\" is not defined"]
+ show (UnexpectedTypeInfoError info) = show info
+ <> " expected to be a type"
+ show (IdentifierAlreadyDefinedError identifier) =
+ concat ["The identifier \"", show identifier, "\" is already defined"]
+ show (UndefinedSymbolError identifier) =
+ concat ["Symbol \"", show identifier, "\" is not defined"]
+ show (UnexpectedArrayByValue identifier) = concat
+ [ "Array \""
+ , show identifier
+ , "\" cannot be passed by value, only by reference"
+ ]
+
+newtype NameAnalysis a = NameAnalysis
+ { runNameAnalysis :: Except Error a
+ }
+
+instance Functor NameAnalysis
+ where
+ fmap f (NameAnalysis x) = NameAnalysis $ f <$> x
+
+instance Applicative NameAnalysis
+ where
+ pure = NameAnalysis . pure
+ (NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x
+
+instance Monad NameAnalysis
+ where
+ (NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
+
+nameAnalysis :: AST.Program -> Either Error SymbolTable
+nameAnalysis = runExcept
+ . runNameAnalysis
+ . program SymbolTable.builtInSymbolTable
+
+program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable
+program symbolTable (AST.Program declarations) = do
+ globalTable <- foldM procedureDeclaration symbolTable declarations
+ foldM declaration globalTable declarations
+
+procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
+procedureDeclaration globalTable (AST.ProcedureDeclaration identifier parameters _ _) = do
+ parametersInfo <- mapM (parameter globalTable) parameters
+ let procedureInfo = ProcedureInfo SymbolTable.empty
+ $ Vector.fromList parametersInfo
+ maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure
+ $ SymbolTable.enter identifier procedureInfo globalTable
+
+declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
+declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do
+ variableInfo <- mapM (variableDeclaration globalTable) variables
+ parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters
+ procedureTable <- fmap (SymbolTable.scope globalTable)
+ $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure
+ $ SymbolTable.fromList
+ $ parameterInfo <> variableInfo
+ traverse_ (statement procedureTable) body
+ pure $ SymbolTable.update (updater procedureTable) identifier globalTable
+ where
+ updater procedureTable (ProcedureInfo _ parameters') = Just
+ $ ProcedureInfo procedureTable parameters'
+ updater _ _ = Nothing
+
+parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info)
+parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter')
+ = (identifier,) . VariableInfo isReferenceParameter'
+ <$> dataType symbolTable typeExpression
+
+variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
+variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression)
+ = (identifier,) . VariableInfo False
+ <$> dataType globalTable typeExpression
+
+parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo
+parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do
+ parameterType <- dataType environmentSymbolTable typeExpression
+ case parameterType of
+ ArrayType _ _
+ | not isReferenceParameter' -> NameAnalysis
+ $ throwE $ UnexpectedArrayByValue identifier
+ _ ->
+ let parameterInfo = ParameterInfo
+ { name = identifier
+ , type' = parameterType
+ , isReferenceParameter = isReferenceParameter'
+ }
+ in pure parameterInfo
+
+dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type
+dataType environmentSymbolTable (AST.NamedType baseType) = do
+ case SymbolTable.lookup baseType environmentSymbolTable of
+ Just baseInfo
+ | TypeInfo baseType' <- baseInfo -> pure baseType'
+ | otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
+ _ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
+dataType environmentSymbolTable (AST.ArrayType arraySize baseType) =
+ dataType environmentSymbolTable baseType <&> ArrayType arraySize
+
+checkSymbol :: SymbolTable -> Identifier -> NameAnalysis ()
+checkSymbol globalTable identifier
+ = unless (SymbolTable.member identifier globalTable)
+ $ NameAnalysis $ throwE
+ $ UndefinedSymbolError identifier
+
+expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
+expression _ (AST.LiteralExpression _) = pure ()
+expression globalTable (AST.SumExpression lhs rhs)
+ = expression globalTable lhs
+ >> expression globalTable rhs
+expression globalTable (AST.SubtractionExpression lhs rhs)
+ = expression globalTable lhs
+ >> expression globalTable rhs
+expression globalTable (AST.NegationExpression negation) =
+ expression globalTable negation
+{- expression globalTable (AST.VariableExpression variableExpression) =
+ variableAccess globalTable variableExpression
+expression globalTable (AST.ProductExpression lhs rhs)
+ = expression globalTable lhs
+ >> expression globalTable rhs
+expression globalTable (AST.DivisionExpression lhs rhs)
+ = expression globalTable lhs
+ >> expression globalTable rhs
+-}
+statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
+statement _ AST.EmptyStatement = pure ()
+statement globalTable (AST.CallStatement name arguments)
+ = checkSymbol globalTable name
+ >> traverse_ (expression globalTable) arguments
+{- statement globalTable (AST.AssignmentStatement lvalue rvalue)
+ = variableAccess globalTable lvalue
+ >> expression globalTable rvalue
+statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
+ = condition globalTable ifCondition
+ >> statement globalTable ifStatement
+ >> maybe (pure ()) (statement globalTable) elseStatement
+statement globalTable (AST.WhileStatement whileCondition loop)
+ = condition globalTable whileCondition
+ >> statement globalTable loop
+statement globalTable (AST.CompoundStatement statements) =
+ traverse_ (statement globalTable) statements
+
+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
+ = maybe (identifierAlreadyDefinedError identifier) pure
+ $ SymbolTable.enter identifier info table
+
+identifierAlreadyDefinedError :: Identifier -> NameAnalysis a
+identifierAlreadyDefinedError = NameAnalysis
+ . lift
+ . throwE
+ . IdentifierAlreadyDefinedError
+
+variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
+variableDeclaration (AST.VariableDeclaration identifier typeExpression)
+ = (identifier,) . VariableInfo False
+ <$> dataType typeExpression
+-}
diff --git a/lib/Language/Elna/Frontend/Parser.hs b/lib/Language/Elna/Frontend/Parser.hs
new file mode 100644
index 0000000..4093f25
--- /dev/null
+++ b/lib/Language/Elna/Frontend/Parser.hs
@@ -0,0 +1,223 @@
+module Language.Elna.Frontend.Parser
+ ( Parser
+ , programP
+ ) where
+
+import Control.Monad (void)
+import Control.Monad.Combinators.Expr (Operator(..), makeExprParser)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Void (Void)
+import Language.Elna.Frontend.AST
+ ( Declaration(..)
+ , Identifier(..)
+ , Parameter(..)
+ , Program(..)
+ , Statement(..)
+ , TypeExpression(..)
+ , VariableDeclaration(..)
+ {-, VariableAccess(..)
+ , Condition(..)-}
+ , Expression(..)
+ , Literal(..)
+ )
+import Text.Megaparsec
+ ( Parsec
+ , (<?>)
+ , MonadParsec(..)
+ , eof
+ , optional
+ , between
+ , sepBy
+ , choice
+ )
+import qualified Text.Megaparsec.Char.Lexer as Lexer
+import Text.Megaparsec.Char
+ ( alphaNumChar
+-- , char
+ , letterChar
+ , space1
+-- , string
+ )
+import Control.Applicative (Alternative(..))
+import Data.Maybe (isJust)
+-- import Data.Functor (($>))
+
+type Parser = Parsec Void Text
+
+literalP :: Parser Literal
+literalP
+ = {- HexadecimalLiteral <$> (string "0x" *> lexeme Lexer.hexadecimal)
+ <|> -} IntegerLiteral <$> Lexer.signed space integerP
+ {- <|> CharacterLiteral <$> lexeme charP
+ <|> BooleanLiteral <$> (symbol "true" $> True)
+ <|> BooleanLiteral <$> (symbol "false" $> False)
+ where
+ charP = fromIntegral . fromEnum
+ <$> between (char '\'') (char '\'') Lexer.charLiteral -}
+{-
+typeDefinitionP :: Parser Declaration
+typeDefinitionP = TypeDefinition
+ <$> (symbol "type" *> identifierP)
+ <*> (symbol "=" *> typeExpressionP)
+ <* semicolonP
+ <?> "type definition"
+-}
+termP :: Parser Expression
+termP = choice
+ [ parensP expressionP
+ , LiteralExpression <$> literalP
+ -- , VariableExpression <$> variableAccessP
+ ]
+
+operatorTable :: [[Operator Parser Expression]]
+operatorTable =
+ [ unaryOperator
+ -- , factorOperator
+ , termOperator
+ ]
+ where
+ unaryOperator =
+ [ prefix "-" NegationExpression
+ , prefix "+" id
+ ]
+ {- factorOperator =
+ [ binary "*" ProductExpression
+ , binary "/" DivisionExpression
+ ] -}
+ termOperator =
+ [ binary "+" SumExpression
+ , binary "-" SubtractionExpression
+ ]
+ prefix name f = Prefix (f <$ symbol name)
+ binary name f = InfixL (f <$ symbol name)
+
+expressionP :: Parser Expression
+expressionP = makeExprParser termP operatorTable
+{-
+variableAccessP :: Parser VariableAccess
+variableAccessP = do
+ identifier <- identifierP
+ indices <- many $ bracketsP expressionP
+ pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices
+
+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
+ ]
+-}
+symbol :: Text -> Parser Text
+symbol = Lexer.symbol space
+
+space :: Parser ()
+space = Lexer.space space1 (Lexer.skipLineComment "//")
+ $ Lexer.skipBlockComment "/*" "*/"
+
+lexeme :: forall a. Parser a -> Parser a
+lexeme = Lexer.lexeme space
+
+blockP :: forall a. Parser a -> Parser a
+blockP = between (symbol "{") (symbol "}")
+
+parensP :: forall a. Parser a -> Parser a
+parensP = between (symbol "(") (symbol ")")
+
+bracketsP :: forall a. Parser a -> Parser a
+bracketsP = between (symbol "[") (symbol "]")
+
+colonP :: Parser ()
+colonP = void $ symbol ":"
+
+commaP :: Parser ()
+commaP = void $ symbol ","
+
+semicolonP :: Parser ()
+semicolonP = void $ symbol ";"
+
+integerP :: Integral a => Parser a
+integerP = lexeme Lexer.decimal
+
+identifierP :: Parser Identifier
+identifierP =
+ let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier"
+ in fmap Identifier $ lexeme $ Text.pack <$> wordParser
+
+procedureP :: Parser ()
+procedureP = void $ symbol "proc"
+
+parameterP :: Parser Parameter
+parameterP = paramCons
+ <$> optional (symbol "ref")
+ <*> identifierP
+ <*> (colonP *> typeExpressionP)
+ where
+ paramCons ref name typeName = Parameter name typeName (isJust ref)
+
+typeExpressionP :: Parser TypeExpression
+typeExpressionP = arrayTypeExpression
+ <|> NamedType <$> identifierP
+ <?> "type expression"
+ where
+ arrayTypeExpression = ArrayType
+ <$> (symbol "array" *> bracketsP integerP)
+ <*> (symbol "of" *> typeExpressionP)
+
+procedureDeclarationP :: Parser Declaration
+procedureDeclarationP = procedureCons
+ <$> (procedureP *> identifierP)
+ <*> parensP (sepBy parameterP commaP)
+ <*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
+ <?> "procedure definition"
+ where
+ procedureCons procedureName parameters (variables, body) =
+ ProcedureDeclaration procedureName parameters variables body
+
+statementP :: Parser Statement
+statementP
+ = EmptyStatement <$ semicolonP
+ {-<|> CompoundStatement <$> blockP (many statementP)
+ <|> try assignmentP
+ <|> try ifElseP
+ <|> try whileP -}
+ <|> try callP
+ <?> "statement"
+ where
+ callP = CallStatement
+ <$> identifierP
+ <*> parensP (sepBy expressionP commaP)
+ <* semicolonP
+ {-ifElseP = IfStatement
+ <$> (symbol "if" *> parensP conditionP)
+ <*> statementP
+ <*> optional (symbol "else" *> statementP)
+ whileP = WhileStatement
+ <$> (symbol "while" *> parensP conditionP)
+ <*> statementP
+ assignmentP = AssignmentStatement
+ <$> variableAccessP
+ <* symbol ":="
+ <*> expressionP
+ <* semicolonP -}
+
+variableDeclarationP :: Parser VariableDeclaration
+variableDeclarationP = VariableDeclaration
+ <$> (symbol "var" *> identifierP)
+ <*> (colonP *> typeExpressionP)
+ <* semicolonP
+ <?> "variable declaration"
+
+declarationP :: Parser Declaration
+declarationP = procedureDeclarationP -- <|> typeDefinitionP
+
+programP :: Parser Program
+programP = Program <$> many declarationP <* eof
diff --git a/lib/Language/Elna/Frontend/SymbolTable.hs b/lib/Language/Elna/Frontend/SymbolTable.hs
new file mode 100644
index 0000000..9ace33f
--- /dev/null
+++ b/lib/Language/Elna/Frontend/SymbolTable.hs
@@ -0,0 +1,88 @@
+module Language.Elna.Frontend.SymbolTable
+ ( SymbolTable
+ , Info(..)
+ , ParameterInfo(..)
+ , builtInSymbolTable
+ , empty
+ , enter
+ , fromList
+ , lookup
+ , member
+ , scope
+ , toMap
+ , update
+ ) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.List (sort)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (isJust)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Language.Elna.Location (Identifier(..))
+import Language.Elna.Frontend.Types (Type(..), intType)
+import Prelude hiding (lookup)
+
+data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
+ deriving (Eq, Show)
+
+empty :: SymbolTable
+empty = SymbolTable Nothing HashMap.empty
+
+update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable
+update updater key (SymbolTable parent mappings) = SymbolTable parent
+ $ HashMap.update updater key mappings
+
+scope :: SymbolTable -> SymbolTable -> SymbolTable
+scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings
+
+builtInSymbolTable :: SymbolTable
+builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList
+ [ ("printi", ProcedureInfo empty Vector.empty)
+ , ("int", TypeInfo intType)
+ ]
+
+toMap :: SymbolTable -> HashMap Identifier Info
+toMap (SymbolTable _ map') = map'
+
+enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable
+enter identifier info table@(SymbolTable parent hashTable)
+ | member identifier table = Nothing
+ | otherwise = Just
+ $ SymbolTable parent (HashMap.insert identifier info hashTable)
+
+lookup :: Identifier -> SymbolTable -> Maybe Info
+lookup identifier (SymbolTable parent table)
+ | Just found <- HashMap.lookup identifier table = Just found
+ | Just parent' <- parent = lookup identifier parent'
+ | otherwise = Nothing
+
+member :: Identifier -> SymbolTable -> Bool
+member identifier table =
+ isJust $ lookup identifier table
+
+fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
+fromList elements
+ | Just identifierDuplicates' <- identifierDuplicates =
+ Left identifierDuplicates'
+ | otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements
+ where
+ identifierDuplicates = NonEmpty.nonEmpty
+ $ fmap NonEmpty.head
+ $ filter ((> 1) . NonEmpty.length)
+ $ NonEmpty.group . sort
+ $ fst <$> elements
+
+data ParameterInfo = ParameterInfo
+ { name :: Identifier
+ , type' :: Type
+ , isReferenceParameter :: Bool
+ } deriving (Eq, Show)
+
+data Info
+ = TypeInfo Type
+ | VariableInfo Bool Type
+ | ProcedureInfo SymbolTable (Vector ParameterInfo)
+ deriving (Eq, Show)
diff --git a/lib/Language/Elna/Frontend/TypeAnalysis.hs b/lib/Language/Elna/Frontend/TypeAnalysis.hs
new file mode 100644
index 0000000..7d0b050
--- /dev/null
+++ b/lib/Language/Elna/Frontend/TypeAnalysis.hs
@@ -0,0 +1,186 @@
+module Language.Elna.Frontend.TypeAnalysis
+ ( typeAnalysis
+ , -- Error(..)
+ ) where
+
+import qualified Language.Elna.Frontend.AST as AST
+import Language.Elna.Frontend.SymbolTable ({-Info(..), ParameterInfo(..), -}SymbolTable)
+
+typeAnalysis :: SymbolTable -> AST.Program -> () -- Maybe Error
+typeAnalysis _globalTable = const () {- either Just (const Nothing)
+ . runExcept
+ . flip runReaderT globalTable
+ . runTypeAnalysis
+ . program -}
+
+{-
+import Control.Applicative (Alternative(..))
+import Control.Monad.Trans.Except (Except, runExcept, throwE)
+import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT, withReaderT, ask)
+import qualified Data.Vector as Vector
+import Language.Elna.Location (Identifier(..))
+import qualified Language.Elna.SymbolTable as SymbolTable
+import Language.Elna.Types (Type(..), booleanType, intType)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad (unless, when)
+import Data.Foldable (traverse_)
+
+data Error
+ = ArithmeticExpressionError Type
+ | ComparisonExpressionError Type Type
+ | UnexpectedVariableInfoError Info
+ | UnexpectedProcedureInfoError Info
+ | UndefinedSymbolError Identifier
+ | InvalidConditionTypeError Type
+ | InvalidAssignmentError Type
+ | ExpectedLvalueError AST.Expression
+ | ParameterCountMismatchError Int Int
+ | ArgumentTypeMismatchError Type Type
+ | ArrayIndexError Type
+ | ArrayAccessError Type
+ deriving (Eq, Show)
+
+newtype TypeAnalysis a = TypeAnalysis
+ { runTypeAnalysis :: ReaderT SymbolTable (Except Error) a
+ }
+
+instance Functor TypeAnalysis
+ where
+ fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x
+
+instance Applicative TypeAnalysis
+ where
+ pure = TypeAnalysis . pure
+ (TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x
+
+instance Monad TypeAnalysis
+ where
+ (TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f)
+
+program :: AST.Program -> TypeAnalysis ()
+program (AST.Program declarations) = traverse_ declaration declarations
+
+declaration :: AST.Declaration -> TypeAnalysis ()
+declaration (AST.ProcedureDefinition procedureName _ _ body) = do
+ globalTable <- TypeAnalysis ask
+ case SymbolTable.lookup procedureName globalTable of
+ Just (ProcedureInfo localTable _) -> TypeAnalysis
+ $ withReaderT (const localTable)
+ $ runTypeAnalysis
+ $ traverse_ (statement globalTable) body
+ Just anotherInfo -> TypeAnalysis $ lift $ throwE
+ $ UnexpectedProcedureInfoError anotherInfo
+ Nothing -> TypeAnalysis $ lift $ throwE
+ $ UndefinedSymbolError procedureName
+declaration _ = pure ()
+
+statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
+statement globalTable = \case
+ AST.EmptyStatement -> pure ()
+ AST.AssignmentStatement lhs rhs -> do
+ lhsType <- variableAccess globalTable lhs
+ rhsType <- expression globalTable rhs
+ unless (lhsType == intType)
+ $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
+ unless (rhsType == intType)
+ $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
+ 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 whileCondition whileStatement -> do
+ conditionType <- condition globalTable whileCondition
+ unless (conditionType == booleanType)
+ $ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
+ statement globalTable whileStatement
+ AST.CompoundStatement statements -> traverse_ (statement globalTable) statements
+ AST.CallStatement procedureName arguments ->
+ case SymbolTable.lookup procedureName globalTable of
+ Just (ProcedureInfo _ parameters)
+ | parametersLength <- Vector.length parameters
+ , argumentsLength <- length arguments
+ , Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE
+ $ ParameterCountMismatchError parametersLength argumentsLength
+ | otherwise -> traverse_ (uncurry checkArgument)
+ $ Vector.zip parameters (Vector.fromList arguments)
+ Just anotherInfo -> TypeAnalysis $ lift $ throwE
+ $ UnexpectedVariableInfoError anotherInfo
+ Nothing -> TypeAnalysis $ lift $ throwE
+ $ UndefinedSymbolError procedureName
+ where
+ checkArgument ParameterInfo{..} argument = do
+ argumentType <- expression globalTable argument
+ unless (argumentType == type')
+ $ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
+ when (isReferenceParameter && not (isLvalue argument))
+ $ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument
+ 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 variableExpression -> do
+ variableAccess globalTable variableExpression
+ AST.LiteralExpression literal' -> literal literal'
+ AST.NegationExpression negation -> do
+ operandType <- expression globalTable negation
+ if operandType == intType
+ then pure intType
+ else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType
+ AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs
+ AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs
+ AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs
+ AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs
+ where
+ arithmeticExpression lhs rhs = do
+ lhsType <- expression globalTable lhs
+ unless (lhsType == intType)
+ $ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType
+ rhsType <- expression globalTable rhs
+ 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
+ then pure booleanType
+ else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType
+
+literal :: AST.Literal -> TypeAnalysis Type
+literal (AST.IntegerLiteral _) = pure intType
+literal (AST.HexadecimalLiteral _) = pure intType
+literal (AST.CharacterLiteral _) = pure intType
+literal (AST.BooleanLiteral _) = pure booleanType
+-}
diff --git a/lib/Language/Elna/Frontend/Types.hs b/lib/Language/Elna/Frontend/Types.hs
new file mode 100644
index 0000000..a3cc730
--- /dev/null
+++ b/lib/Language/Elna/Frontend/Types.hs
@@ -0,0 +1,29 @@
+module Language.Elna.Frontend.Types
+ ( Type(..)
+ , addressByteSize
+ , booleanType
+ , intType
+ ) where
+
+import Data.Text (Text)
+import Data.Word (Word32)
+import Language.Elna.Location (showArrayType)
+
+addressByteSize :: Int
+addressByteSize = 4
+
+data Type
+ = PrimitiveType Text Int
+ | ArrayType Word32 Type
+ deriving Eq
+
+instance Show Type
+ where
+ show (PrimitiveType typeName _) = show typeName
+ show (ArrayType elementCount typeName) = showArrayType elementCount typeName
+
+intType :: Type
+intType = PrimitiveType "int" 4
+
+booleanType :: Type
+booleanType = PrimitiveType "boolean" 1
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:29:40 +0000