{-# 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                     ( mapMaybe, fromMaybe )

import           Language.Fortran.Analysis      ( Analysis
                                                , srcName
                                                )
import           Language.Fortran.AST           ( AList
                                                , aStrip
                                                , Block(..)
                                                , CommonGroup(..)
                                                , Declarator(..)
                                                , DeclaratorType(..)
                                                , DimensionDeclarator(..)
                                                , Expression(..)
                                                , Name
                                                , ProgramUnit(..)
                                                , programUnitBody
                                                , Statement(..)
                                                , Selector(..)
                                                , TypeSpec(..)
                                                , Value(..)
                                                )

import           Language.Fortran.Vars.SymbolTable.Arrays ( resolveDims )
import           Language.Fortran.Vars.Eval     ( eval
                                                , eval'
                                                )
import           Language.Fortran.Vars.BozConstant
                                                ( resolveBozConstant
                                                , bozToInt
                                                )
import           Language.Fortran.Vars.Types    ( ExpVal(..)
                                                , SymbolTableEntry(..)
                                                , Type
                                                , SemType(..)
                                                , CharacterLen(..)
                                                , SymbolTable
                                                , Dim(..), Dims(..), Dimensions
                                                )
import           Language.Fortran.Vars.Utils    ( typeSpecToScalarType
                                                , typeSpecToArrayType
                                                )
import           Language.Fortran.Vars.Kind     ( getKind
                                                , getTypeKind
                                                , setTypeKind
                                                , getKindOfExpVal
                                                , typeOfExpVal
                                                , baseToType
                                                , isStr
                                                )

{- TODO 2023-05-02 raehik: no longer used?

-- | 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 symTable (DimensionDeclarator _ _ lowerbound upperbound)
  = do
    lb <- valueOf lowerbound
    ub <- valueOf upperbound
    pure (lb, ub)
 where
  valueOf (Just (ExpValue _ _ ValStar)) = Nothing
  valueOf (Just (ExpValue _ _ (ValVariable name))) =
    case M.lookup name symTable of
      Just (SParameter _ (Int i)) -> Just i
      _                           -> Nothing
  valueOf (Just expr) = case eval' symTable expr of
    Right (Int i) -> Just i
    _             -> Nothing
  valueOf Nothing = Just 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symTable (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
alist)
 where
  -- special case: immediate BOZ constant
  -- The fortran-src evaluator doesn't look at binder when evaluating, so can't
  -- see the kind. The deprecated fortran-vars evaluator did. So tests of this
  -- form used to work, but now fail:
  --
  --    INTEGER*2 i2
  --    PARAMETER(i2 = '8000'x)
  --
  -- This special case catches only these (and only for INTEGERs).
  --
  -- raehik thinks the proper way to do this is the @INT(boz, kind)@ intrinsic.
  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 (ExpValue Analysis a
_ SrcSpan
_ (ValBoz Boz
boz)))) =
      let symbol :: Name
symbol = forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
       in case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symt of
            Maybe SymbolTableEntry
Nothing -> SymbolTable
symt
            Just (SVariable Type
ty Location
_) -> case Type
ty of
              TInteger Kind
kind ->
                let val :: ExpVal
val = Kind -> Boz -> ExpVal
bozToInt Kind
kind Boz
boz
                 in forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol (Type -> ExpVal -> SymbolTableEntry
SParameter Type
ty ExpVal
val) SymbolTable
symt
              Type
_ -> SymbolTable
symt -- unhandled BOZ coercion
            Just SymbolTableEntry
_ -> SymbolTable
symt -- unhandled BOZ usage

  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 = forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
        val' :: ExpVal
val'   = case 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' :: Kind
kind' = ExpVal -> Kind
getKindOfExpVal ExpVal
val'   -- infer kind from value
        pd' :: SymbolTableEntry
pd'   = Type -> ExpVal -> SymbolTableEntry
SParameter (Type -> Maybe Kind -> Type
setTypeKind (ExpVal -> Type
typeOfExpVal ExpVal
val') (forall a. a -> Maybe a
Just Kind
kind')) ExpVal
val'
        entry :: SymbolTableEntry
entry = case 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 Kind
_ -> 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 \'" forall a. [a] -> [a] -> [a]
++ Name
t forall a. [a] -> [a] -> [a]
++ Name
"\'"
            in  forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name -> Name
errStr Name
symbol
    in  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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SymbolTable -> Declarator (Analysis a) -> SymbolTable
f SymbolTable
symTable (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 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
_                  -> forall a. HasCallStack => Name -> a
error
          (Name
symbol
          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 -> Kind -> Type
TCharacter CharacterLen
CharLenStar Kind
1) (Name
symbol, Kind
0)
    in  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 = 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 Kind
kind' = forall a.
SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Kind
getKind SymbolTable
symt TypeSpec (Analysis a)
typespec Maybe (Expression (Analysis a))
charLength
            ty'' :: Type
ty''  = Type -> Maybe Kind -> Type
setTypeKind Type
ty' Maybe Kind
kind'
            entry :: SymbolTableEntry
entry = case 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
_ Dimensions
dims) Location
loc) ->
                Type -> Location -> SymbolTableEntry
SVariable (Type -> Dimensions -> Type
TArray Type
ty' Dimensions
dims) Location
loc
              Just v :: SymbolTableEntry
v@(SVariable Type
ty Location
loc) ->
                let errStr :: Name
errStr =
                        Name
"The second declaration of '"
                          forall a. [a] -> [a] -> [a]
++ Name
symbol
                          forall a. [a] -> [a] -> [a]
++ Name
"' at line "
                          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show SrcSpan
s
                          forall a. [a] -> [a] -> [a]
++ Name
" does not have the same type as the first"
                in  if forall a. Data a => a -> Constr
toConstr Type
ty' forall a. Eq a => a -> a -> Bool
/= forall a. Data a => a -> Constr
toConstr Type
ty
                      then forall a. HasCallStack => Name -> a
error Name
errStr
                      else
                        let mk :: Maybe Kind
mk = Type -> Maybe Kind
getTypeKind Type
ty'
                        in  if Maybe Kind
mk forall a. Eq a => a -> a -> Bool
/= Type -> Maybe Kind
getTypeKind Type
ty
                              then Type -> Location -> SymbolTableEntry
SVariable Type
ty'' Location
loc
                              else SymbolTableEntry
v
              Just SymbolTableEntry
_ -> forall a. HasCallStack => Name -> a
error
                (Name
symbol
                forall a. [a] -> [a] -> [a]
++ Name
" is not a parameter nor array-type variable.\
                                         \ Invalid Fortran syntax at "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show SrcSpan
s
                )
              Maybe SymbolTableEntry
Nothing -> Type -> Location -> SymbolTableEntry
SVariable Type
ty'' (Name
symbol, Kind
0)
          in
            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 = 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) ->
          let ty :: Type
ty = Type -> Dimensions -> Type
TArray (CharacterLen -> Kind -> Type
TCharacter CharacterLen
CharLenStar Kind
1) (forall (t :: * -> *) a. Maybe (t (Dim a)) -> a -> Dims t a
DimsAssumedSize forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Kind
1))
          in  Type -> Location -> SymbolTableEntry
SVariable Type
ty (Name
symbol, Kind
0)
        Maybe (Expression (Analysis a))
_ ->
          case forall a.
SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions
resolveDims SymbolTable
symt (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator (Analysis a)
dimDecls) of
            Maybe Dimensions
Nothing -> forall a. HasCallStack => Name -> a
error Name
"unsupported dimension declarators: probably skip instead of erroring"
            Just Dimensions
dims ->
              let kd :: Maybe Kind
kd = forall a.
SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Kind
getKind SymbolTable
symt TypeSpec (Analysis a)
typespec Maybe (Expression (Analysis a))
charLength
                  ty :: Type
ty = Type -> Maybe Kind -> Type
setTypeKind (BaseType -> Type
baseToType BaseType
bt) Maybe Kind
kd
              in  Type -> Location -> SymbolTableEntry
SVariable (Type -> Dimensions -> Type
TArray Type
ty Dimensions
dims) (Name
symbol, Kind
0)
    in
      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 =
  case forall a.
SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions
resolveDims SymbolTable
symTable [DimensionDeclarator (Analysis a)]
dimDecls of
    Maybe Dimensions
Nothing -> forall a. HasCallStack => Name -> a
error Name
"unsupported dimension declarators: probably skip instead of erroring"
    Just Dimensions
dims ->
      let symbol :: Name
symbol = forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
varExp
      in  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable of
            Just (SVariable TArray{} Location
_) ->
              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 -> Dimensions -> Type
TArray Type
ty Dimensions
dims) Location
loc
              in  forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
symbol SymbolTableEntry
ste SymbolTable
symTable
            Just SymbolTableEntry
var -> forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"Invalid declarator: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Name
show SymbolTableEntry
var
            Maybe SymbolTableEntry
Nothing -> -- add array info, use a placeholder for scalar type
              let ste :: SymbolTableEntry
ste =
                      Type -> Location -> SymbolTableEntry
SVariable (Type -> Dimensions -> Type
TArray Type
placeholderIntrinsicType Dimensions
dims) (Name
symbol, Kind
0)
              in  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 = Kind -> Type
TInteger Kind
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        -> 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 -> 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        -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. SymbolTable -> Declarator (Analysis a) -> SymbolTable
handleDimension SymbolTable
symTable (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
decls)
  StCommon    Analysis a
_ SrcSpan
_ AList CommonGroup (Analysis a)
cmns         -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}.
Data a =>
SymbolTable -> CommonGroup (Analysis a) -> SymbolTable
handleCommon SymbolTable
symTable (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)   -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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))
_ ->
      forall a.
Name
-> AList DimensionDeclarator (Analysis a)
-> SymbolTable
-> SymbolTable
upgradeScalarToArray (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))
_ ->
      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))
_ AList Declarator (Analysis a)
decls) =
    let arrayDecls :: [(Expression (Analysis a), [DimensionDeclarator (Analysis a)])]
arrayDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}.
Declarator a -> Maybe (Expression a, [DimensionDeclarator a])
extractArrayDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. AList t a -> [t a]
aStrip forall a b. (a -> b) -> a -> b
$ AList Declarator (Analysis a)
decls
    in  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
_ -> forall a. a -> Maybe a
Just (Expression a
v, 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)
_ -> forall a. Maybe a
Nothing

-- | Upgrade an existing scalar variable to an array variable with the given
--   dimension information and return the updated 'SymbolTable'.
--
-- 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 forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable of
    Just (SVariable TArray{} Location
_) ->
      forall a. HasCallStack => Name -> a
error
        forall a b. (a -> b) -> a -> b
$  Name
symbol
        forall a. Semigroup a => a -> a -> a
<> Name
" is array-typed variable."
        forall a. Semigroup a => a -> a -> a
<> Name
" Invalid fortran syntax (Duplicate DIMENSION attribute)"
    Just (SVariable Type
ty Location
loc) ->
      case forall a.
SymbolTable -> [DimensionDeclarator a] -> Maybe Dimensions
resolveDims SymbolTable
symTable (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator (Analysis a)
dimDecls) of
        Maybe Dimensions
Nothing -> forall a. HasCallStack => Name -> a
error Name
"TODO invalid DIMENSION attribute while upgrading a scalar to array"
        Just Dimensions
dims ->
          let entry :: SymbolTableEntry
entry = Type -> Location -> SymbolTableEntry
SVariable (Type -> Dimensions -> Type
TArray Type
ty Dimensions
dims) Location
loc
          in  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 = forall a. SymbolTable -> TypeSpec (Analysis a) -> Type
typeSpecToScalarType SymbolTable
symt TypeSpec (Analysis a)
typespec
      entryLoc :: Location
entryLoc  = (Name
symbol, Kind
0)
      entry :: SymbolTableEntry
entry     = Type -> Location -> SymbolTableEntry
SVariable Type
entryType Location
entryLoc
  in  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 forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 = forall a.
SymbolTable
-> Name
-> TypeSpec (Analysis a)
-> [Declarator (Analysis a)]
-> Maybe Type
declToType SymbolTable
symt' Name
symbol TypeSpec (Analysis a)
typespec forall a b. (a -> b) -> a -> b
$ 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, Kind
0)
                entry :: SymbolTableEntry
entry    = Type -> Location -> SymbolTableEntry
SVariable Type
ty Location
entryLoc
            in  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 forall a. Eq a => a -> a -> Bool
== forall {a}. Declarator a -> Name
getName Declarator (Analysis a)
d
  then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Declarator (Analysis a) -> Type
toType Declarator (Analysis a)
d
  else 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
_ = 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))
_) =
    forall a.
SymbolTable
-> [DimensionDeclarator (Analysis a)]
-> TypeSpec (Analysis a)
-> Type
typeSpecToArrayType SymbolTable
symt (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))
_) = forall a. SymbolTable -> TypeSpec (Analysis a) -> Type
typeSpecToScalarType SymbolTable
symt TypeSpec (Analysis a)
tyspec
declToType SymbolTable
_ Name
_ TypeSpec (Analysis a)
_ [] = 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     ) = 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)]
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (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 = forall a.
Data a =>
Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable
puSymbols Bool
False forall k a. Map k a
M.empty ProgramUnit (Analysis a)
pu
  in  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a.
Data a =>
SymbolTable -> Block (Analysis a) -> SymbolTable
blSymbols SymbolTable
puSignatureSymbols forall a b. (a -> b) -> a -> b
$ forall a. ProgramUnit a -> [Block a]
programUnitBody ProgramUnit (Analysis a)
pu