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"