142 lines
6.1 KiB
Haskell
142 lines
6.1 KiB
Haskell
module Language.Elna.Intermediate
|
|
( Label(..)
|
|
, Operand(..)
|
|
, Quadruple(..)
|
|
, Variable(..)
|
|
, intermediate
|
|
) where
|
|
|
|
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 Word32 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 globalTable (AST.CompoundStatement statements) =
|
|
foldMap (statement globalTable) statements
|
|
|
|
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
|