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
|
module Language.Elna.Intermediate
( Label(..)
, Operand(..)
, Quadruple(..)
, Variable(..)
, intermediate
) where
import Data.Bifunctor (Bifunctor(..))
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Data.Word (Word32)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Language.Elna.AST as AST
import Language.Elna.Types (Type(..))
import Language.Elna.SymbolTable (SymbolTable, Info(..))
import qualified Language.Elna.SymbolTable as SymbolTable
data Operand
= VariableOperand Variable
| IntOperand Int32
deriving (Eq, Show)
newtype Label = Label Text
deriving (Eq, Show)
data Variable = Variable Text | TempVariable
deriving (Eq, Show)
data Quadruple
= StartQuadruple
| GoToQuadruple Label
| AssignQuadruple Operand Variable
| ArrayQuadruple Variable Operand Variable
| ArrayAssignQuadruple Operand Operand Variable
| AddQuadruple Operand Operand Variable
| SubtractionQuadruple Operand Operand Variable
| ProductQuadruple Operand Operand Variable
| DivisionQuadruple Operand Operand Variable
| NegationQuadruple Operand Variable
| EqualQuadruple Operand Operand Label
| NonEqualQuadruple Operand Operand Label
| LessQuadruple Operand Operand Label
| GreaterQuadruple Operand Operand Label
| LessOrEqualQuadruple Operand Operand Label
| GreaterOrEqualQuadruple Operand Operand Label
| LabelQuadruple Label
| ParameterQuadruple Operand
| CallQuadruple Variable Word32
| StopQuadruple
deriving (Eq, Show)
intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector Quadruple)
intermediate globalTable (AST.Program declarations) =
foldr go HashMap.empty declarations
where
go (AST.TypeDefinition _ _) accumulator = accumulator
go (AST.ProcedureDefinition procedureName _ _ statements) accumulator =
let translatedStatements
= Vector.cons StartQuadruple
$ flip Vector.snoc StopQuadruple
$ foldMap (statement globalTable) statements
in HashMap.insert procedureName translatedStatements accumulator
statement :: SymbolTable -> AST.Statement -> Vector Quadruple
statement _ AST.EmptyStatement = mempty
statement localTable (AST.AssignmentStatement variableAccess' assignee) =
let (rhsOperand, rhsStatements) = expression localTable assignee
variableType' = variableType variableAccess' localTable
lhsStatements = case variableAccess localTable variableAccess' Nothing variableType' mempty of
(AST.Identifier identifier, Just accumulatedIndex, accumulatedStatements) ->
Vector.snoc accumulatedStatements
$ ArrayAssignQuadruple rhsOperand accumulatedIndex
$ Variable identifier
(AST.Identifier identifier, Nothing, accumulatedStatements) ->
Vector.snoc accumulatedStatements
$ AssignQuadruple rhsOperand
$ Variable identifier
in rhsStatements <> lhsStatements
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) =
let (conditionStatements, jumpConstructor) = condition localTable ifCondition
ifStatements = statement localTable ifStatement
ifLabel = Label "L1"
endLabel = Label "L2"
in conditionStatements <> case statement localTable <$> elseStatement of
Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
<> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
statement localTable (AST.WhileStatement whileCondition whileStatement) =
let (conditionStatements, jumpConstructor) = condition localTable whileCondition
whileStatements = statement localTable whileStatement
startLabel = Label "L3"
endLabel = Label "L4"
conditionLabel = Label "L5"
in Vector.fromList [LabelQuadruple conditionLabel]
<> conditionStatements
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
<> whileStatements
<> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
statement localTable (AST.CallStatement (AST.Identifier callName) arguments) =
let (parameterStatements, argumentStatements)
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
$ unzip
$ expression localTable <$> arguments
in Vector.snoc (argumentStatements <> parameterStatements)
$ CallQuadruple (Variable callName)
$ fromIntegral
$ Vector.length argumentStatements
statement localTable (AST.CompoundStatement statements) =
foldMap (statement localTable) statements
condition :: SymbolTable -> AST.Condition -> (Vector Quadruple, Label -> Quadruple)
condition localTable (AST.EqualCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, EqualQuadruple lhsOperand rhsOperand)
condition localTable (AST.NonEqualCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, NonEqualQuadruple lhsOperand rhsOperand)
condition localTable (AST.LessCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
condition localTable (AST.GreaterCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, GreaterQuadruple lhsOperand rhsOperand)
condition localTable (AST.LessOrEqualCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, LessOrEqualQuadruple lhsOperand rhsOperand)
condition localTable (AST.GreaterOrEqualCondition lhs rhs) =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
in (lhsStatements <> rhsStatements, GreaterOrEqualQuadruple lhsOperand rhsOperand)
variableAccess
:: SymbolTable
-> AST.VariableAccess
-> Maybe Operand
-> Type
-> Vector Quadruple
-> (AST.Identifier, Maybe Operand, Vector Quadruple)
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
(identifier, accumulatedIndex, accumulatedStatements)
variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ =
let (indexPlace, statements) = expression localTable index1
in variableAccess localTable access1 (Just indexPlace) baseType statements
variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements =
let (indexPlace, statements') = expression localTable arrayIndex
resultVariable = TempVariable
resultOperand = VariableOperand resultVariable
indexCalculation = Vector.fromList
[ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
, AddQuadruple indexPlace resultOperand resultVariable
]
in variableAccess localTable arrayAccess' (Just resultOperand) baseType
$ statements <> indexCalculation <> statements'
variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
variableType :: AST.VariableAccess -> SymbolTable -> Type
variableType (AST.VariableAccess identifier) symbolTable
| Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
| otherwise = error "Undefined type."
variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
variableType arrayAccess' symbolTable
expression :: SymbolTable -> AST.Expression -> (Operand, Vector Quadruple)
expression localTable = \case
(AST.VariableExpression variableExpression) ->
let variableType' = variableType variableExpression localTable
in case variableAccess localTable variableExpression Nothing variableType' mempty of
(AST.Identifier identifier, Nothing, statements) ->
(VariableOperand (Variable identifier), statements)
(AST.Identifier identifier, Just operand, statements) ->
let arrayAddress = TempVariable
arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
in (VariableOperand arrayAddress, Vector.snoc statements arrayStatement)
(AST.LiteralExpression literal') -> (literal literal', mempty)
(AST.NegationExpression negation) ->
let (operand, statements) = expression localTable negation
tempVariable = TempVariable
negationQuadruple = NegationQuadruple operand tempVariable
in (VariableOperand tempVariable, Vector.snoc statements negationQuadruple)
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
(AST.SubtractionExpression lhs rhs) ->
binaryExpression SubtractionQuadruple lhs rhs
(AST.ProductExpression lhs rhs) ->
binaryExpression ProductQuadruple lhs rhs
(AST.DivisionExpression lhs rhs) ->
binaryExpression DivisionQuadruple lhs rhs
where
binaryExpression f lhs rhs =
let (lhsOperand, lhsStatements) = expression localTable lhs
(rhsOperand, rhsStatements) = expression localTable rhs
tempVariable = TempVariable
newQuadruple = f lhsOperand rhsOperand tempVariable
in (VariableOperand tempVariable, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple)
literal :: AST.Literal -> Operand
literal (AST.IntegerLiteral integer) = IntOperand integer
literal (AST.HexadecimalLiteral integer) = IntOperand integer
literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character
literal (AST.BooleanLiteral boolean)
| boolean = IntOperand 1
| otherwise = IntOperand 0
|
