Negate integral expressions
This commit is contained in:
270
lib/Language/Elna/Glue.hs
Normal file
270
lib/Language/Elna/Glue.hs
Normal file
@@ -0,0 +1,270 @@
|
||||
module Language.Elna.Glue
|
||||
( glue
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (State, get, modify', runState)
|
||||
import Data.Bifunctor (Bifunctor(..))
|
||||
import Data.Foldable (Foldable(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Word (Word32)
|
||||
import qualified Language.Elna.Frontend.AST as AST
|
||||
import Language.Elna.Backend.Intermediate (Operand(..), Quadruple(..), Variable(..))
|
||||
import Language.Elna.Frontend.SymbolTable (SymbolTable{-, Info(..) -})
|
||||
|
||||
newtype Glue a = Glue
|
||||
{ runGlue :: State Word32 a }
|
||||
|
||||
instance Functor Glue
|
||||
where
|
||||
fmap f (Glue x) = Glue $ f <$> x
|
||||
|
||||
instance Applicative Glue
|
||||
where
|
||||
pure = Glue . pure
|
||||
(Glue f) <*> (Glue x) = Glue $ f <*> x
|
||||
|
||||
instance Monad Glue
|
||||
where
|
||||
(Glue x) >>= f = Glue $ x >>= (runGlue . f)
|
||||
|
||||
glue :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable))
|
||||
glue globalTable
|
||||
= fst
|
||||
. flip runState 0
|
||||
. runGlue
|
||||
. program globalTable
|
||||
|
||||
program
|
||||
:: SymbolTable
|
||||
-> AST.Program
|
||||
-> Glue (HashMap AST.Identifier (Vector (Quadruple Variable)))
|
||||
program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes
|
||||
<$> traverse (declaration globalTable) declarations
|
||||
|
||||
declaration
|
||||
:: SymbolTable
|
||||
-> AST.Declaration
|
||||
-> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
|
||||
declaration globalTable (AST.ProcedureDeclaration procedureName _ _ statements)
|
||||
= Just
|
||||
. (procedureName,)
|
||||
. Vector.cons StartQuadruple
|
||||
. flip Vector.snoc StopQuadruple
|
||||
. fold
|
||||
<$> traverse (statement globalTable) statements
|
||||
-- declaration (AST.TypeDefinition _ _) accumulator = pure accumulator
|
||||
|
||||
statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable))
|
||||
statement _ AST.EmptyStatement = pure mempty
|
||||
statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
|
||||
visitedArguments <- traverse (expression localTable) arguments
|
||||
let (parameterStatements, argumentStatements)
|
||||
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
|
||||
$ unzip visitedArguments
|
||||
in pure
|
||||
$ Vector.snoc (argumentStatements <> parameterStatements)
|
||||
$ CallQuadruple callName
|
||||
$ fromIntegral
|
||||
$ Vector.length argumentStatements
|
||||
{- statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
|
||||
(rhsOperand, rhsStatements) <- expression localTable assignee
|
||||
let variableType' = variableType variableAccess' localTable
|
||||
accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
|
||||
pure $ rhsStatements <> case accessResult 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
|
||||
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
|
||||
(conditionStatements, jumpConstructor) <- condition localTable ifCondition
|
||||
ifLabel <- createLabel
|
||||
endLabel <- createLabel
|
||||
ifStatements <- statement localTable ifStatement
|
||||
possibleElseStatements <- traverse (statement localTable) elseStatement
|
||||
pure $ conditionStatements <> case possibleElseStatements 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) = do
|
||||
(conditionStatements, jumpConstructor) <- condition localTable whileCondition
|
||||
startLabel <- createLabel
|
||||
endLabel <- createLabel
|
||||
conditionLabel <- createLabel
|
||||
whileStatements <- statement localTable whileStatement
|
||||
pure $ Vector.fromList [LabelQuadruple conditionLabel]
|
||||
<> conditionStatements
|
||||
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
|
||||
<> whileStatements
|
||||
<> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
|
||||
statement localTable (AST.CompoundStatement statements) =
|
||||
fold <$> traverse (statement localTable) statements -}
|
||||
|
||||
createTemporary :: Glue Variable
|
||||
createTemporary = do
|
||||
currentCounter <- Glue get
|
||||
Glue $ modify' (+ 1)
|
||||
pure $ TempVariable currentCounter
|
||||
|
||||
{-
|
||||
import Language.Elna.Types (Type(..))
|
||||
import qualified Language.Elna.SymbolTable as SymbolTable
|
||||
import GHC.Records (HasField(..))
|
||||
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import qualified Data.Text.Lazy as Text.Lazy
|
||||
|
||||
newtype Label = Label Text
|
||||
deriving Eq
|
||||
|
||||
instance Show Label
|
||||
where
|
||||
show (Label label) = '.' : Text.unpack label
|
||||
|
||||
createLabel :: Glue Label
|
||||
createLabel = do
|
||||
currentCounter <- Glue $ gets labelCounter
|
||||
Glue $ modify' modifier
|
||||
pure
|
||||
$ Label
|
||||
$ Text.Lazy.toStrict
|
||||
$ Text.Builder.toLazyText
|
||||
$ Text.Builder.decimal currentCounter
|
||||
where
|
||||
modifier generator = generator
|
||||
{ labelCounter = getField @"labelCounter" generator + 1
|
||||
}
|
||||
|
||||
condition
|
||||
:: SymbolTable
|
||||
-> AST.Condition
|
||||
-> Glue (Vector Quadruple, Label -> Quadruple)
|
||||
condition localTable (AST.EqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, EqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.NonEqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, NonEqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.LessCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
|
||||
condition localTable (AST.GreaterCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, GreaterQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.LessOrEqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, LessOrEqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
pure
|
||||
( lhsStatements <> rhsStatements
|
||||
, GreaterOrEqualQuadruple lhsOperand rhsOperand
|
||||
)
|
||||
|
||||
variableAccess
|
||||
:: SymbolTable
|
||||
-> AST.VariableAccess
|
||||
-> Maybe Operand
|
||||
-> Type
|
||||
-> Vector Quadruple
|
||||
-> Glue (AST.Identifier, Maybe Operand, Vector Quadruple)
|
||||
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
|
||||
pure (identifier, accumulatedIndex, accumulatedStatements)
|
||||
variableAccess localTable (AST.ArrayAccess access1 index1) Nothing (ArrayType _ baseType) _ = do
|
||||
(indexPlace, statements) <- expression localTable index1
|
||||
variableAccess localTable access1 (Just indexPlace) baseType statements
|
||||
variableAccess localTable (AST.ArrayAccess arrayAccess' arrayIndex) (Just baseIndex) (ArrayType arraySize baseType) statements = do
|
||||
(indexPlace, statements') <- expression localTable arrayIndex
|
||||
resultVariable <- createTemporary
|
||||
let 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 -> Glue (Operand Variable, Vector (Quadruple Variable))
|
||||
expression localTable = \case
|
||||
(AST.LiteralExpression literal') -> pure (literal literal', mempty)
|
||||
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
|
||||
(AST.SubtractionExpression lhs rhs) ->
|
||||
binaryExpression SubtractionQuadruple lhs rhs
|
||||
(AST.NegationExpression negation) -> do
|
||||
(operand, statements) <- expression localTable negation
|
||||
tempVariable <- createTemporary
|
||||
let negationQuadruple = NegationQuadruple operand tempVariable
|
||||
pure
|
||||
( VariableOperand tempVariable
|
||||
, Vector.snoc statements negationQuadruple
|
||||
)
|
||||
{- (AST.VariableExpression variableExpression) -> do
|
||||
let variableType' = variableType variableExpression localTable
|
||||
variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
|
||||
case variableAccess' of
|
||||
(AST.Identifier identifier, Nothing, statements) ->
|
||||
pure (VariableOperand (Variable identifier), statements)
|
||||
(AST.Identifier identifier, Just operand, statements) -> do
|
||||
arrayAddress <- createTemporary
|
||||
let arrayStatement = ArrayQuadruple (Variable identifier) operand arrayAddress
|
||||
pure
|
||||
( VariableOperand arrayAddress
|
||||
, Vector.snoc statements arrayStatement
|
||||
)
|
||||
(AST.ProductExpression lhs rhs) ->
|
||||
binaryExpression ProductQuadruple lhs rhs
|
||||
(AST.DivisionExpression lhs rhs) ->
|
||||
binaryExpression DivisionQuadruple lhs rhs -}
|
||||
where
|
||||
binaryExpression f lhs rhs = do
|
||||
(lhsOperand, lhsStatements) <- expression localTable lhs
|
||||
(rhsOperand, rhsStatements) <- expression localTable rhs
|
||||
tempVariable <- createTemporary
|
||||
let newQuadruple = f lhsOperand rhsOperand tempVariable
|
||||
pure
|
||||
( VariableOperand tempVariable
|
||||
, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
|
||||
)
|
||||
|
||||
literal :: AST.Literal -> Operand Variable
|
||||
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 -}
|
||||
Reference in New Issue
Block a user