From fdf56ce9d0de459dc5bd65537847ded7b02ad5c2 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 2 Oct 2024 22:56:15 +0200 Subject: Negate integral expressions --- lib/Language/Elna/Intermediate.hs | 311 -------------------------------------- 1 file changed, 311 deletions(-) delete mode 100644 lib/Language/Elna/Intermediate.hs (limited to 'lib/Language/Elna/Intermediate.hs') diff --git a/lib/Language/Elna/Intermediate.hs b/lib/Language/Elna/Intermediate.hs deleted file mode 100644 index 32c951e..0000000 --- a/lib/Language/Elna/Intermediate.hs +++ /dev/null @@ -1,311 +0,0 @@ -module Language.Elna.Intermediate - ( Operand(..) - , Quadruple(..) - {- , Label(..) -} - , Variable(..) - , intermediate - ) where - -import Data.Bifunctor (Bifunctor(..)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Data.Int (Int32) -import Data.Word (Word32) -import Data.Text (Text) -import qualified Language.Elna.AST as AST -import Language.Elna.SymbolTable (SymbolTable{-, Info(..) -}) -import Data.Foldable (Foldable(..)) -import Control.Monad.Trans.State (State, get, modify', runState) -import Data.Maybe (catMaybes) - -newtype Variable = TempVariable Word32 -- | Variable Text - deriving Eq - -instance Show Variable - where - -- show (Variable variable) = '$' : Text.unpack variable - show (TempVariable variable) = '$' : show variable - -data Operand v - = IntOperand Int32 - | VariableOperand v - deriving (Eq, Show) - -data Quadruple v - = StartQuadruple - | StopQuadruple - | ParameterQuadruple (Operand v) - | CallQuadruple Text Word32 - | AddQuadruple (Operand v) (Operand v) v - | SubtractionQuadruple (Operand v) (Operand v) v - {-| GoToQuadruple Label - | AssignQuadruple Operand Variable - | ArrayQuadruple Variable Operand Variable - | ArrayAssignQuadruple 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 -} - deriving (Eq, Show) - -newtype Intermediate a = Intermediate - { runIntermediate :: State Word32 a } - -instance Functor Intermediate - where - fmap f (Intermediate x) = Intermediate $ f <$> x - -instance Applicative Intermediate - where - pure = Intermediate . pure - (Intermediate f) <*> (Intermediate x) = Intermediate $ f <*> x - -instance Monad Intermediate - where - (Intermediate x) >>= f = Intermediate $ x >>= (runIntermediate . f) - -intermediate :: SymbolTable -> AST.Program -> HashMap AST.Identifier (Vector (Quadruple Variable)) -intermediate globalTable - = fst - . flip runState 0 - . runIntermediate - . program globalTable - -program - :: SymbolTable - -> AST.Program - -> Intermediate (HashMap AST.Identifier (Vector (Quadruple Variable))) -program globalTable (AST.Program declarations) = HashMap.fromList . catMaybes - <$> traverse (declaration globalTable) declarations - -declaration - :: SymbolTable - -> AST.Declaration - -> Intermediate (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 -> Intermediate (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 :: Intermediate Variable -createTemporary = do - currentCounter <- Intermediate get - Intermediate $ 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 :: Intermediate Label -createLabel = do - currentCounter <- Intermediate $ gets labelCounter - Intermediate $ 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 - -> Intermediate (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 - -> Intermediate (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 -> Intermediate (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.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.NegationExpression negation) -> do - (operand, statements) <- expression localTable negation - tempVariable <- createTemporary - let negationQuadruple = NegationQuadruple operand tempVariable - pure - ( VariableOperand tempVariable - , Vector.snoc statements negationQuadruple - ) - (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 -} -- cgit v1.2.3