module Language.Fortran.Vars.Union
( union
)
where
import qualified Data.Map as M
import Language.Fortran.AST ( Name )
import Language.Fortran.Vars.Types
( SymbolTableEntry(..)
, Location
, MemoryBlock(..)
, MemoryBlockName
, ProgramUnitModel
, StorageClass(..)
, SymbolTable
)
updateVal :: MemoryBlockName -> Int -> Name -> SymbolTable -> SymbolTable
updateVal :: Name -> Offset -> Name -> SymbolTable -> SymbolTable
updateVal Name
blockName Offset
diff Name
symbol SymbolTable
symt = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
Just (SVariable Type
ty (Name
_, Offset
offset)) ->
let entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable Type
ty (Name
blockName, Offset
offset forall a. Num a => a -> a -> a
+ Offset
diff)
in forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
Just SymbolTableEntry
_ -> forall a. HasCallStack => Name -> a
error (Name
symbol forall a. [a] -> [a] -> [a]
++ Name
"is not a variable.")
Maybe SymbolTableEntry
Nothing -> SymbolTable
symt
mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass StorageClass
Unspecified StorageClass
c2 = StorageClass
c2
mergeStClass StorageClass
c1 StorageClass
Unspecified = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 | StorageClass
c1 forall a. Eq a => a -> a -> Bool
== StorageClass
c2 = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 =
forall a. HasCallStack => Name -> a
error (Name
"Try to merge StorageClass " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show StorageClass
c1 forall a. [a] -> [a] -> [a]
++ Name
" with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show StorageClass
c2)
union
:: ProgramUnitModel -> Location -> Location -> (ProgramUnitModel, Location)
union :: ProgramUnitModel
-> Location -> Location -> (ProgramUnitModel, Location)
union ProgramUnitModel
puModel Location
loc1 Location
loc2 | Location
loc1 forall a. Eq a => a -> a -> Bool
== Location
loc2 = (ProgramUnitModel
puModel, Location
loc1)
union (SymbolTable
symTable, StorageTable
storageTable) Location
location1 Location
location2 =
let (Name
blockName1, Offset
offset1) = Location
location1
(Name
blockName2, Offset
offset2) = Location
location2
Just MemoryBlock
block1 = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
blockName1 StorageTable
storageTable of
Just MemoryBlock
block -> forall a. a -> Maybe a
Just MemoryBlock
block
Maybe MemoryBlock
Nothing -> forall a. HasCallStack => Name -> a
error (Name
"Block doesn't exist: " forall a. [a] -> [a] -> [a]
++ Name
blockName1)
Just MemoryBlock
block2 = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
blockName2 StorageTable
storageTable of
Just MemoryBlock
block -> forall a. a -> Maybe a
Just MemoryBlock
block
Maybe MemoryBlock
Nothing -> forall a. HasCallStack => Name -> a
error (Name
"Block doesn't exist: " forall a. [a] -> [a] -> [a]
++ Name
blockName2)
in case forall a. Ord a => a -> a -> Ordering
compare Offset
offset1 Offset
offset2 of
Ordering
Prelude.GT -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
Ordering
Prelude.LT -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
Ordering
Prelude.EQ -> case (MemoryBlock -> StorageClass
storageClass MemoryBlock
block1, MemoryBlock -> StorageClass
storageClass MemoryBlock
block2) of
(StorageClass
Common, StorageClass
_ ) -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
(StorageClass
_ , StorageClass
Common) -> Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
(StorageClass, StorageClass)
_ -> if MemoryBlock -> Maybe Offset
blockSize MemoryBlock
block1 forall a. Ord a => a -> a -> Bool
>= MemoryBlock -> Maybe Offset
blockSize MemoryBlock
block2
then Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location1 Location
location2
else Location -> Location -> (ProgramUnitModel, Location)
mergeTo Location
location2 Location
location1
where
mergeTo :: Location -> Location -> (ProgramUnitModel, Location)
mergeTo :: Location -> Location -> (ProgramUnitModel, Location)
mergeTo toLocation :: Location
toLocation@(Name
toBlockName, Offset
toOffset) (Name
fromBlockName, Offset
fromOffset) =
let
diff :: Offset
diff = Offset
toOffset forall a. Num a => a -> a -> a
- Offset
fromOffset
Just MemoryBlock
fromBlock = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fromBlockName StorageTable
storageTable
Just MemoryBlock
toBlock = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
toBlockName StorageTable
storageTable
newVarList :: [Name]
newVarList = MemoryBlock -> [Name]
variables MemoryBlock
toBlock forall a. [a] -> [a] -> [a]
++ MemoryBlock -> [Name]
variables MemoryBlock
fromBlock
newSize :: Maybe Offset
newSize = do
Offset
to <- MemoryBlock -> Maybe Offset
blockSize MemoryBlock
toBlock
Offset
from <- MemoryBlock -> Maybe Offset
blockSize MemoryBlock
fromBlock
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Offset
to (Offset
from forall a. Num a => a -> a -> a
+ Offset
diff)
newStClass :: StorageClass
newStClass = StorageClass -> StorageClass -> StorageClass
mergeStClass (MemoryBlock -> StorageClass
storageClass MemoryBlock
fromBlock) (MemoryBlock -> StorageClass
storageClass MemoryBlock
toBlock)
newBlock :: MemoryBlock
newBlock = MemoryBlock { blockSize :: Maybe Offset
blockSize = Maybe Offset
newSize
, storageClass :: StorageClass
storageClass = StorageClass
newStClass
, variables :: [Name]
variables = [Name]
newVarList
}
mbs :: StorageTable
mbs = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
toBlockName MemoryBlock
newBlock StorageTable
storageTable
mbs' :: StorageTable
mbs' = forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
fromBlockName StorageTable
mbs
symTable' :: SymbolTable
symTable' =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Offset -> Name -> SymbolTable -> SymbolTable
updateVal Name
toBlockName Offset
diff) SymbolTable
symTable (MemoryBlock -> [Name]
variables MemoryBlock
fromBlock)
in
((SymbolTable
symTable', StorageTable
mbs'), Location
toLocation)