{-# LANGUAGE LambdaCase #-}
module Language.Fortran.Vars.SymbolTable
( collectSymbols
)
where
import Data.Data ( Data
, toConstr
)
import Data.List ( foldl' )
import qualified Data.Map as M
import Data.Maybe ( catMaybes )
import Language.Fortran.Analysis ( Analysis
, srcName
)
import Language.Fortran.AST ( AList
, Argument(..)
, aStrip
, BaseType(..)
, Block(..)
, CommonGroup(..)
, Declarator(..)
, DeclaratorType(..)
, DimensionDeclarator(..)
, Expression(..)
, Index(..)
, Name
, ProgramUnit(..)
, programUnitBody
, Statement(..)
, Selector(..)
, TypeSpec(..)
, Value(..)
)
import Language.Fortran.Vars.Eval
( eval
, eval'
)
import Language.Fortran.Vars.BozConstant
( resolveBozConstant )
import Language.Fortran.Vars.Types
( ExpVal(..)
, SymbolTableEntry(..)
, Type(..)
, SemType(..)
, CharacterLen(..)
, SymbolTable
)
import Language.Fortran.Vars.Utils
( typeSpecToScalarType
, typeSpecToArrayType
)
import Language.Fortran.Vars.Kind
( getKind
, getTypeKind
, setTypeKind
, getKindOfExpVal
, toInt
, typeOfExpVal
, baseToType
, isStr
)
resolveDimensionDimensionDeclarator
:: SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
resolveDimensionDimensionDeclarator :: forall a.
SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
resolveDimensionDimensionDeclarator SymbolTable
symTable (DimensionDeclarator Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
lowerbound Maybe (Expression (Analysis a))
upperbound)
= do
Int
lb <- Maybe (Expression (Analysis a)) -> Maybe Int
forall {a}. Maybe (Expression a) -> Maybe Int
valueOf Maybe (Expression (Analysis a))
lowerbound
Int
ub <- Maybe (Expression (Analysis a)) -> Maybe Int
forall {a}. Maybe (Expression a) -> Maybe Int
valueOf Maybe (Expression (Analysis a))
upperbound
(Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
lb, Int
ub)
where
valueOf :: Maybe (Expression a) -> Maybe Int
valueOf (Just (ExpValue a
_ SrcSpan
_ Value a
ValStar)) = Maybe Int
forall a. Maybe a
Nothing
valueOf (Just (ExpValue a
_ SrcSpan
_ (ValVariable Name
name))) =
case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name SymbolTable
symTable of
Just (SParameter Type
_ (Int Int
i)) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Maybe SymbolTableEntry
_ -> Maybe Int
forall a. Maybe a
Nothing
valueOf (Just Expression a
expr) = case SymbolTable -> Expression a -> Either Name ExpVal
forall a. SymbolTable -> Expression a -> Either Name ExpVal
eval' SymbolTable
symTable Expression a
expr of
Right (Int Int
i) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Either Name ExpVal
_ -> Maybe Int
forall a. Maybe a
Nothing
valueOf Maybe (Expression a)
Nothing = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
handleParameter
:: Data a => SymbolTable -> AList Declarator (Analysis a) -> SymbolTable
handleParameter :: forall a.
Data a =>
SymbolTable -> AList Declarator (Analysis a) -> SymbolTable
handleParameter SymbolTable
symTable AList Declarator (Analysis a)
alist = (SymbolTable -> Declarator (Analysis a) -> SymbolTable)
-> SymbolTable -> [Declarator (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Declarator (Analysis a) -> SymbolTable
forall {a}. SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symTable (AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
alist)
where
f :: SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symt (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
varExp DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
valExp)) =
let symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
val' :: ExpVal
val' = case SymbolTable -> Expression (Analysis a) -> ExpVal
forall a. SymbolTable -> Expression a -> ExpVal
eval SymbolTable
symt Expression (Analysis a)
valExp of
boz :: ExpVal
boz@(Boz Boz
_) -> SymbolTable -> Name -> ExpVal -> ExpVal
resolveBozConstant SymbolTable
symTable Name
symbol ExpVal
boz
ExpVal
v -> ExpVal
v
kind' :: Int
kind' = ExpVal -> Int
getKindOfExpVal ExpVal
val'
pd' :: SymbolTableEntry
pd' = Type -> ExpVal -> SymbolTableEntry
SParameter (Type -> Maybe Int -> Type
setTypeKind (ExpVal -> Type
typeOfExpVal ExpVal
val') (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
kind')) ExpVal
val'
entry :: SymbolTableEntry
entry = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
Maybe SymbolTableEntry
Nothing -> SymbolTableEntry
pd'
Just (SVariable Type
ty Location
_) -> case Type
ty of
TCharacter CharacterLen
CharLenStar Int
_ -> SymbolTableEntry
pd'
Type
_ -> Type -> ExpVal -> SymbolTableEntry
SParameter Type
ty ExpVal
val'
Just SDummy{} | ExpVal -> Bool
isStr ExpVal
val' -> SymbolTableEntry
pd'
Just SymbolTableEntry
_ ->
let errStr :: Name -> Name
errStr Name
t =
Name
"Invalid PARAMETER statement for symbol \'" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
t Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\'"
in Name -> SymbolTableEntry
forall a. HasCallStack => Name -> a
error (Name -> SymbolTableEntry) -> Name -> SymbolTableEntry
forall a b. (a -> b) -> a -> b
$ Name -> Name
errStr Name
symbol
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
f SymbolTable
symt Declarator (Analysis a)
_ = SymbolTable
symt
handleDeclaration
:: Data a
=> SymbolTable
-> TypeSpec (Analysis a)
-> AList Declarator (Analysis a)
-> SymbolTable
handleDeclaration :: forall a.
Data a =>
SymbolTable
-> TypeSpec (Analysis a)
-> AList Declarator (Analysis a)
-> SymbolTable
handleDeclaration SymbolTable
symTable TypeSpec (Analysis a)
typespec AList Declarator (Analysis a)
decls = (SymbolTable -> Declarator (Analysis a) -> SymbolTable)
-> SymbolTable -> [Declarator (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symTable (AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
decls)
where
(TypeSpec Analysis a
_ SrcSpan
_ BaseType
bt Maybe (Selector (Analysis a))
selector) = TypeSpec (Analysis a)
typespec
handleVarStar :: Name -> SymbolTable -> Type -> SymbolTable
handleVarStar Name
symbol SymbolTable
symt Type
ty' =
let
entry :: SymbolTableEntry
entry = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
Just (SParameter Type
_ ExpVal
val) -> Type -> ExpVal -> SymbolTableEntry
SParameter Type
ty' ExpVal
val
Just SymbolTableEntry
_ -> Name -> SymbolTableEntry
forall a. HasCallStack => Name -> a
error
(Name
symbol
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"is not a parameter. \
\Only ParameterEntries are expected at this point."
)
Maybe SymbolTableEntry
Nothing -> Type -> Location -> SymbolTableEntry
SVariable (CharacterLen -> Int -> Type
TCharacter CharacterLen
CharLenStar Int
1) (Name
symbol, Int
0)
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
f :: SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symt (Declarator Analysis a
_ SrcSpan
s Expression (Analysis a)
varExp DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
charLength Maybe (Expression (Analysis a))
_) =
let
symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
ty' :: Type
ty' = BaseType -> Type
baseToType BaseType
bt
in
case (Maybe (Selector (Analysis a))
selector, Maybe (Expression (Analysis a))
charLength) of
(Just (Selector Analysis a
_ SrcSpan
_ (Just (ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
ValStar)) Maybe (Expression (Analysis a))
_), Maybe (Expression (Analysis a))
Nothing) ->
Name -> SymbolTable -> Type -> SymbolTable
handleVarStar Name
symbol SymbolTable
symt Type
ty'
(Maybe (Selector (Analysis a))
_, Just (ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
ValStar)) -> Name -> SymbolTable -> Type -> SymbolTable
handleVarStar Name
symbol SymbolTable
symt Type
ty'
(Maybe (Selector (Analysis a)), Maybe (Expression (Analysis a)))
_ ->
let
kind' :: Maybe Int
kind' = SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Int
forall a.
SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Int
getKind SymbolTable
symt TypeSpec (Analysis a)
typespec Maybe (Expression (Analysis a))
charLength
ty'' :: Type
ty'' = Type -> Maybe Int -> Type
setTypeKind Type
ty' Maybe Int
kind'
entry :: SymbolTableEntry
entry = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
Just (SParameter Type
_ ExpVal
val) -> Type -> ExpVal -> SymbolTableEntry
SParameter Type
ty'' ExpVal
val
Just (SVariable (TArray Type
_ Maybe Dimensions
dims) Location
loc) ->
Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray Type
ty' Maybe Dimensions
dims) Location
loc
Just v :: SymbolTableEntry
v@(SVariable Type
ty Location
loc) ->
let errStr :: Name
errStr =
Name
"The second declaration of '"
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
symbol
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"' at line "
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
s
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" does not have the same type as the first"
in if Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
ty' Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
/= Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
ty
then Name -> SymbolTableEntry
forall a. HasCallStack => Name -> a
error Name
errStr
else
let mk :: Maybe Int
mk = Type -> Maybe Int
getTypeKind Type
ty'
in if Maybe Int
mk Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Type -> Maybe Int
getTypeKind Type
ty
then Type -> Location -> SymbolTableEntry
SVariable Type
ty'' Location
loc
else SymbolTableEntry
v
Just SymbolTableEntry
_ -> Name -> SymbolTableEntry
forall a. HasCallStack => Name -> a
error
(Name
symbol
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" is not a parameter nor array-type variable.\
\ Invalid Fortran syntax at "
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
s
)
Maybe SymbolTableEntry
Nothing -> Type -> Location -> SymbolTableEntry
SVariable Type
ty'' (Name
symbol, Int
0)
in
Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
f SymbolTable
symt (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
varExp (ArrayDecl AList DimensionDeclarator (Analysis a)
dimDecls) Maybe (Expression (Analysis a))
charLength Maybe (Expression (Analysis a))
_) =
let
symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
entry :: SymbolTableEntry
entry = case Maybe (Expression (Analysis a))
charLength of
Just (ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
ValStar) ->
Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray (CharacterLen -> Int -> Type
TCharacter CharacterLen
CharLenStar Int
1) Maybe Dimensions
forall a. Maybe a
Nothing) (Name
symbol, Int
0)
Maybe (Expression (Analysis a))
_ ->
let
kd :: Maybe Int
kd = SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Int
forall a.
SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Int
getKind SymbolTable
symt TypeSpec (Analysis a)
typespec Maybe (Expression (Analysis a))
charLength
dims :: Maybe Dimensions
dims = (DimensionDeclarator (Analysis a) -> Maybe (Int, Int))
-> [DimensionDeclarator (Analysis a)] -> Maybe Dimensions
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
forall a.
SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
resolveDimensionDimensionDeclarator SymbolTable
symt)
(AList DimensionDeclarator (Analysis a)
-> [DimensionDeclarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator (Analysis a)
dimDecls)
ty :: Type
ty = Type -> Maybe Int -> Type
setTypeKind (BaseType -> Type
baseToType BaseType
bt) Maybe Int
kd
in
Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray Type
ty Maybe Dimensions
dims) (Name
symbol, Int
0)
in
Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
handleArrayDecl
:: Data a
=> SymbolTable -> Expression (Analysis a) -> [DimensionDeclarator (Analysis a)]
-> SymbolTable
handleArrayDecl :: forall a.
Data a =>
SymbolTable
-> Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)]
-> SymbolTable
handleArrayDecl SymbolTable
symTable Expression (Analysis a)
varExp [DimensionDeclarator (Analysis a)]
dimDecls =
let symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
dims :: Maybe Dimensions
dims = (DimensionDeclarator (Analysis a) -> Maybe (Int, Int))
-> [DimensionDeclarator (Analysis a)] -> Maybe Dimensions
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
forall a.
SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
resolveDimensionDimensionDeclarator SymbolTable
symTable) [DimensionDeclarator (Analysis a)]
dimDecls
in case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable of
Just (SVariable TArray{} Location
_) -> Name -> SymbolTable
forall a. HasCallStack => Name -> a
error Name
"invalid declarator: duplicate array declarations"
Just (SVariable Type
ty Location
loc) ->
let ste :: SymbolTableEntry
ste = Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray Type
ty Maybe Dimensions
dims) Location
loc
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
ste SymbolTable
symTable
Maybe SymbolTableEntry
Nothing ->
let ste :: SymbolTableEntry
ste = Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray Type
placeholderIntrinsicType Maybe Dimensions
dims) (Name
symbol, Int
0)
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
ste SymbolTable
symTable
where placeholderIntrinsicType :: Type
placeholderIntrinsicType = Int -> Type
TInteger Int
4
stSymbols :: Data a => SymbolTable -> Statement (Analysis a) -> SymbolTable
stSymbols :: forall a.
Data a =>
SymbolTable -> Statement (Analysis a) -> SymbolTable
stSymbols SymbolTable
symTable = \case
StParameter Analysis a
_ SrcSpan
_ AList Declarator (Analysis a)
alist -> SymbolTable -> AList Declarator (Analysis a) -> SymbolTable
forall a.
Data a =>
SymbolTable -> AList Declarator (Analysis a) -> SymbolTable
handleParameter SymbolTable
symTable AList Declarator (Analysis a)
alist
StDeclaration Analysis a
_ SrcSpan
_ TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
_ AList Declarator (Analysis a)
decls -> SymbolTable
-> TypeSpec (Analysis a)
-> AList Declarator (Analysis a)
-> SymbolTable
forall a.
Data a =>
SymbolTable
-> TypeSpec (Analysis a)
-> AList Declarator (Analysis a)
-> SymbolTable
handleDeclaration SymbolTable
symTable TypeSpec (Analysis a)
ts AList Declarator (Analysis a)
decls
StDimension Analysis a
_ SrcSpan
_ AList Declarator (Analysis a)
decls -> (SymbolTable -> Declarator (Analysis a) -> SymbolTable)
-> SymbolTable -> [Declarator (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Declarator (Analysis a) -> SymbolTable
forall {a}. SymbolTable -> Declarator (Analysis a) -> SymbolTable
handleDimension SymbolTable
symTable (AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
decls)
StCommon Analysis a
_ SrcSpan
_ AList CommonGroup (Analysis a)
cmns -> (SymbolTable -> CommonGroup (Analysis a) -> SymbolTable)
-> SymbolTable -> [CommonGroup (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> CommonGroup (Analysis a) -> SymbolTable
forall {a}.
Data a =>
SymbolTable -> CommonGroup (Analysis a) -> SymbolTable
handleCommon SymbolTable
symTable (AList CommonGroup (Analysis a) -> [CommonGroup (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList CommonGroup (Analysis a)
cmns)
StInclude Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ (Just [Block (Analysis a)]
bls) -> (SymbolTable -> Block (Analysis a) -> SymbolTable)
-> SymbolTable -> [Block (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Block (Analysis a) -> SymbolTable
forall a.
Data a =>
SymbolTable -> Block (Analysis a) -> SymbolTable
blSymbols SymbolTable
symTable [Block (Analysis a)]
bls
Statement (Analysis a)
_ -> SymbolTable
symTable
where
handleDimension :: SymbolTable -> Declarator (Analysis a) -> SymbolTable
handleDimension SymbolTable
symt = \case
Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
varExp (ArrayDecl AList DimensionDeclarator (Analysis a)
dimDecls) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ ->
Name
-> AList DimensionDeclarator (Analysis a)
-> SymbolTable
-> SymbolTable
forall a.
Name
-> AList DimensionDeclarator (Analysis a)
-> SymbolTable
-> SymbolTable
upgradeScalarToArray (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp) AList DimensionDeclarator (Analysis a)
dimDecls SymbolTable
symt
Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ ->
Name -> SymbolTable
forall a. HasCallStack => Name -> a
error Name
"non-array declaration in a DIMENSION statement"
handleCommon :: SymbolTable -> CommonGroup (Analysis a) -> SymbolTable
handleCommon SymbolTable
symt (CommonGroup Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mName AList Declarator (Analysis a)
decls) =
let arrayDecls :: [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
arrayDecls = [Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])])
-> (AList Declarator (Analysis a)
-> [Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])])
-> AList Declarator (Analysis a)
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Declarator (Analysis a)
-> Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)]))
-> [Declarator (Analysis a)]
-> [Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
forall a b. (a -> b) -> [a] -> [b]
map Declarator (Analysis a)
-> Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])
forall {a}.
Declarator a -> Maybe (Expression a, [DimensionDeclarator a])
extractArrayDecl ([Declarator (Analysis a)]
-> [Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])])
-> (AList Declarator (Analysis a) -> [Declarator (Analysis a)])
-> AList Declarator (Analysis a)
-> [Maybe
(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip (AList Declarator (Analysis a)
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])])
-> AList Declarator (Analysis a)
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
forall a b. (a -> b) -> a -> b
$ AList Declarator (Analysis a)
decls
in (SymbolTable
-> (Expression (Analysis a), [DimensionDeclarator (Analysis a)])
-> SymbolTable)
-> SymbolTable
-> [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
-> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)] -> SymbolTable)
-> (Expression (Analysis a), [DimensionDeclarator (Analysis a)])
-> SymbolTable
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)] -> SymbolTable)
-> (Expression (Analysis a), [DimensionDeclarator (Analysis a)])
-> SymbolTable)
-> (SymbolTable
-> Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)]
-> SymbolTable)
-> SymbolTable
-> (Expression (Analysis a), [DimensionDeclarator (Analysis a)])
-> SymbolTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolTable
-> Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)]
-> SymbolTable
forall a.
Data a =>
SymbolTable
-> Expression (Analysis a)
-> [DimensionDeclarator (Analysis a)]
-> SymbolTable
handleArrayDecl) SymbolTable
symt [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
arrayDecls
extractArrayDecl :: Declarator a -> Maybe (Expression a, [DimensionDeclarator a])
extractArrayDecl = \case
Declarator a
_ SrcSpan
_ Expression a
v (ArrayDecl AList DimensionDeclarator a
d) Maybe (Expression a)
_ Maybe (Expression a)
_ -> (Expression a, [DimensionDeclarator a])
-> Maybe (Expression a, [DimensionDeclarator a])
forall a. a -> Maybe a
Just (Expression a
v, AList DimensionDeclarator a -> [DimensionDeclarator a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator a
d)
Declarator a
_ SrcSpan
_ Expression a
_ DeclaratorType a
ScalarDecl Maybe (Expression a)
_ Maybe (Expression a)
_ -> Maybe (Expression a, [DimensionDeclarator a])
forall a. Maybe a
Nothing
upgradeScalarToArray
:: Name
-> AList DimensionDeclarator (Analysis a)
-> SymbolTable
-> SymbolTable
upgradeScalarToArray :: forall a.
Name
-> AList DimensionDeclarator (Analysis a)
-> SymbolTable
-> SymbolTable
upgradeScalarToArray Name
symbol AList DimensionDeclarator (Analysis a)
dimDecls SymbolTable
symTable =
case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable of
Just (SVariable TArray{} Location
_) ->
Name -> SymbolTable
forall a. HasCallStack => Name -> a
error (Name -> SymbolTable) -> Name -> SymbolTable
forall a b. (a -> b) -> a -> b
$ Name
symbol Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is array-typed variable."
Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" Invalid fortran syntax (Duplicate DIMENSION attribute)"
Just (SVariable Type
ty Location
loc) ->
let mdims :: Maybe Dimensions
mdims = (DimensionDeclarator (Analysis a) -> Maybe (Int, Int))
-> [DimensionDeclarator (Analysis a)] -> Maybe Dimensions
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
forall a.
SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)
resolveDimensionDimensionDeclarator SymbolTable
symTable)
(AList DimensionDeclarator (Analysis a)
-> [DimensionDeclarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator (Analysis a)
dimDecls)
entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable (Type -> Maybe Dimensions -> Type
TArray Type
ty Maybe Dimensions
mdims) Location
loc
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symTable
Maybe SymbolTableEntry
_ -> SymbolTable
symTable
puSymbols
:: Data a => Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
puSymbols :: forall a.
Data a =>
Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
puSymbols Bool
_ SymbolTable
symt (PUFunction Analysis a
_ SrcSpan
_ (Just TypeSpec (Analysis a)
typespec) PrefixSuffix (Analysis a)
_ Name
symbol Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_) =
let entryType :: Type
entryType = SymbolTable -> TypeSpec (Analysis a) -> Type
forall a. SymbolTable -> TypeSpec (Analysis a) -> Type
typeSpecToScalarType SymbolTable
symt TypeSpec (Analysis a)
typespec
entryLoc :: Location
entryLoc = (Name
symbol, Int
0)
entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable Type
entryType Location
entryLoc
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt
puSymbols Bool
getDecls SymbolTable
symt (PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
Nothing PrefixSuffix (Analysis a)
_ Name
symbol Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
bls Maybe [ProgramUnit (Analysis a)]
_) =
if Bool
getDecls then (SymbolTable -> Block (Analysis a) -> SymbolTable)
-> SymbolTable -> [Block (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Block (Analysis a) -> SymbolTable
forall {a}. SymbolTable -> Block (Analysis a) -> SymbolTable
handler SymbolTable
symt [Block (Analysis a)]
bls else SymbolTable
symt
where
handler :: SymbolTable -> Block (Analysis a) -> SymbolTable
handler SymbolTable
symt' (BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StDeclaration Analysis a
_ SrcSpan
_ TypeSpec (Analysis a)
typespec Maybe (AList Attribute (Analysis a))
_ AList Declarator (Analysis a)
decls)) =
let mty :: Maybe Type
mty = SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
forall a.
SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
declToType SymbolTable
symt' Name
symbol TypeSpec (Analysis a)
typespec ([Declarator (Analysis a)] -> Maybe Type)
-> [Declarator (Analysis a)] -> Maybe Type
forall a b. (a -> b) -> a -> b
$ AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
decls
in case Maybe Type
mty of
Just Type
ty ->
let entryLoc :: Location
entryLoc = (Name
symbol, Int
0)
entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable Type
ty Location
entryLoc
in Name -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
entry SymbolTable
symt'
Maybe Type
Nothing -> SymbolTable
symt'
handler SymbolTable
symt' Block (Analysis a)
_ = SymbolTable
symt'
puSymbols Bool
_ SymbolTable
symt ProgramUnit (Analysis a)
_ = SymbolTable
symt
declToType
:: SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
declToType :: forall a.
SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
declToType SymbolTable
symt Name
name TypeSpec (Analysis a)
tyspec (Declarator (Analysis a)
d : [Declarator (Analysis a)]
ds) = if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Declarator (Analysis a) -> Name
forall {a}. Declarator a -> Name
getName Declarator (Analysis a)
d
then Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Declarator (Analysis a) -> Type
toType Declarator (Analysis a)
d
else SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
forall a.
SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
declToType SymbolTable
symt Name
name TypeSpec (Analysis a)
tyspec [Declarator (Analysis a)]
ds
where
getName :: Declarator a -> Name
getName (Declarator a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
_ (ValVariable Name
str)) DeclaratorType a
_ Maybe (Expression a)
_ Maybe (Expression a)
_) = Name
str
getName Declarator a
_ = Name -> Name
forall a. HasCallStack => Name -> a
error Name
"Unexpected declaration expression"
toType :: Declarator (Analysis a) -> Type
toType (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ (ArrayDecl AList DimensionDeclarator (Analysis a)
dims) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) =
SymbolTable
-> [DimensionDeclarator (Analysis a)]
-> TypeSpec (Analysis a)
-> Type
forall a.
SymbolTable
-> [DimensionDeclarator (Analysis a)]
-> TypeSpec (Analysis a)
-> Type
typeSpecToArrayType SymbolTable
symt (AList DimensionDeclarator (Analysis a)
-> [DimensionDeclarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator (Analysis a)
dims) TypeSpec (Analysis a)
tyspec
toType (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) = SymbolTable -> TypeSpec (Analysis a) -> Type
forall a. SymbolTable -> TypeSpec (Analysis a) -> Type
typeSpecToScalarType SymbolTable
symt TypeSpec (Analysis a)
tyspec
declToType SymbolTable
_ Name
_ TypeSpec (Analysis a)
_ [] = Maybe Type
forall a. Maybe a
Nothing
blSymbols :: Data a => SymbolTable -> Block (Analysis a) -> SymbolTable
blSymbols :: forall a.
Data a =>
SymbolTable -> Block (Analysis a) -> SymbolTable
blSymbols SymbolTable
symt (BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Statement (Analysis a)
st ) = SymbolTable -> Statement (Analysis a) -> SymbolTable
forall a.
Data a =>
SymbolTable -> Statement (Analysis a) -> SymbolTable
stSymbols SymbolTable
symt Statement (Analysis a)
st
blSymbols SymbolTable
symt (BlInterface Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Bool
_ [ProgramUnit (Analysis a)]
pus [Block (Analysis a)]
_) = (SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable)
-> SymbolTable -> [ProgramUnit (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
forall a.
Data a =>
Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
puSymbols Bool
True) SymbolTable
symt [ProgramUnit (Analysis a)]
pus
blSymbols SymbolTable
symt Block (Analysis a)
_ = SymbolTable
symt
collectSymbols :: Data a => ProgramUnit (Analysis a) -> SymbolTable
collectSymbols :: forall a. Data a => ProgramUnit (Analysis a) -> SymbolTable
collectSymbols ProgramUnit (Analysis a)
pu =
let puSignatureSymbols :: SymbolTable
puSignatureSymbols = Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
forall a.
Data a =>
Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
puSymbols Bool
False SymbolTable
forall k a. Map k a
M.empty ProgramUnit (Analysis a)
pu
in (SymbolTable -> Block (Analysis a) -> SymbolTable)
-> SymbolTable -> [Block (Analysis a)] -> SymbolTable
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Block (Analysis a) -> SymbolTable
forall a.
Data a =>
SymbolTable -> Block (Analysis a) -> SymbolTable
blSymbols SymbolTable
puSignatureSymbols ([Block (Analysis a)] -> SymbolTable)
-> [Block (Analysis a)] -> SymbolTable
forall a b. (a -> b) -> a -> b
$ ProgramUnit (Analysis a) -> [Block (Analysis a)]
forall a. ProgramUnit a -> [Block a]
programUnitBody ProgramUnit (Analysis a)
pu