module Language.Fortran.Vars.CommonLayout ( getCommonLayout , getFlagType ) where import qualified Data.Map as M import Language.Fortran.AST ( Name ) import Language.Fortran.Vars.Types ( SymbolTableEntry(..) , MemoryBlock(..) , ProgramUnitModel , StorageClass(..) , Offset , Type , SemType(..) , CharacterLen(..) ) data FlagType = Default | AlignCommons | NoAlignCommons getFlagType :: String -> FlagType getFlagType :: String -> FlagType getFlagType String "" = FlagType Default getFlagType String "falign-commons" = FlagType AlignCommons getFlagType String "fno-align-commons" = FlagType NoAlignCommons getFlagType String _ = FlagType Default getCommonLayout :: ProgramUnitModel -> String -> FlagType -> [(Name, Offset, Type)] getCommonLayout :: ProgramUnitModel -> String -> FlagType -> [(String, Offset, Type)] getCommonLayout (SymbolTable symbolTable, StorageTable storageTable) String commonArea FlagType flagOptions = [(String, Offset, Type)] -> [(String, Offset, Type)] forall {a}. [(a, Offset, Type)] -> [(a, Offset, Type)] generateOffset [(String, Offset, Type)] annotatedVariables where annotatedVariables :: [(String, Offset, Type)] annotatedVariables = (String -> (String, Offset, Type)) -> [String] -> [(String, Offset, Type)] forall a b. (a -> b) -> [a] -> [b] map (\String x -> (String x, String -> Offset getOffset String x, String -> Type getType String x)) (String -> [String] getVariables String commonArea) generateOffset :: [(a, Offset, Type)] -> [(a, Offset, Type)] generateOffset [(a, Offset, Type)] list = case FlagType flagOptions of FlagType Default -> [(a, Offset, Type)] list FlagType NoAlignCommons -> [(a, Offset, Type)] list FlagType AlignCommons -> [(a, Offset, Type)] -> Offset -> [(a, Offset, Type)] forall {a}. [(a, Offset, Type)] -> Offset -> [(a, Offset, Type)] getPaddedOffset [(a, Offset, Type)] list Offset 0 getPaddedOffset :: [(a, Offset, Type)] -> Offset -> [(a, Offset, Type)] getPaddedOffset [] Offset _ = [] getPaddedOffset ((a name, Offset offset, Type variableType) : [(a, Offset, Type)] xs) Offset cumm = (a name, Offset offset Offset -> Offset -> Offset forall a. Num a => a -> a -> a + Offset newCumm, Type variableType) (a, Offset, Type) -> [(a, Offset, Type)] -> [(a, Offset, Type)] forall a. a -> [a] -> [a] : [(a, Offset, Type)] -> Offset -> [(a, Offset, Type)] getPaddedOffset [(a, Offset, Type)] xs Offset newCumm where newCumm :: Offset newCumm = if Offset diff Offset -> Offset -> Bool forall a. Ord a => a -> a -> Bool > Offset 0 then Offset cumm Offset -> Offset -> Offset forall a. Num a => a -> a -> a + Offset size Offset -> Offset -> Offset forall a. Num a => a -> a -> a - Offset diff else Offset cumm diff :: Offset diff = (Offset offset Offset -> Offset -> Offset forall a. Num a => a -> a -> a + Offset cumm) Offset -> Offset -> Offset forall a. Integral a => a -> a -> a `mod` Offset size size :: Offset size = Type -> Offset getSize Type variableType getSize :: Type -> Offset getSize Type variable = case Type variable of TInteger Offset size -> Offset size TReal Offset size -> Offset size TComplex Offset size -> Offset size TLogical Offset size -> Offset size TByte Offset size -> Offset size TCharacter (CharLenInt Offset i) Offset k -> Offset iOffset -> Offset -> Offset forall a. Num a => a -> a -> a *Offset k TCharacter CharacterLen _ Offset _ -> String -> Offset forall a. HasCallStack => String -> a error String "Cannot handle dynamic length TCharacter in common area" TArray Type innerType Maybe Dimensions _ -> Type -> Offset getSize Type innerType TCustom String _ -> String -> Offset forall a. HasCallStack => String -> a error String "Cannot handle TCustom in common area" getVariables :: String -> [String] getVariables String cmn = let cmnStorageName :: String cmnStorageName = String "/" String -> String -> String forall a. [a] -> [a] -> [a] ++ String cmn String -> String -> String forall a. [a] -> [a] -> [a] ++ String "/" in case String -> StorageTable -> Maybe MemoryBlock forall k a. Ord k => k -> Map k a -> Maybe a M.lookup String cmnStorageName StorageTable storageTable of Just MemoryBlock memoryBlock | MemoryBlock -> StorageClass storageClass MemoryBlock memoryBlock StorageClass -> StorageClass -> Bool forall a. Eq a => a -> a -> Bool == StorageClass Common -> MemoryBlock -> [String] variables MemoryBlock memoryBlock Maybe MemoryBlock _ -> [] getOffset :: String -> Offset getOffset String variableName = case String -> SymbolTable -> Maybe SymbolTableEntry forall k a. Ord k => k -> Map k a -> Maybe a M.lookup String variableName SymbolTable symbolTable of Just (SVariable Type _ (String _, Offset offset)) -> Offset offset Maybe SymbolTableEntry _ -> String -> Offset forall a. HasCallStack => String -> a error String "variable not found in symbolTable" getType :: String -> Type getType String variableName = case String -> SymbolTable -> Maybe SymbolTableEntry forall k a. Ord k => k -> Map k a -> Maybe a M.lookup String variableName SymbolTable symbolTable of Just (SVariable Type variableType (String, Offset) _) -> Type variableType Maybe SymbolTableEntry _ -> String -> Type forall a. HasCallStack => String -> a error String "variable not found in symbolTable"