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 :: Name -> FlagType
getFlagType Name
""                  = FlagType
Default
getFlagType Name
"falign-commons"    = FlagType
AlignCommons
getFlagType Name
"fno-align-commons" = FlagType
NoAlignCommons
getFlagType Name
_                   = FlagType
Default

getCommonLayout
  :: ProgramUnitModel -> String -> FlagType -> [(Name, Offset, Type)]
getCommonLayout :: ProgramUnitModel -> Name -> FlagType -> [(Name, Offset, Type)]
getCommonLayout (SymbolTable
symbolTable, StorageTable
storageTable) Name
commonArea FlagType
flagOptions =
  [(Name, Offset, Type)] -> [(Name, Offset, Type)]
generateOffset [(Name, Offset, Type)]
annotatedVariables
 where
  annotatedVariables :: [(Name, Offset, Type)]
annotatedVariables =
    forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> (Name
x, Name -> Offset
getOffset Name
x, Name -> Type
getType Name
x)) (Name -> [Name]
getVariables Name
commonArea)
  generateOffset :: [(Name, Offset, Type)] -> [(Name, Offset, Type)]
generateOffset [(Name, Offset, Type)]
list = case FlagType
flagOptions of
    FlagType
Default        -> [(Name, Offset, Type)]
list
    FlagType
NoAlignCommons -> [(Name, Offset, Type)]
list
    FlagType
AlignCommons   -> forall {a}. [(a, Offset, Type)] -> Offset -> [(a, Offset, Type)]
getPaddedOffset [(Name, 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 forall a. Num a => a -> a -> a
+ Offset
newCumm, Type
variableType) 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 forall a. Ord a => a -> a -> Bool
> Offset
0 then Offset
cumm forall a. Num a => a -> a -> a
+ Offset
size forall a. Num a => a -> a -> a
- Offset
diff else Offset
cumm
    diff :: Offset
diff    = (Offset
offset forall a. Num a => a -> a -> a
+ Offset
cumm) 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
iforall a. Num a => a -> a -> a
*Offset
k
    TCharacter CharacterLen
_ Offset
_ ->
      forall a. HasCallStack => Name -> a
error Name
"Cannot handle dynamic length TCharacter in common area"
    TArray Type
innerType Dimensions
_ -> Type -> Offset
getSize Type
innerType
    TCustom Name
_          -> forall a. HasCallStack => Name -> a
error Name
"Cannot handle TCustom in common area"
  getVariables :: Name -> [Name]
getVariables Name
cmn =
    let cmnStorageName :: Name
cmnStorageName = Name
"/" forall a. [a] -> [a] -> [a]
++ Name
cmn forall a. [a] -> [a] -> [a]
++ Name
"/"
    in  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
cmnStorageName StorageTable
storageTable of
          Just MemoryBlock
memoryBlock | MemoryBlock -> StorageClass
storageClass MemoryBlock
memoryBlock forall a. Eq a => a -> a -> Bool
== StorageClass
Common ->
            MemoryBlock -> [Name]
variables MemoryBlock
memoryBlock
          Maybe MemoryBlock
_ -> []
  getOffset :: Name -> Offset
getOffset Name
variableName = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
variableName SymbolTable
symbolTable of
    Just (SVariable Type
_ (Name
_, Offset
offset)) -> Offset
offset
    Maybe SymbolTableEntry
_                              -> forall a. HasCallStack => Name -> a
error Name
"variable not found in symbolTable"
  getType :: Name -> Type
getType Name
variableName = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
variableName SymbolTable
symbolTable of
    Just (SVariable Type
variableType (Name, Offset)
_) -> Type
variableType
    Maybe SymbolTableEntry
_                               -> forall a. HasCallStack => Name -> a
error Name
"variable not found in symbolTable"