Collect function declaration symbols

TODO

@@ -9,3 +9,9 @@
 - 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.
+- Name analyzer collects procedure names in the first run. Implement the second run,
+  where the analyzer goes into and checks procedures.

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(..)
-    --, Info(..)
+    , ParameterInfo(..)
-    -- , 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
+nameAnalysis :: AST.Program -> Either Error SymbolTable
-program (AST.Program declarations)
+nameAnalysis = runExcept
-    = NameAnalysis ask
+    . runNameAnalysis
-    >>= flip (foldM declaration) declarations
+    . 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)
+declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do
-    = withSymbolTable globalTable (dataType typeExpression)
+    variableInfo <- mapM (variableDeclaration globalTable) variables
-    >>= flip (enter identifier) globalTable . TypeInfo
+    parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters
-declaration globalTable (AST.ProcedureDefinition identifier parameters variables body) = do
+    procedureTable <- fmap (SymbolTable.scope globalTable)
-        parametersInfo <- mapM parameter parameters
+        $ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure
-        variableInfo <- mapM variableDeclaration variables
+        $ SymbolTable.fromList
-        newTable <- either (identifierAlreadyDefinedError . NonEmpty.head) pure
+        $ parameterInfo <> variableInfo
-            $ SymbolTable.fromList
+    traverse_ (statement procedureTable) body
-            $ fmap parameterToVariableInfo parametersInfo
+    pure $ SymbolTable.update (updater procedureTable) identifier globalTable
-            <> variableInfo
+  where
-        traverse_ (statement globalTable) body
+    updater procedureTable (ProcedureInfo _ parameters') = Just
-        let procedureInfo = ProcedureInfo newTable
+        $ ProcedureInfo procedureTable parameters'
-                $ Vector.fromList parametersInfo
+    updater _ _ = Nothing
-        enter identifier procedureInfo globalTable
+
+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
 -}

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
+data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
-  where
+    deriving (Eq, Show)
-    (SymbolTable lhs) <> (SymbolTable rhs) = SymbolTable $ rhs <> lhs
 
-instance Monoid SymbolTable
+empty :: SymbolTable
-  where
+empty = SymbolTable Nothing HashMap.empty
-    mempty = 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
+        $ SymbolTable parent (HashMap.insert identifier info hashTable)
-        $ 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)
--}

src/Main.hs

@@ -25,11 +25,13 @@ main  = execParser commandLine >>= withCommandLine
             >>= withParsedInput defaultOutput
             . runParser programP input
     withParsedInput output (Right program) =
-        let symbolTable = nameAnalysis program
+        either print (withSymbolTable output program)
-            _ = typeAnalysis symbolTable program
+            $ nameAnalysis program
-            intermediate' = intermediate symbolTable program
-         in elfObject output
-            $ riscv32Elf
-            $ generateCode symbolTable intermediate'
     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