1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
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.ProductExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.DivisionExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
{- expression globalTable (AST.VariableExpression variableExpression) =
variableAccess globalTable variableExpression
-}
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.CompoundStatement statements) =
traverse_ (statement globalTable) statements
{- 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
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
-}
|
