summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--TODO4
-rw-r--r--lib/Language/Elna/NameAnalysis.hs156
-rw-r--r--lib/Language/Elna/SymbolTable.hs55
-rw-r--r--src/Main.hs14
4 files changed, 118 insertions, 111 deletions
diff --git a/TODO b/TODO
index 41aee95..a3dbb9e 100644
--- a/TODO
+++ b/TODO
@@ -9,3 +9,7 @@
- Don't ignore relocations where the symbol is not defined in the symbol table.
Report an error about an undefined symbol.
- Don't hardcode symbols in symbolEntry.
+
+# Name analysis
+
+- Format error messages.
diff --git a/lib/Language/Elna/NameAnalysis.hs b/lib/Language/Elna/NameAnalysis.hs
index 78b3ce4..0ef702d 100644
--- a/lib/Language/Elna/NameAnalysis.hs
+++ b/lib/Language/Elna/NameAnalysis.hs
@@ -1,39 +1,23 @@
module Language.Elna.NameAnalysis
( nameAnalysis
- -- , Error(..)
+ , Error(..)
) where
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Vector as Vector
+import qualified Language.Elna.SymbolTable as SymbolTable
import qualified Language.Elna.AST as AST
import Language.Elna.SymbolTable
( SymbolTable
- , empty
- --, Info(..)
- -- , ParameterInfo(..)
+ , Info(..)
+ , ParameterInfo(..)
)
-
-nameAnalysis :: AST.Program -> SymbolTable -- Either Error SymbolTable
-nameAnalysis = const empty {- runExcept
- . flip runReaderT builtInSymbolTable
- . runNameAnalysis
- . program -}
-{-
import Control.Monad.Trans.Except (Except, runExcept, throwE)
-import Control.Monad.Trans.Reader
- ( ReaderT(..)
- , ask
- , asks
- , runReaderT
- , withReaderT
- )
import Data.Functor ((<&>))
import Language.Elna.Location (Identifier(..))
-import qualified Language.Elna.SymbolTable as SymbolTable
import Language.Elna.Types (Type(..))
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad (foldM, unless)
-import qualified Data.List.NonEmpty as NonEmpty
import Data.Foldable (traverse_)
-import qualified Data.Vector as Vector
+import Control.Monad (foldM)
data Error
= UndefinedTypeError Identifier
@@ -44,7 +28,7 @@ data Error
deriving (Eq, Show)
newtype NameAnalysis a = NameAnalysis
- { runNameAnalysis :: ReaderT SymbolTable (Except Error) a
+ { runNameAnalysis :: Except Error a
}
instance Functor NameAnalysis
@@ -60,30 +44,77 @@ instance Monad NameAnalysis
where
(NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
-program :: AST.Program -> NameAnalysis SymbolTable
-program (AST.Program declarations)
- = NameAnalysis ask
- >>= flip (foldM declaration) declarations
-
+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.TypeDefinition identifier typeExpression)
- = withSymbolTable globalTable (dataType typeExpression)
- >>= flip (enter identifier) globalTable . TypeInfo
-declaration globalTable (AST.ProcedureDefinition identifier parameters variables body) = do
- parametersInfo <- mapM parameter parameters
- variableInfo <- mapM variableDeclaration variables
- newTable <- either (identifierAlreadyDefinedError . NonEmpty.head) pure
- $ SymbolTable.fromList
- $ fmap parameterToVariableInfo parametersInfo
- <> variableInfo
- traverse_ (statement globalTable) body
- let procedureInfo = ProcedureInfo newTable
- $ Vector.fromList parametersInfo
- enter identifier procedureInfo globalTable
+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
statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
statement _ AST.EmptyStatement = pure ()
-statement globalTable (AST.AssignmentStatement lvalue rvalue)
+{- statement globalTable (AST.AssignmentStatement lvalue rvalue)
= variableAccess globalTable lvalue
>> expression globalTable rvalue
statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
@@ -170,41 +201,4 @@ variableDeclaration :: AST.VariableDeclaration -> NameAnalysis (Identifier, Info
variableDeclaration (AST.VariableDeclaration identifier typeExpression)
= (identifier,) . VariableInfo False
<$> dataType typeExpression
-
-parameter :: AST.Parameter -> NameAnalysis ParameterInfo
-parameter (AST.Parameter identifier typeExpression isReferenceParameter') = do
- parameterType <- dataType typeExpression
- case parameterType of
- ArrayType _ _
- | not isReferenceParameter' -> NameAnalysis
- $ lift $ throwE $ UnexpectedArrayByValue identifier
- _ ->
- let parameterInfo = ParameterInfo
- { name = identifier
- , type' = parameterType
- , isReferenceParameter = isReferenceParameter'
- }
- in pure parameterInfo
-
-parameterToVariableInfo :: ParameterInfo -> (Identifier, Info)
-parameterToVariableInfo ParameterInfo{..} =
- ( name
- , VariableInfo isReferenceParameter type'
- )
-
-withSymbolTable :: forall a. SymbolTable -> NameAnalysis a -> NameAnalysis a
-withSymbolTable symbolTable' = NameAnalysis
- . withReaderT (const symbolTable')
- . runNameAnalysis
-
-dataType :: AST.TypeExpression -> NameAnalysis Type
-dataType (AST.NamedType baseType) = do
- environmentSymbolTable <- NameAnalysis ask
- case SymbolTable.lookup baseType environmentSymbolTable of
- Just baseInfo
- | TypeInfo baseType' <- baseInfo -> pure baseType'
- | otherwise -> NameAnalysis $ lift $ throwE $ UnexpectedTypeInfoError baseInfo
- _ -> NameAnalysis $ lift $ throwE $ UndefinedTypeError baseType
-dataType (AST.ArrayType arraySize baseType) =
- dataType baseType <&> ArrayType arraySize
-}
diff --git a/lib/Language/Elna/SymbolTable.hs b/lib/Language/Elna/SymbolTable.hs
index c8406fc..52b8542 100644
--- a/lib/Language/Elna/SymbolTable.hs
+++ b/lib/Language/Elna/SymbolTable.hs
@@ -1,64 +1,72 @@
module Language.Elna.SymbolTable
( SymbolTable
- , empty
- {-, Info(..)
+ , Info(..)
, ParameterInfo(..)
, builtInSymbolTable
+ , empty
, enter
, fromList
, lookup
- , member -}
+ , member
+ , scope
+ , toMap
+ , update
) where
-data SymbolTable = SymbolTable -- (HashMap Identifier Info)
- deriving (Eq, Show)
-
-empty :: SymbolTable
-empty = SymbolTable -- HashMap.empty
-
-{-
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 Language.Elna.Location (Identifier(..))
import Language.Elna.Types (Type(..), intType, booleanType)
import Prelude hiding (lookup)
-instance Semigroup SymbolTable
- where
- (SymbolTable lhs) <> (SymbolTable rhs) = SymbolTable $ rhs <> lhs
+data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
+ deriving (Eq, Show)
-instance Monoid SymbolTable
- where
- mempty = empty
+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 $ HashMap.fromList
+builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList
[ ("boolean", TypeInfo booleanType)
, ("int", TypeInfo intType)
]
+toMap :: SymbolTable -> HashMap Identifier Info
+toMap (SymbolTable _ map') = map'
+
enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable
-enter identifier info table@(SymbolTable hashTable)
+enter identifier info table@(SymbolTable parent hashTable)
| member identifier table = Nothing
| otherwise = Just
- $ SymbolTable
- $ HashMap.insert identifier info hashTable
+ $ SymbolTable parent (HashMap.insert identifier info hashTable)
lookup :: Identifier -> SymbolTable -> Maybe Info
-lookup identifier (SymbolTable table) = HashMap.lookup identifier table
+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 (SymbolTable table) = HashMap.member identifier table
+member identifier table =
+ isJust $ lookup identifier table
fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
fromList elements
| Just identifierDuplicates' <- identifierDuplicates =
Left identifierDuplicates'
- | otherwise = Right $ SymbolTable $ HashMap.fromList elements
+ | otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements
where
identifierDuplicates = NonEmpty.nonEmpty
$ fmap NonEmpty.head
@@ -77,4 +85,3 @@ data Info
| VariableInfo Bool Type
| ProcedureInfo SymbolTable (Vector ParameterInfo)
deriving (Eq, Show)
--}
diff --git a/src/Main.hs b/src/Main.hs
index 646d967..a993e98 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,11 +25,13 @@ main = execParser commandLine >>= withCommandLine
>>= withParsedInput defaultOutput
. runParser programP input
withParsedInput output (Right program) =
- let symbolTable = nameAnalysis program
- _ = typeAnalysis symbolTable program
- intermediate' = intermediate symbolTable program
- in elfObject output
- $ riscv32Elf
- $ generateCode symbolTable intermediate'
+ either print (withSymbolTable output program)
+ $ nameAnalysis program
withParsedInput _ (Left errorBundle) = putStrLn
$ errorBundlePretty errorBundle
+ withSymbolTable output program symbolTable =
+ let _ = typeAnalysis symbolTable program
+ intermediate' = intermediate symbolTable program
+ instructions = generateCode symbolTable intermediate'
+ in elfObject output
+ $ riscv32Elf instructions
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 20:37:26 +0000