{-# 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
                                                )

-- | Given a 'SymbolTable' and a 'DimensionDeclarator', return a pair of
-- resolved 'DynamicDimensionElement's representing lower- and upper- bound
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

-- Parameter declarations
-- A parameter may or may not have a type declaration. If it does have one,
-- the declaration statement can go before or after the parameter statement.
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'   -- infer kind from value
        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
                 -- Entry found implies there is a preceding declaration
                 -- of the name. 
                 -- If that is variable declaration, keep the accurate type
                 -- and kind informatio from the declaration.
                 -- Else if it is dummy variable, keep the accurate type 
                 -- and update kind
                 -- Else raise error for conflicting parameter attribute
                 -- Parameter name does not necessarily have a type
                 -- declaration or a kind is assumed. In that case type
                 -- and kind are inferred from the value of parameter.
          Maybe SymbolTableEntry
Nothing               -> SymbolTableEntry
pd'
          Just (SVariable Type
ty Location
_) -> case Type
ty of
            -- TODO previously TCharacter Nothing
            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
        -- Entry found implies the name also appears in a
        -- preceding parameter statement. In case of ValStar
        -- selector, only type is updated.
        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
  -- don't care initial value at this moment
  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
              -- Entry found implies the name also appears in a
              -- preceding parameter statement or that the entry
              -- has already been defined. In the case of parameter
              -- only type and kind are updated, and the type and
              -- kind are checked in the case of already defined.
              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

-- | Handle an array 'Declarator'.
--
-- 'Declarator's are the RHS of a declaration statement, and also used in COMMON
-- block definitions. They store the variable name, and array type info.
-- Importantly, they don't store any scalar info (only bring the variable into
-- scope). So we only handle array 'Declarator's.
--
-- If the array 'Declarator' is for a variable not (yet) in the given
-- 'SymbolTable', it's given a placeholder scalar type. This is apparently
-- inconsistent with how DIMENSION statements are handled, where such cases are
-- skipped.
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 -> -- add array info, use a placeholder for scalar type
            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

-- | Given a 'SymbolTable' and a 'Statement' found in a 'ProgramUnit', return a new 'SymbolTable'
-- with any newly defined symbols
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
    -- DIMENSION statements only permit array declarators, so this is impossible
    -- in a correct parser.
    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

-- | Try to upgrade an existing scalar variable to an array variable.
--
-- Returns the unchanged 'SymbolTable' if the variable didn't exist. If the
-- variable was already an array type, runtime error.
--
-- The DIMENSION statement defines array metadata for a variable. Due to
-- Fortran syntax, a variable's the full type isn't known until the executable
-- statements begin, and you may define array and scalar info in either order
-- e.g. `INTEGER x; DIMENSION x(2)` or `DIMENSION x(2); INTEGER x`. This
-- function handles just the former case. (Ideally we handle both
-- interchangeably, but the fortran-vars type representation isn't conducive.)
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

-- | Given a 'Bool', 'SymbolTable' and a 'ProgramUnit', return an updated
-- 'SymbolTable' containing symbols defined in 'ProgramUnit' signature, e.g.
--   integer function fname() -> symbol table containing 'fname'
-- The first argument flags whether to traverse declarations for the function return
-- type, allowing us to avoid traversing the top level program unit twice
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

-- | Given a TypeSpec and list of Declarators, search for a name in that list
-- and return the resolved type if there
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

-- | Update SymbolTable for a given block, traverse statements to get
-- declarations and interfaces to get function signatures.
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

-- | Given a 'ProgramUnit', generate a 'SymbolTable' for all of the non-intrisic symbols
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