Collect function declaration symbols

2024-09-20 13:32:24 +02:00
parent c9ff4f0a2a
commit 0a8d3fce2f
4 changed files with 117 additions and 110 deletions
--- a/4
+++ b/4
@@ -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.
--- 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
+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
-            $ fmap parameterToVariableInfo parametersInfo
-            <> variableInfo
-        traverse_ (statement globalTable) body
-        let procedureInfo = ProcedureInfo newTable
-                $ Vector.fromList parametersInfo
-        enter identifier procedureInfo globalTable
+        $ 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
 -}
--- 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)
-}
--- 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