fortran-src 0.4.3 → 0.5.0

raw patch · 25 files changed

+881/−258 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• fortran-src.cabal +16/−16
• src/Language/Fortran/AST.hs +8/−30
• src/Language/Fortran/Analysis.hs +9/−7
• src/Language/Fortran/Analysis/BBlocks.hs +1/−11
• src/Language/Fortran/Analysis/SemanticTypes.hs +239/−0
• src/Language/Fortran/Analysis/Types.hs +332/−110
• src/Language/Fortran/Lexer/FreeForm.x +1/−0
• src/Language/Fortran/Parser/Fortran2003.y +2/−2
• src/Language/Fortran/Parser/Fortran77.y +9/−11
• src/Language/Fortran/Parser/Fortran90.y +7/−7
• src/Language/Fortran/Parser/Fortran95.y +7/−7
• src/Language/Fortran/Parser/Utils.hs +90/−1
• src/Language/Fortran/PrettyPrint.hs +2/−8
• src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +1/−1
• src/Main.hs +4/−2
• test/Language/Fortran/Analysis/SemanticTypesSpec.hs +31/−0
• test/Language/Fortran/Analysis/TypesSpec.hs +35/−28
• test/Language/Fortran/Parser/Fortran2003Spec.hs +2/−2
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +6/−6
• test/Language/Fortran/Parser/Fortran90Spec.hs +2/−2
• test/Language/Fortran/Parser/Fortran95Spec.hs +2/−2
• test/Language/Fortran/Parser/UtilsSpec.hs +55/−2
• test/Language/Fortran/PrettyPrintSpec.hs +2/−2
• test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +0/−1

@@ -1,3 +1,21 @@+### 0.5.0 (Jun 30, 2021)+  * Introduce a second-stage type representation including kind info alongside+    types, and resolving some types to semantic type with preset kinds (e.g.+    `DOUBLE PRECISION` -> `REAL(8)`).+    * Module is at Language.Fortran.Analysis.SemanticTypes . Includes utils and+      instances.+    * The type analysis in Language.Fortran.Analysis.Types uses this+      representation now (`IDType` stores a `SemType` instead of a `BaseType`).+  * Move `CharacterLen` from parsing to type analysis.+    * This makes `BaseType` now a plain tag/enum with no extra info.+  * Add extended Fortran 90 real literal parser (parses kind info).+  * Export some infer monad utils (potentially useful for running just parts of+    type analysis)+  * Parser & lexer tweaks+    * Fortran 77 parser should no longer attempt to parse kind selectors for+      `DOUBLE` types+    * Fix an edge case with the fixed form lexer (#150)+ ### 0.4.3 (May 25, 2021)    * Add Haddock documentation to AST module. Many parts of the AST now have

@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: f5d7e99716015530592de9c1b2546f0d2ad31a230d0574adb8385118e8bdba1f  name:           fortran-src-version:        0.4.3+version:        0.5.0 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90 and 95. description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. category:       Language@@ -28,6 +26,7 @@  library   exposed-modules:+      Language.Fortran.Analysis.SemanticTypes       Language.Fortran.Analysis       Language.Fortran.Analysis.Renaming       Language.Fortran.Analysis.ModGraph@@ -70,15 +69,15 @@     , happy >=1.19   build-depends:       GenericPretty >=1.2.2 && <2-    , array >=0.5 && <0.6+    , array ==0.5.*     , base >=4.6 && <5     , binary >=0.8.3.0 && <0.11     , bytestring >=0.10 && <0.12     , containers >=0.5 && <0.7-    , deepseq >=1.4 && <1.5+    , deepseq ==1.4.*     , directory >=1.2 && <2-    , fgl >=5 && <6-    , filepath >=1.4 && <1.5+    , fgl ==5.*+    , filepath ==1.4.*     , mtl >=2.2 && <3     , pretty >=1.1 && <2     , temporary >=1.2 && <1.4@@ -93,15 +92,15 @@   ghc-options: -Wall -fno-warn-tabs   build-depends:       GenericPretty >=1.2.2 && <2-    , array >=0.5 && <0.6+    , array ==0.5.*     , base >=4.6 && <5     , binary >=0.8.3.0 && <0.11     , bytestring >=0.10 && <0.12     , containers >=0.5 && <0.7-    , deepseq >=1.4 && <1.5+    , deepseq ==1.4.*     , directory >=1.2 && <2-    , fgl >=5 && <6-    , filepath >=1.4 && <1.5+    , fgl ==5.*+    , filepath ==1.4.*     , fortran-src     , mtl >=2.2 && <3     , pretty >=1.1 && <2@@ -117,6 +116,7 @@       Language.Fortran.Analysis.BBlocksSpec       Language.Fortran.Analysis.DataFlowSpec       Language.Fortran.Analysis.RenamingSpec+      Language.Fortran.Analysis.SemanticTypesSpec       Language.Fortran.Analysis.TypesSpec       Language.Fortran.AnalysisSpec       Language.Fortran.Lexer.FixedFormSpec@@ -146,15 +146,15 @@       hspec-discover:hspec-discover   build-depends:       GenericPretty >=1.2.2 && <2-    , array >=0.5 && <0.6+    , array ==0.5.*     , base >=4.6 && <5     , binary >=0.8.3.0 && <0.11     , bytestring >=0.10 && <0.12     , containers >=0.5 && <0.7-    , deepseq >=1.4 && <1.5+    , deepseq ==1.4.*     , directory >=1.2 && <2-    , fgl >=5 && <6-    , filepath >=1.4 && <1.5+    , fgl ==5.*+    , filepath ==1.4.*     , fortran-src     , hspec >=2.2 && <3     , mtl >=2.2 && <3

@@ -6,6 +6,8 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +-- |+-- -- This module holds the data types used to represent Fortran code of various -- versions. --@@ -25,8 +27,8 @@ -- (The Fortran 66 ANSI standard lacks detail, and isn't as useful as the later -- standards for implementing the language.) ----- /Some comments aren't reflected in the Haddock documentation, so you may also--- wish to view this file's source./+-- /Note:/ some comments aren't reflected in the Haddock documentation, so you+-- may also wish to view this file's source.  module Language.Fortran.AST   (@@ -45,7 +47,6 @@   -- ** Types and declarations   , Name   , BaseType(..)-  , CharacterLen(..)   , TypeSpec(..)   , Declarator(..)   , Selector(..)@@ -84,6 +85,7 @@   , FlushSpec(..)   , DoSpecification(..)   , ProgramUnitName(..)+  , Kind    -- * Node annotations & related typeclasses   , A0@@ -93,7 +95,6 @@   , Named(..)    -- * Helpers-  , charLenSelector   , validPrefixSuffix   , emptyPrefixes   , emptySuffixes@@ -156,7 +157,7 @@   | TypeComplex   | TypeDoubleComplex   | TypeLogical-  | TypeCharacter (Maybe CharacterLen) (Maybe String) -- ^ len and kind, if specified+  | TypeCharacter   | TypeCustom String   | ClassStar   | ClassCustom String@@ -165,29 +166,6 @@  instance Binary BaseType -data CharacterLen = CharLenStar    -- ^ specified with a *-                  | CharLenColon   -- ^ specified with a : (Fortran2003)-                    -- FIXME, possibly, with a more robust const-exp:-                  | CharLenExp     -- ^ specified with a non-trivial expression-                  | CharLenInt Int -- ^ specified with a constant integer-  deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary CharacterLen--charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)-charLenSelector Nothing                          = (Nothing, Nothing)-charLenSelector (Just (Selector _ _ mlen mkind)) = (l, k)-  where-    l | Just (ExpValue _ _ ValStar) <- mlen        = Just CharLenStar-      | Just (ExpValue _ _ ValColon) <- mlen       = Just CharLenColon-      | Just (ExpValue _ _ (ValInteger i)) <- mlen = Just $ CharLenInt (read i)-      | Nothing <- mlen                            = Nothing-      | otherwise                                  = Just CharLenExp-    k | Just (ExpValue _ _ (ValInteger i)) <- mkind  = Just i-      | Just (ExpValue _ _ (ValVariable s)) <- mkind = Just s-      -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it-      | otherwise                                    = Nothing- -- | The type specification of a declaration statement, containing the syntactic --   type name and kind selector. --@@ -211,6 +189,8 @@   Selector a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))   deriving (Eq, Show, Data, Typeable, Generic, Functor) +type Kind = Int+ data MetaInfo = MetaInfo { miVersion :: FortranVersion, miFilename :: String }   deriving (Eq, Show, Data, Typeable, Generic) @@ -968,7 +948,6 @@ instance Out a => Out (Value a) instance Out a => Out (TypeSpec a) instance Out a => Out (Selector a)-instance Out CharacterLen instance Out BaseType instance Out a => Out (Declarator a) instance Out a => Out (DimensionDeclarator a)@@ -1064,7 +1043,6 @@ instance NFData a => NFData (StructureItem a) instance NFData a => NFData (UnionMap a) instance NFData MetaInfo-instance NFData CharacterLen instance NFData BaseType instance NFData UnaryOp instance NFData BinaryOp

@@ -7,7 +7,7 @@   ( initAnalysis, stripAnalysis, Analysis(..), Constant(..)   , varName, srcName, lvVarName, lvSrcName, isNamedExpression   , genVar, puName, puSrcName, blockRhsExprs, rhsExprs-  , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..)+  , ModEnv, NameType(..), IDType(..), ConstructType(..)   , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars   , blockVarUses, blockVarDefs   , BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty@@ -30,6 +30,8 @@ import Language.Fortran.Intrinsics (getIntrinsicDefsUses, allIntrinsics) import Data.Bifunctor (first) +import           Language.Fortran.Analysis.SemanticTypes (SemType(..))+ --------------------------------------------------  -- | Basic block@@ -97,7 +99,7 @@ instance Binary ConstructType  data IDType = IDType-  { idVType :: Maybe BaseType+  { idVType :: Maybe SemType   , idCType :: Maybe ConstructType }   deriving (Ord, Eq, Show, Data, Typeable, Generic) @@ -169,7 +171,7 @@ isNamedExpression _                               = False  -- | Obtain either uniqueName or source name from an ExpValue variable.-varName :: Expression (Analysis a) -> String+varName :: Expression (Analysis a) -> Name varName (ExpValue Analysis { uniqueName = Just n } _ ValVariable{})  = n varName (ExpValue Analysis { sourceName = Just n } _ ValVariable{})  = n varName (ExpValue _ _ (ValVariable n))                               = n@@ -179,7 +181,7 @@ varName _                                                            = error "Use of varName on non-variable."  -- | Obtain the source name from an ExpValue variable.-srcName :: Expression (Analysis a) -> String+srcName :: Expression (Analysis a) -> Name srcName (ExpValue Analysis { sourceName = Just n } _ ValVariable{})  = n srcName (ExpValue _ _ (ValVariable n))                               = n srcName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n@@ -187,20 +189,20 @@ srcName _                                                            = error "Use of srcName on non-variable."  -- | Obtain either uniqueName or source name from an LvSimpleVar variable.-lvVarName :: LValue (Analysis a) -> String+lvVarName :: LValue (Analysis a) -> Name lvVarName (LvSimpleVar Analysis { uniqueName = Just n } _ _)  = n lvVarName (LvSimpleVar Analysis { sourceName = Just n } _ _)  = n lvVarName (LvSimpleVar _ _ n)                                 = n lvVarName _                                                   = error "Use of lvVarName on non-variable."  -- | Obtain the source name from an LvSimpleVar variable.-lvSrcName :: LValue (Analysis a) -> String+lvSrcName :: LValue (Analysis a) -> Name lvSrcName (LvSimpleVar Analysis { sourceName = Just n } _ _) = n lvSrcName (LvSimpleVar _ _ n) = n lvSrcName _ = error "Use of lvSrcName on a non-variable"  -- | Generate an ExpValue variable with its source name == to its uniqueName.-genVar :: Analysis a -> SrcSpan -> String -> Expression (Analysis a)+genVar :: Analysis a -> SrcSpan -> Name -> Expression (Analysis a) genVar a s n = ExpValue (a { uniqueName = Just n, sourceName = Just n }) s v   where     v | Just CTIntrinsic <- idCType =<< idType a = ValIntrinsic n

@@ -884,21 +884,11 @@ showBaseType TypeComplex         = "complex" showBaseType TypeDoubleComplex   = "doublecomplex" showBaseType TypeLogical         = "logical"-showBaseType (TypeCharacter l k) = case (l, k) of-  (Just cl, Just ki) -> "character(" ++ showCharLen cl ++ "," ++ ki ++ ")"-  (Just cl, Nothing) -> "character(" ++ showCharLen cl ++ ")"-  (Nothing, Just ki) -> "character(kind=" ++ ki ++ ")"-  (Nothing, Nothing) -> "character"+showBaseType TypeCharacter       = "character" showBaseType (TypeCustom s)      = "type(" ++ s ++ ")" showBaseType TypeByte            = "byte" showBaseType ClassStar           = "class(*)" showBaseType (ClassCustom s)     = "class(" ++ s ++ ")"--showCharLen :: CharacterLen -> String-showCharLen CharLenStar = "*"-showCharLen CharLenColon = ":"-showCharLen CharLenExp  = "*" -- FIXME, possibly, with a more robust const-exp-showCharLen (CharLenInt i) = show i  showDecl :: Declarator a -> String showDecl (DeclArray _ _ e adims length' initial) =

@@ -0,0 +1,239 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Fortran.Analysis.SemanticTypes where++import           Data.Data                      ( Data, Typeable )+import           Control.DeepSeq                ( NFData )+import           GHC.Generics                   ( Generic )+import           Language.Fortran.AST           ( BaseType(..)+                                                , Kind+                                                , Expression(..)+                                                , Value(..)+                                                , TypeSpec(..)+                                                , Selector(..) )+import           Language.Fortran.Util.Position ( SrcSpan(..) )+import           Language.Fortran.Version       ( FortranVersion(..) )+import           Data.Binary                    ( Binary )+import           Text.PrettyPrint.GenericPretty ( Out(..) )+import           Text.PrettyPrint               ( (<+>), parens )+import           Language.Fortran.PrettyPrint   ( Pretty(..) )++-- | Semantic type assigned to variables.+--+-- 'BaseType' stores the "type tag" given in syntax. 'SemType's add metadata+-- (kind and length), and resolve some "simple" types to a core type with a+-- preset kind (e.g. `DOUBLE PRECISION` -> `REAL(8)`).+--+-- Fortran 90 (and beyond) features may not be well supported.+data SemType+  = TInteger Kind+  | TReal Kind+  | TComplex Kind+  | TLogical Kind+  | TByte Kind+  | TCharacter CharacterLen Kind+  | TArray SemType (Maybe Dimensions) -- ^ Nothing denotes dynamic dimensions+  | TCustom String                    -- use for F77 structures, F90 DDTs+  deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance Binary SemType+instance Out    SemType++-- TODO placeholder, not final or tested+-- should really attempt to print with kind info, and change to DOUBLE PRECISION+-- etc. for <F90. Maybe cheat, use 'recoverSemTypeTypeSpec' and print resulting+-- TypeSpec?+instance Pretty SemType where+  pprint' v = \case+    TInteger k -> "integer"+    TReal k    -> "real"+    TComplex k -> "complex"+    TLogical k -> "logical"+    TByte k    -> "byte"+    TCharacter len k -> "character"+    TArray st dims -> pprint' v st <+> parens "(A)"+    TCustom str -> pprint' v (TypeCustom str)++-- | The declared dimensions of a staticically typed array variable+-- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]+type Dimensions = [(Int, Int)]++--------------------------------------------------------------------------------++data CharacterLen = CharLenStar    -- ^ specified with a *+                  | CharLenColon   -- ^ specified with a : (Fortran2003)+                    -- FIXME, possibly, with a more robust const-exp:+                  | CharLenExp     -- ^ specified with a non-trivial expression+                  | CharLenInt Int -- ^ specified with a constant integer+  deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary CharacterLen+instance Out    CharacterLen+instance NFData CharacterLen++charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)+charLenSelector Nothing                          = (Nothing, Nothing)+charLenSelector (Just (Selector _ _ mlen mkind)) = (l, k)+  where+    l = charLenSelector' <$> mlen+    k | Just (ExpValue _ _ (ValInteger i)) <- mkind  = Just i+      | Just (ExpValue _ _ (ValVariable s)) <- mkind = Just s+      -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it+      | otherwise                                    = Nothing++charLenSelector' :: Expression a -> CharacterLen+charLenSelector' = \case+  ExpValue _ _ ValStar        -> CharLenStar+  ExpValue _ _ ValColon       -> CharLenColon+  ExpValue _ _ (ValInteger i) -> CharLenInt (read i)+  _                           -> CharLenExp++-- | Attempt to recover the 'Value' that generated the given 'CharacterLen'.+charLenToValue :: CharacterLen -> Maybe (Value a)+charLenToValue = \case+  CharLenStar  -> Just ValStar+  CharLenColon -> Just ValColon+  CharLenInt i -> Just (ValInteger (show i))+  CharLenExp   -> Nothing++getTypeKind :: SemType -> Kind+getTypeKind = \case+  TInteger   k -> k+  TReal      k -> k+  TComplex   k -> k+  TLogical   k -> k+  TByte      k -> k+  TCharacter _ k -> k+  TCustom    _ -> error "TCustom does not have a kind"+  TArray t _   -> getTypeKind t++setTypeKind :: SemType -> Kind -> SemType+setTypeKind st k = case st of+  TInteger   _ -> TInteger   k+  TReal      _ -> TReal      k+  TComplex   _ -> TComplex   k+  TLogical   _ -> TLogical   k+  TByte      _ -> TByte      k+  TCharacter charLen _ -> TCharacter charLen k+  TCustom    _ -> error "can't set kind of TCustom"+  TArray _ _   -> error "can't set kind of TArray"++charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen+charLenConcat l1 l2 = case (l1, l2) of+  (CharLenExp    , _             ) -> CharLenExp+  (_             , CharLenExp    ) -> CharLenExp+  (CharLenStar   , _             ) -> CharLenStar+  (_             , CharLenStar   ) -> CharLenStar+  (CharLenColon  , _             ) -> CharLenColon+  (_             , CharLenColon  ) -> CharLenColon+  (CharLenInt i1 , CharLenInt i2 ) -> CharLenInt (i1 + i2)++-- | Recover the most appropriate 'TypeSpec' for the given 'SemType', depending+--   on the given 'FortranVersion'.+--+-- Kinds weren't formalized as a syntactic feature until Fortran 90, so we ask+-- for a context. If possible (>=F90), we prefer the more explicit+-- representation e.g. @REAL(8)@. For older versions, for specific type-kind+-- combinations, @DOUBLE PRECISION@ and @DOUBLE COMPLEX@ are used instead.+-- However, we otherwise don't shy away from adding kind info regardless of+-- theoretical version support.+--+-- Array types don't work properly, due to array type info being in a parent+-- node that holds individual elements.+recoverSemTypeTypeSpec :: forall a. a -> SrcSpan+                       -> FortranVersion -> SemType -> TypeSpec a+recoverSemTypeTypeSpec a ss v = \case+  TInteger k -> wrapBaseAndKind TypeInteger k+  TLogical k -> wrapBaseAndKind TypeLogical k+  TByte    k -> wrapBaseAndKind TypeByte k++  TCustom str -> ts (TypeCustom str) Nothing++  TArray     st  _   -> recoverSemTypeTypeSpec a ss v st++  TReal    k ->+      if k == 8 && v < Fortran90+    then ts TypeDoublePrecision Nothing+    else wrapBaseAndKind TypeReal k+  TComplex k ->+      if k == 16 && v < Fortran90+    then ts TypeDoubleComplex Nothing+    else wrapBaseAndKind TypeComplex k++  TCharacter len k   ->+    -- TODO can improve, use no selector if len=1, kind=1+    -- only include kind if != 1+    let sel = Selector a ss (ExpValue a ss <$> charLenToValue len) (if k == 1 then Nothing else Just (intValExpr k))+     in ts TypeCharacter (Just sel)++  where+    ts = TypeSpec a ss+    intValExpr :: Int -> Expression a+    intValExpr x = ExpValue a ss (ValInteger (show x))++    -- | Wraps 'BaseType' and 'Kind' into 'TypeSpec'. If the kind is the+    --   'BaseType''s default kind, it is omitted.+    wrapBaseAndKind :: BaseType -> Kind -> TypeSpec a+    wrapBaseAndKind bt k = ts bt sel+      where+        sel =   if k == kindOfBaseType bt+              then Nothing+              else Just $ Selector a ss Nothing (Just (intValExpr k))++--------------------------------------------------------------------------------++-- | Given a 'BaseType' infer the "default" kind (or size of the+-- variable in memory).+--+-- Useful when you need a default kind, but gives you an unwrapped type.+-- Consider using Analysis.deriveSemTypeFromBaseType also.+--+-- Further documentation:+-- https://docs.oracle.com/cd/E19957-01/805-4939/c400041360f5/index.html+kindOfBaseType :: BaseType -> Int+kindOfBaseType = \case+  TypeInteger         -> 4+  TypeReal            -> 4+  TypeDoublePrecision -> 8+  TypeComplex         -> 8+  TypeDoubleComplex   -> 16+  TypeLogical         -> 4+  TypeCharacter{}     -> 1+  TypeByte            -> 1++  -- arbitrary values (>F77 is not tested/used)+  TypeCustom{}        -> 1+  ClassStar           -> 1+  ClassCustom{}       -> 1++getTypeSize :: SemType -> Maybe Int+getTypeSize = \case+  TInteger      k   -> Just k+  TReal         k   -> Just k+  TComplex      k   -> Just k+  TLogical      k   -> Just k+  TByte         k   -> Just k+  TArray     ty _   -> getTypeSize ty+  TCustom       _   -> Just 1+  -- char: treat length as "kind" (but also use recorded kind)+  TCharacter (CharLenInt l) k -> Just (l * k)+  TCharacter _              _ -> Nothing++setTypeSize :: SemType -> Maybe Int -> SemType+setTypeSize ty mk = case (mk, ty) of+  (Just k, TInteger _  ) -> TInteger k+  (Just k, TReal _     ) -> TReal k+  (Just k, TComplex _  ) -> TComplex k+  (Just k, TLogical _  ) -> TLogical k+  (Just k, TByte _     ) -> TByte k+  (_     , TCustom s   ) -> TCustom s+  -- char: treat length as "kind"+  (Just l, TCharacter _ k) ->+    TCharacter (CharLenInt l) k+  (Nothing, TCharacter _ k) ->+    TCharacter CharLenStar k+  _ -> error $ "Tried to set invalid kind for type " <> show ty

@@ -1,7 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase          #-}+ module Language.Fortran.Analysis.Types-  ( analyseTypes, analyseTypesWithEnv, analyseAndCheckTypesWithEnv, extractTypeEnv, TypeEnv, TypeError )-where+  ( analyseTypes+  , analyseTypesWithEnv+  , analyseAndCheckTypesWithEnv+  , extractTypeEnv+  , TypeEnv+  , TypeError+  , deriveSemTypeFromDeclaration+  , deriveSemTypeFromTypeSpec+  , deriveSemTypeFromBaseType+  , runInfer+  , inferState0+  ) where  import Language.Fortran.AST @@ -15,10 +27,11 @@ import Data.Data import Data.Functor.Identity (Identity ()) import Language.Fortran.Analysis+import Language.Fortran.Analysis.SemanticTypes import Language.Fortran.Intrinsics import Language.Fortran.Util.Position-import Language.Fortran.ParserMonad (FortranVersion(..))-+import Language.Fortran.Version (FortranVersion(..))+import Language.Fortran.Parser.Utils  -------------------------------------------------- @@ -77,7 +90,7 @@    -- Gather types for known entry points.   eps <- gets (M.toList . entryPoints)-  _ <- forM eps $ \ (eName, (fName, mRetName)) -> do+  forM_ eps $ \ (eName, (fName, mRetName)) -> do     mFType <- getRecordedType fName     case mFType of       Just (IDType fVType fCType) -> do@@ -125,8 +138,12 @@     -- record some type information that we can glean     recordCType CTFunction n     case (mRetType, mRetVar) of-      (Just (TypeSpec _ _ baseType _), Just v) -> recordBaseType baseType n >> recordBaseType baseType (varName v)-      (Just (TypeSpec _ _ baseType _), _)      -> recordBaseType baseType n+      (Just ts@(TypeSpec _ _ _ _), Just v) -> do+        semType <- deriveSemTypeFromTypeSpec ts+        recordSemType semType n >> recordSemType semType (varName v)+      (Just ts@(TypeSpec _ _ _ _), _)      -> do+        semType <- deriveSemTypeFromTypeSpec ts+        recordSemType semType n       _                                        -> return ()     -- record entry points for later annotation     forM_ blocks $ \ block ->@@ -151,8 +168,8 @@                                                  return $ read i ]  statement :: Data a => InferFunc (Statement (Analysis a))--- maybe FIXME: should Kind Selectors be part of types?-statement (StDeclaration _ _ (TypeSpec _ _ baseType _) mAttrAList declAList)++statement (StDeclaration _ stmtSs ts@(TypeSpec _ _ _ _) mAttrAList declAList)   | mAttrs  <- maybe [] aStrip mAttrAList   , attrDim <- find isAttrDimension mAttrs   , isParam <- any isAttrParameter mAttrs@@ -165,16 +182,14 @@                 | Just (IDType _ (Just ct)) <- M.lookup n env                 , ct /= CTIntrinsic                           = ct                 | otherwise                                   = CTVariable-    let charLen (ExpValue _ _ (ValInteger i)) = CharLenInt (read i)-        charLen (ExpValue _ _ ValStar)        = CharLenStar-        charLen _                             = CharLenExp-    let bType (Just e)-          | TypeCharacter _ kind <- baseType = TypeCharacter (Just $ charLen e) kind-          | otherwise                        = TypeCharacter (Just $ charLen e) Nothing-        bType Nothing  = baseType     forM_ decls $ \ decl -> case decl of-      DeclArray _ _ v ddAList e _ -> recordType (bType e) (CTArray $ dimDeclarator ddAList) (varName v)-      DeclVariable _ _ v e _      -> recordType (bType e) (cType n) n where n = varName v+        DeclArray _ declSs v ddAList mLenExpr _ -> do+            let ct = CTArray $ dimDeclarator ddAList+            st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr+            recordType st ct (varName v)+        DeclVariable _ declSs v mLenExpr _      -> do+            st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr+            recordType st (cType n) n where n = varName v  statement (StExternal _ _ varAList) = do   let vars = aStrip varAList@@ -204,12 +219,23 @@ statement _ = return ()  annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))++-- handle the various literals annotateExpression e@(ExpValue _ _ (ValVariable _))    = maybe e (`setIDType` e) `fmap` getRecordedType (varName e) annotateExpression e@(ExpValue _ _ (ValIntrinsic _))   = maybe e (`setIDType` e) `fmap` getRecordedType (varName e)-annotateExpression e@(ExpValue _ _ (ValReal r))        = return $ realLiteralType r `setIDType` e-annotateExpression e@(ExpValue _ _ (ValComplex e1 e2)) = return $ complexLiteralType e1 e2 `setIDType` e-annotateExpression e@(ExpValue _ _ (ValInteger _))     = return $ IDType (Just TypeInteger) Nothing `setIDType` e-annotateExpression e@(ExpValue _ _ (ValLogical _))     = return $ IDType (Just TypeLogical) Nothing `setIDType` e+annotateExpression e@(ExpValue _ ss (ValReal r))        = do+    k <- deriveRealLiteralKind ss r+    return $ setSemType (TReal k) e+annotateExpression e@(ExpValue _ ss (ValComplex e1 e2)) = do+    st <- complexLiteralType ss e1 e2+    return $ setSemType st e+annotateExpression e@(ExpValue _ _ (ValInteger _))     =+    -- FIXME: in >F90, int lits can have kind info on end @_8@, same as real+    -- lits. We do parse this into the lit string, it is available to us.+    return $ setSemType (deriveSemTypeFromBaseType TypeInteger) e+annotateExpression e@(ExpValue _ _ (ValLogical _))     =+    return $ setSemType (deriveSemTypeFromBaseType TypeLogical) e+ annotateExpression e@(ExpBinary _ _ op e1 e2)          = flip setIDType e `fmap` binaryOpType (getSpan e) op e1 e2 annotateExpression e@(ExpUnary _ _ op e1)              = flip setIDType e `fmap` unaryOpType (getSpan e1) op e1 annotateExpression e@(ExpSubscript _ _ e1 idxAList)    = flip setIDType e `fmap` subscriptType (getSpan e) e1 idxAList@@ -220,80 +246,118 @@ annotateProgramUnit pu | Named n <- puName pu = maybe pu (`setIDType` pu) `fmap` getRecordedType n annotateProgramUnit pu                        = return pu -realLiteralType :: String -> IDType-realLiteralType r | 'd' `elem` r = IDType (Just TypeDoublePrecision) Nothing-                  | otherwise    = IDType (Just TypeReal) Nothing+-- | Derive the kind of a REAL literal constant.+--+-- Logic taken from HP's F90 reference pg.33, written to gfortran's behaviour.+-- Stays in the 'Infer' monad so it can report type errors+deriveRealLiteralKind :: SrcSpan -> String -> Infer Kind+deriveRealLiteralKind ss r =+    case realLitKindParam realLit of+      Nothing -> return kindFromExpOrDefault+      Just k  ->+        case realLitExponent realLit of+          Nothing  -> return k  -- no exponent, use kind param+          Just expo ->+            -- can only use kind param with 'e' or no exponent+            case expLetter expo of+              ExpLetterE -> return k+              _          -> do+                -- badly formed literal, but we'll allow and use the provided+                -- kind param (with no doubling or anything)+                typeError "only real literals with exponent letter 'e' can specify explicit kind parameter" ss+                return k+  where+    realLit = parseRealLiteral r+    kindFromExpOrDefault =+        case realLitExponent realLit of+          -- no exponent: select default real kind+          Nothing             -> 4+          Just expo           ->+            case expLetter expo of+              ExpLetterE -> 4+              ExpLetterD -> 8 -complexLiteralType :: Expression a -> Expression a -> IDType-complexLiteralType (ExpValue _ _ (ValReal r)) _- | IDType (Just TypeDoublePrecision) _ <- realLiteralType r = IDType (Just TypeDoubleComplex) Nothing- | otherwise                                                = IDType (Just TypeComplex) Nothing-complexLiteralType _ _ = IDType (Just TypeComplex) Nothing+-- | Get the type of a COMPLEX literal constant.+--+-- The kind is derived only from the first expression, the second is ignored.+complexLiteralType :: SrcSpan -> Expression a -> Expression a -> Infer SemType+complexLiteralType ss (ExpValue _ _ (ValReal r)) _ = do+    k1 <- deriveRealLiteralKind ss r+    return $ TComplex k1+complexLiteralType _ _ _ = return $ deriveSemTypeFromBaseType TypeComplex  binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType binaryOpType ss op e1 e2 = do-  mbt1 <- case getIDType e1 of-            Just (IDType (Just bt) _) -> return $ Just bt+  mst1 <- case getIDType e1 of+            Just (IDType (Just st) _) -> return $ Just st             _ -> typeError "Unable to obtain type for first operand" (getSpan e1) >> return Nothing-  mbt2 <- case getIDType e2 of-            Just (IDType (Just bt) _) -> return $ Just bt+  mst2 <- case getIDType e2 of+            Just (IDType (Just st) _) -> return $ Just st             _ -> typeError "Unable to obtain type for second operand" (getSpan e2) >> return Nothing-  case (mbt1, mbt2) of+  case (mst1, mst2) of     (_, Nothing) -> return emptyType     (Nothing, _) -> return emptyType-    (Just bt1, Just bt2) -> do-      mbt <- case (bt1, bt2) of-        (_                   , TypeDoubleComplex   ) -> return . Just $ TypeDoubleComplex-        (TypeDoubleComplex   , _                   ) -> return . Just $ TypeDoubleComplex-        (_                   , TypeComplex         ) -> return . Just $ TypeComplex-        (TypeComplex         , _                   ) -> return . Just $ TypeComplex-        (_                   , TypeDoublePrecision ) -> return . Just $ TypeDoublePrecision-        (TypeDoublePrecision , _                   ) -> return . Just $ TypeDoublePrecision-        (_                   , TypeReal            ) -> return . Just $ TypeReal-        (TypeReal            , _                   ) -> return . Just $ TypeReal-        (_                   , TypeInteger         ) -> return . Just $ TypeInteger-        (TypeInteger         , _                   ) -> return . Just $ TypeInteger-        (TypeByte            , TypeByte            ) -> return . Just $ TypeByte-        (TypeLogical         , TypeLogical         ) -> return . Just $ TypeLogical-        (TypeCustom _        , TypeCustom _        ) -> do-          typeError "custom types / binary op not supported" ss-          return Nothing-        (TypeCharacter l1 k1 , TypeCharacter l2 _ )-          | op == Concatenation -> return . Just $ TypeCharacter (liftM2 charLenConcat l1 l2) k1-          | op `elem` [EQ, NE]  -> return $ Just TypeLogical-          | otherwise -> do typeError "Invalid op on character strings" ss-                            return Nothing-        _ -> do typeError "Type error between operands of binary operator" ss-                return Nothing-      mbt' <- case mbt of-        Just bt+    (Just st1, Just st2) -> do+      mst  <- binopSimpleCombineSemTypes ss op st1 st2+      mst' <- case mst of+        Just st           | op `elem` [ Addition, Subtraction, Multiplication, Division-                      , Exponentiation, Concatenation, Or, XOr, And ]       -> return $ Just bt-          | op `elem` [GT, GTE, LT, LTE, EQ, NE, Equivalent, NotEquivalent] -> return $ Just TypeLogical+                      , Exponentiation, Concatenation, Or, XOr, And ]       -> return $ Just st+          | op `elem` [GT, GTE, LT, LTE, EQ, NE, Equivalent, NotEquivalent] -> return $ Just (deriveSemTypeFromBaseType TypeLogical)           | BinCustom{} <- op -> typeError "custom binary ops not supported" ss >> return Nothing         _ -> return Nothing -      return $ IDType mbt' Nothing+      return $ IDType mst' Nothing -- FIXME: might have to check kinds of each operand +-- | Combine two 'SemType's with a 'BinaryOp'.+--+-- No real work done here, no kind combining, just selection.+binopSimpleCombineSemTypes :: SrcSpan -> BinaryOp -> SemType -> SemType -> Infer (Maybe SemType)+binopSimpleCombineSemTypes ss op st1 st2 = do+    case (st1, st2) of+      (_           , TComplex k2) -> ret $ TComplex k2+      (TComplex k1, _           ) -> ret $ TComplex k1+      (_           , TReal    k2) -> ret $ TReal k2+      (TReal    k1, _           ) -> ret $ TReal k1+      (_           , TInteger k2) -> ret $ TInteger k2+      (TInteger k1, _           ) -> ret $ TInteger k1+      (TByte    k1, TByte     _ ) -> ret $ TByte k1+      (TLogical k1, TLogical  _ ) -> ret $ TLogical k1+      (TCustom  _, TCustom   _) -> do+        typeError "custom types / binary op not supported" ss+        return Nothing+      (TCharacter l1 k1, TCharacter l2 k2)+        | k1 /= k2 -> do typeError "operation on character strings of different kinds" ss+                         return Nothing+        | op == Concatenation -> ret $ TCharacter (charLenConcat l1 l2) k1+        | op `elem` [EQ, NE]  -> ret $ deriveSemTypeFromBaseType TypeLogical+        | otherwise -> do typeError "Invalid op on character strings" ss+                          return Nothing+      _ -> do typeError "Type error between operands of binary operator" ss+              return Nothing+  where+    ret = return . Just+ unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType unaryOpType ss op e = do-  mbt <- case getIDType e of-           Just (IDType (Just bt) _) -> return $ Just bt+  mst <- case getIDType e of+           Just (IDType (Just st) _) -> return $ Just st            _ -> typeError "Unable to obtain type for" (getSpan e) >> return Nothing-  mbt' <- case (mbt, op) of+  mst' <- case (mst, op) of     (Nothing, _)               -> return Nothing-    (Just TypeCustom{}, _)     -> typeError "custom types / unary ops not supported" ss >> return Nothing+    (Just TCustom{}, _)        -> typeError "custom types / unary ops not supported" ss >> return Nothing     (_, UnCustom{})            -> typeError "custom unary ops not supported" ss >> return Nothing-    (Just TypeLogical, Not)    -> return $ Just TypeLogical-    (Just bt, _)+    (Just st@(TLogical _), Not)    -> return $ Just st+    (Just st, _)       | op `elem` [Plus, Minus] &&-        bt `elem` numericTypes -> return $ Just bt+        isNumericType st -> return $ Just st     _ -> typeError "Type error for unary operator" ss >> return Nothing-  return $ IDType mbt' Nothing+  return $ IDType mst' Nothing -- FIXME: might have to check kind of operand  subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType subscriptType ss e1 (AList _ _ idxs) = do-  let isInteger ie | Just (IDType (Just TypeInteger) _) <- getIDType ie = True | otherwise = False+  let isInteger ie | Just (IDType (Just (TInteger _)) _) <- getIDType ie = True+                   | otherwise = False   forM_ idxs $ \ idx -> case idx of     IxSingle _ _ _ ie       | not (isInteger ie) -> typeError "Invalid or unknown type for index" (getSpan ie)@@ -303,11 +367,11 @@       | Just ie3 <- mie3, not (isInteger ie3) -> typeError "Invalid or unknown type for index" (getSpan ie3)     _ -> return ()   case getIDType e1 of-    Just ty@(IDType mbt (Just (CTArray dds))) -> do+    Just ty@(IDType mst (Just (CTArray dds))) -> do       when (length idxs /= length dds) $ typeError "Length of indices does not match rank of array." ss       let isSingle (IxSingle{}) = True; isSingle _ = False       if all isSingle idxs-        then return $ IDType mbt Nothing+        then return $ IDType mst Nothing         else return ty     _ -> return emptyType @@ -318,37 +382,36 @@   case mRetType of     Nothing -> return emptyType     Just retType -> do-      mbt <- case retType of-            ITReal      -> return $ Just TypeReal-            ITInteger   -> return $ Just TypeInteger-            ITComplex   -> return $ Just TypeComplex-            ITDouble    -> return $ Just TypeDoublePrecision-            ITLogical   -> return $ Just TypeLogical-            ITCharacter -> return . Just $ TypeCharacter Nothing Nothing+      mst <- case retType of+            ITReal      -> wrapBaseType TypeReal+            ITInteger   -> wrapBaseType TypeInteger+            ITComplex   -> wrapBaseType TypeComplex+            ITDouble    -> wrapBaseType TypeDoublePrecision+            ITLogical   -> wrapBaseType TypeLogical+            ITCharacter -> wrapBaseType TypeCharacter             ITParam i               | length params >= i, Argument _ _ _ e <- params !! (i-1)                 -> return $ idVType =<< getIDType e               | otherwise -> typeError ("Invalid parameter list to intrinsic '" ++ n ++ "'") ss >> return Nothing-      case mbt of+      case mst of         Nothing -> return emptyType-        Just _ -> return $ IDType mbt Nothing+        Just _ -> return $ IDType mst Nothing+  where+    wrapBaseType :: Monad m => BaseType -> m (Maybe SemType)+    wrapBaseType = return . Just . deriveSemTypeFromBaseType+ functionCallType ss e1 _ = case getIDType e1 of-  Just (IDType (Just bt) (Just CTFunction)) -> return $ IDType (Just bt) Nothing-  Just (IDType (Just bt) (Just CTExternal)) -> return $ IDType (Just bt) Nothing+  Just (IDType (Just st) (Just CTFunction)) -> return $ IDType (Just st) Nothing+  Just (IDType (Just st) (Just CTExternal)) -> return $ IDType (Just st) Nothing   _ -> typeError "non-function invoked by call" ss >> return emptyType -charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen-charLenConcat l1 l2 = case (l1, l2) of-  (CharLenExp    , _             ) -> CharLenExp-  (_             , CharLenExp    ) -> CharLenExp-  (CharLenStar   , _             ) -> CharLenStar-  (_             , CharLenStar   ) -> CharLenStar-  (CharLenColon  , _             ) -> CharLenColon-  (_             , CharLenColon  ) -> CharLenColon-  (CharLenInt i1 , CharLenInt i2 ) -> CharLenInt (i1 + i2)--numericTypes :: [BaseType]-numericTypes = [TypeDoubleComplex, TypeComplex, TypeDoublePrecision, TypeReal, TypeInteger, TypeByte]+isNumericType :: SemType -> Bool+isNumericType = \case+  TComplex{} -> True+  TReal{}    -> True+  TInteger{} -> True+  TByte{}    -> True+  _            -> False  -------------------------------------------------- -- Monadic helper combinators.@@ -366,22 +429,22 @@ emptyType = IDType Nothing Nothing  -- Record the type of the given name.-recordType :: BaseType -> ConstructType -> Name -> Infer ()-recordType bt ct n = modify $ \ s -> s { environ = insert n (IDType (Just bt) (Just ct)) (environ s) }+recordType :: SemType -> ConstructType -> Name -> Infer ()+recordType st ct n = modify $ \ s -> s { environ = insert n (IDType (Just st) (Just ct)) (environ s) }  -- Record the type (maybe) of the given name.-recordMType :: Maybe BaseType -> Maybe ConstructType -> Name -> Infer ()-recordMType bt ct n = modify $ \ s -> s { environ = insert n (IDType bt ct) (environ s) }+recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer ()+recordMType st ct n = modify $ \ s -> s { environ = insert n (IDType st ct) (environ s) }  -- Record the CType of the given name. recordCType :: ConstructType -> Name -> Infer () recordCType ct n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }   where changeFunc mIDType = Just (IDType (mIDType >>= idVType) (Just ct)) --- Record the BaseType of the given name.-recordBaseType :: BaseType -> Name -> Infer ()-recordBaseType bt n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }-  where changeFunc mIDType = Just (IDType (Just bt) (mIDType >>= idCType))+-- Record the SemType of the given name.+recordSemType :: SemType -> Name -> Infer ()+recordSemType st n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }+  where changeFunc mIDType = Just (IDType (Just st) (mIDType >>= idCType))  recordEntryPoint :: Name -> Name -> Maybe Name -> Infer () recordEntryPoint fn en mRetName = modify $ \ s -> s { entryPoints = M.insert en (fn, mRetName) (entryPoints s) }@@ -393,12 +456,25 @@ setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a) setIDType ty x   | a@Analysis {} <- getAnnotation x = setAnnotation (a { idType = Just ty }) x-  | otherwise                          = x+  | otherwise                        = x  -- Get the idType annotation getIDType :: (Annotated f, Data a) => f (Analysis a) -> Maybe IDType getIDType x = idType (getAnnotation x) +-- | For all types holding an 'IDType' (in an 'Analysis'), set the 'SemType'+--   field of the 'IDType'.+setSemType :: (Annotated f, Data a) => SemType -> f (Analysis a) -> f (Analysis a)+setSemType st x =+    let anno  = getAnnotation x+        idt   = idType anno+        anno' = anno { idType = Just (setIDTypeSemType idt) }+     in setAnnotation anno' x+  where+    setIDTypeSemType :: Maybe IDType -> IDType+    setIDTypeSemType (Just (IDType _ mCt)) = IDType (Just st) mCt+    setIDTypeSemType Nothing               = IDType (Just st) Nothing+ -- Set the CType part of idType annotation --setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a) --setCType ct x@@ -425,15 +501,161 @@  isAttrParameter :: Attribute a -> Bool isAttrParameter AttrParameter {} = True-isAttrParameter _                  = False+isAttrParameter _                = False  isAttrExternal :: Attribute a -> Bool isAttrExternal AttrExternal {} = True-isAttrExternal _                 = False+isAttrExternal _               = False  isIxSingle :: Index a -> Bool isIxSingle IxSingle {} = True-isIxSingle _             = False+isIxSingle _           = False++--------------------------------------------------++-- Most, but not all deriving functions can report type errors. So most of these+-- functions are in the Infer monad.++-- | Attempt to derive the 'SemType' of a variable from the relevant parts of+--   its surrounding 'StDeclaration'.+--+-- This is an example of a simple declaration:+--+--     INTEGER(8) :: var_name+--+-- A declaration holds a 'TypeSpec' (left of the double colon; LHS) and a list+-- of 'Declarator's (right of the double colon; RHS). However, CHARACTER+-- variable are allowed to specify their length via special syntax on the RHS:+--+--     CHARACTER :: string*10+--+-- so to handle that, this function takes that length as a Maybe Expression (as+-- provided in 'StDeclaration').+--+-- If a length was defined on both sides, the declaration length (RHS) is used.+-- This matches gfortran's behaviour, though even with -Wall they don't warn on+-- this rather confusing syntax usage. We report a (soft) type error.+deriveSemTypeFromDeclaration+    :: SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType+deriveSemTypeFromDeclaration stmtSs declSs ts@(TypeSpec _ _ bt mSel) mLenExpr =+    case mLenExpr of+      Nothing ->+        -- no RHS length, can continue with regular deriving+        deriveSemTypeFromTypeSpec ts++      Just lenExpr ->+        -- we got a RHS length; only CHARACTERs permit this+        case bt of+          TypeCharacter -> deriveCharWithLen lenExpr+          _ -> do+            -- can't use RHS @var*length = x@ syntax on non-CHARACTER: complain,+            -- continue regular deriving without length+            flip typeError declSs $+                "non-CHARACTER variable at declaration "+             <> show stmtSs+             <> " given a length"+            deriveSemTypeFromTypeSpec ts+  where+    -- Function called when we have a TypeCharacter and a RHS declarator length.+    -- (no function signature due to type variable scoping)+    --deriveCharWithLen :: Expression a -> Infer SemType+    deriveCharWithLen lenExpr =+        case mSel of+          Just (Selector selA selSs mSelLenExpr mKindExpr) -> do+            _ <- case mSelLenExpr of+                   Just _ -> do+                      -- both LHS & RHS lengths: surprising syntax, notify user+                      -- Ben has seen this IRL: a high-ranking Fortran+                      -- tutorial site uses it (2021-04-30):+                      -- http://web.archive.org/web/20210118202503/https://www.tutorialspoint.com/fortran/fortran_strings.htm+                     flip typeError declSs $+                         "warning: CHARACTER variable at declaration "+                      <> show stmtSs+                      <> " has length in LHS type spec and RHS declarator"+                      <> " -- specific RHS declarator overrides"+                   _ -> return ()+            -- overwrite the Selector with RHS length expr & continue+            let sel' = Selector selA selSs (Just lenExpr) mKindExpr+            deriveSemTypeFromBaseTypeAndSelector TypeCharacter sel'+          Nothing ->+            -- got RHS len, no Selector (e.g. @CHARACTER :: x*3 = "sup"@)+            -- naughty let binding to avoid re-hardcoding default char kind+            let (TCharacter _ k) = deriveSemTypeFromBaseType TypeCharacter+             in return $ TCharacter (charLenSelector' lenExpr) k++-- | Attempt to derive a 'SemType' from a 'TypeSpec'.+deriveSemTypeFromTypeSpec :: TypeSpec a -> Infer SemType+deriveSemTypeFromTypeSpec (TypeSpec _ _ bt mSel) =+    case mSel of+      -- Selector present: we might have kind/other info provided+      Just sel -> deriveSemTypeFromBaseTypeAndSelector bt sel+      -- no Selector: derive using default kinds etc.+      Nothing  -> return $ deriveSemTypeFromBaseType bt++-- | Attempt to derive a SemType from a 'BaseType' and a 'Selector'.+deriveSemTypeFromBaseTypeAndSelector :: BaseType -> Selector a -> Infer SemType+deriveSemTypeFromBaseTypeAndSelector bt (Selector _ ss mLen mKindExpr) = do+    st <- deriveFromBaseTypeAndKindExpr mKindExpr+    case mLen of+      Nothing      -> return st+      Just lenExpr ->+        case st of+          TCharacter _ kind ->+            let charLen = charLenSelector' lenExpr+             in return $ TCharacter charLen kind+          _ -> do+            -- (unreachable code path in correct parser operation)+            typeError "only CHARACTER types can specify length (separate to kind)" ss+            return st+  where+    deriveFromBaseTypeAndKindExpr :: Maybe (Expression a) -> Infer SemType+    deriveFromBaseTypeAndKindExpr = \case+      Nothing -> defaultSemType+      Just kindExpr ->+        case kindExpr of+          -- FIXME: only support integer kind selectors for now, no params/exprs+          -- (would require a wide change across codebase)+          ExpValue _ _ (ValInteger k) ->+            deriveSemTypeFromBaseTypeAndKind bt (read k)+          _ -> do+            typeError "unsupported or invalid kind selector, only literal integers allowed" (getSpan kindExpr)+            defaultSemType+    defaultSemType = return $ deriveSemTypeFromBaseType bt++-- | Derive 'SemType' directly from 'BaseType', using relevant default kinds.+deriveSemTypeFromBaseType :: BaseType -> SemType+deriveSemTypeFromBaseType = \case+  TypeInteger         -> TInteger 4+  TypeReal            -> TReal    4+  TypeComplex         -> TComplex 4+  TypeLogical         -> TLogical 4++  -- Fortran specs & compilers seem to agree on equating these intrinsic types+  -- to others with a larger kind, so we drop the extra syntactic info here.+  TypeDoublePrecision -> TReal    8+  TypeDoubleComplex   -> TComplex 8++  -- BYTE: HP's Fortran 90 reference says that BYTE is an HP extension, equates+  -- it to INTEGER(1), and indicates that it doesn't take a kind selector.+  -- Don't know how BYTEs are used in the wild. I wonder if we could safely+  -- equate BYTE to (TInteger 1)?+  TypeByte            -> TByte    noKind++  -- CHARACTERs default to len=1, kind=1 (non-1 is rare)+  TypeCharacter       -> TCharacter (CharLenInt 1) 1++  -- FIXME: this is where Fortran specs diverge, and fortran-vars doesn't+  -- support beyond F77e. Sticking with what passes the fortran-vars tests.+  ClassStar           -> TCustom "ClassStar"+  TypeCustom    str   -> TCustom str+  ClassCustom   str   -> TCustom str++noKind :: Kind+noKind = -1++deriveSemTypeFromBaseTypeAndKind :: BaseType -> Kind -> Infer SemType+deriveSemTypeFromBaseTypeAndKind bt k =+    return $ setTypeKind (deriveSemTypeFromBaseType bt) k  -------------------------------------------------- 

@@ -1144,6 +1144,7 @@   | TComment            SrcSpan String   | TString             SrcSpan String   | TIntegerLiteral     SrcSpan String+  -- | TRealLiteral        SrcSpan String (Maybe RealExponent) (Maybe KindParam)   | TRealLiteral        SrcSpan String   | TBozLiteral         SrcSpan String   | TComma              SrcSpan

@@ -1012,9 +1012,9 @@ TYPE_SPEC :: { TypeSpec A0 } : integer KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 } | real    KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }-| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }+| doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing } | complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 } | logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } | type '(' id ')'   { let TId _ id = $3

@@ -1020,17 +1020,15 @@  TYPE_SPEC :: { TypeSpec A0 } TYPE_SPEC-: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }-| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  }-| doublePrecision KIND_SELECTOR-  { TypeSpec () (getSpan ($1, $2)) TypeDoublePrecision $2 }-| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }-| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }-| doubleComplex KIND_SELECTOR-  { TypeSpec () (getSpan ($1, $2)) TypeDoubleComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 }-| byte KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 }-| record '/' NAME '/' { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }+: integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  }+| doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing}+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }+| doubleComplex           { TypeSpec () (getSpan $1)       TypeDoubleComplex Nothing}+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| byte      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 }+| record    '/' NAME '/'  { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }  KIND_SELECTOR :: { Maybe (Selector A0) } KIND_SELECTOR

@@ -868,13 +868,13 @@     in DimensionDeclarator () span Nothing Nothing }  TYPE_SPEC :: { TypeSpec A0 }-: integer KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }-| real    KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }-| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }-| complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 }-| logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }-| type '(' id ')'+: integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }+| doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing }+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| type      '(' id ')'   { let TId _ id = $3     in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing } 

@@ -881,13 +881,13 @@     in DimensionDeclarator () span Nothing Nothing }  TYPE_SPEC :: { TypeSpec A0 }-: integer KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }-| real    KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }-| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }-| complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 }-| logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }-| type '(' id ')'+: integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }+| doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing }+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| type      '(' id ')'   { let TId _ id = $3     in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing } 

@@ -1,7 +1,21 @@+{-# LANGUAGE LambdaCase #-}+ {-| Simple module to provide functions that read Fortran literals -}-module Language.Fortran.Parser.Utils (readReal, readInteger) where+module Language.Fortran.Parser.Utils+  ( readReal+  , readInteger+  , parseRealLiteral+  , RealLit(..)+  , Exponent(..)+  , NumSign(..)+  , ExponentLetter(..)+  ) where++import Language.Fortran.AST (Kind)+ import Data.Char import Numeric+import Text.Read (readMaybe)  breakAtDot :: String -> (String, String) replaceDwithE :: Char -> Char@@ -41,3 +55,78 @@ readsToMaybe r = case r of   (x, _):_ -> Just x   _ -> Nothing++--------------------------------------------------------------------------------++-- TODO limitation+-- Kind params allow 'Name's as well (which are checked at compile time to be a+-- special type of constant expression). We limit ourselves to integer kind+-- params only, because currently we don't handle full kind params in the later+-- stages anyway.+type KindParam = Kind++-- | A REAL literal may have an optional exponent and kind.+--+-- The value can be retrieved as a 'Double' by using these parts.+data RealLit = RealLit+  { realLitValue     :: String -- xyz.abc, xyz, xyz., .abc+  , realLitExponent  :: Maybe Exponent+  , realLitKindParam :: Maybe KindParam+  } deriving (Eq, Ord, Show)++-- | An exponent is an exponent letter (E, D) and a value (with an optional+-- sign).+data Exponent = Exponent+  { expLetter :: ExponentLetter+  , expSign   :: Maybe NumSign+  , expNum    :: Int+  } deriving (Eq, Ord, Show)++-- Note: Some Fortran language references include extensions here. HP's F90+-- reference provides a Q exponent letter which sets kind to 16.+data ExponentLetter+  = ExpLetterD+  | ExpLetterE+    deriving (Eq, Ord, Show)++data NumSign+  = SignPos+  | SignNeg+    deriving (Eq, Ord, Show)++-- | Parse a Fortran literal real to its constituent parts.+parseRealLiteral :: String -> RealLit+parseRealLiteral r =+    RealLit { realLitValue     = takeWhile isValuePart r+            , realLitExponent  = parseRealLitExponent (dropWhile isValuePart r)+            , realLitKindParam = parseRealLitKindInt (dropWhile (/= '_') r)+            }+  where+    -- slightly ugly: we add the signs in here to allow -1.0 easily+    isValuePart :: Char -> Bool+    isValuePart ch+      | isDigit ch                 = True+      | ch `elem` ['.', '-', '+']  = True+      | otherwise                  = False+    parseRealLitKindInt :: String -> Maybe Kind+    parseRealLitKindInt = \case+      '_':chs -> readMaybe chs+      _       -> Nothing+    parseRealLitExponent :: String -> Maybe Exponent+    parseRealLitExponent "" = Nothing+    parseRealLitExponent (c:cs) = do+        letter <-+                case toLower c of+                  'e' -> Just ExpLetterE+                  'd' -> Just ExpLetterD+                  _   -> Nothing+        let (sign, cs'') =+                case cs of+                  ""       -> (Nothing, cs)+                  c':cs'  -> -- TODO: want to locally scope cs' but unsure how to??+                    case c' of+                      '-' -> (Just SignNeg, cs')+                      '+' -> (Just SignPos, cs')+                      _   -> (Nothing     , cs)+            digitStr = read (takeWhile isDigit cs'')+        return $ Exponent letter sign digitStr

@@ -12,7 +12,7 @@ import Prelude hiding (EQ,LT,GT,pred,exp,(<>))  import Language.Fortran.AST-import Language.Fortran.ParserMonad+import Language.Fortran.Version import Language.Fortran.Util.FirstParameter  import Text.PrettyPrint@@ -353,7 +353,7 @@       | v == Fortran77Extended = "double complex"       | otherwise = tooOld v "Double complex" Fortran77Extended     pprint' _ TypeLogical = "logical"-    pprint' v (TypeCharacter _ _)+    pprint' v TypeCharacter       | v >= Fortran77 = "character"       | otherwise = tooOld v "Character data type" Fortran77     pprint' v (TypeCustom str)@@ -369,12 +369,6 @@     pprint' v (ClassCustom str)       | v >= Fortran2003 = "class" <> parens (text str)       | otherwise = tooOld v "Class(spec)" Fortran2003--instance Pretty CharacterLen where-  pprint' _ CharLenStar = "*"-  pprint' _ CharLenColon = ":"-  pprint' _ CharLenExp  = "*" -- FIXME, possibly, with a more robust const-exp-  pprint' _ (CharLenInt i) = text (show i)  instance Pretty (TypeSpec a) where     pprint' v (TypeSpec _ _ baseType mSelector) =

@@ -18,7 +18,7 @@     trans = transformBi :: Data a => TransFunc Expression ProgramFile a     expression (ExpValue a s (ValVariable v))       | Just (IDType _ (Just CTIntrinsic)) <- idType a = ExpValue a s (ValIntrinsic v)-    expression e                                      = e+    expression e                                         = e  -------------------------------------------------- 

@@ -327,8 +327,10 @@ showModuleMap :: ModuleMap -> String showModuleMap = concatMap (\ (n, m) -> show n ++ ":\n" ++ (unlines . map ("  "++) . lines . showGenericMap $ m)) . M.toList showTypes :: TypeEnv -> String-showTypes tenv = flip concatMap (M.toList tenv) $ \ (name, IDType { idVType = vt, idCType = ct }) ->-    printf "%s\t\t%s %s\n" name (drop 4 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct)+showTypes tenv =+    flip concatMap (M.toList tenv) $+      \ (name, IDType { idVType = vt, idCType = ct }) ->+        printf "%s\t\t%s %s\n" name (drop 3 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct) printTypes :: TypeEnv -> IO () printTypes = putStrLn . showTypes showTypeErrors :: [TypeError] -> String

@@ -0,0 +1,31 @@+module Language.Fortran.Analysis.SemanticTypesSpec where++import Test.Hspec+import TestUtil++import Language.Fortran.Analysis.SemanticTypes+import Language.Fortran.AST+import Language.Fortran.Version++spec :: Spec+spec = do+  describe "Semantic types" $ do+    it "recovers DOUBLE PRECISION for REAL(8) in Fortran 77" $ do+      let semtype  = TReal 8+          typespec = TypeSpec () u TypeDoublePrecision Nothing+       in recoverSemTypeTypeSpec () u Fortran77 semtype `shouldBe` typespec++    it "recovers DOUBLE COMPLEX for COMPLEX(16) in Fortran 77" $ do+      let semtype  = TComplex 16+          typespec = TypeSpec () u TypeDoubleComplex Nothing+       in recoverSemTypeTypeSpec () u Fortran77 semtype `shouldBe` typespec++    it "recovers REAL(8) for REAL(8) in Fortran 90" $ do+      let semtype  = TReal 8+          typespec = TypeSpec () u TypeReal (Just (Selector () u Nothing (Just (ExpValue () u (ValInteger "8")))))+       in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec++    it "recovers CHARACTER(*)" $ do+      let semtype  = TCharacter CharLenStar 1+          typespec = TypeSpec () u TypeCharacter (Just (Selector () u (Just (ExpValue () u ValStar)) Nothing))+       in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec

@@ -8,9 +8,10 @@ import Data.Data import Data.Generics.Uniplate.Data import Language.Fortran.AST+import Language.Fortran.Analysis import Language.Fortran.Analysis.Types+import Language.Fortran.Analysis.SemanticTypes import Language.Fortran.Analysis.Renaming-import Language.Fortran.Analysis import qualified Language.Fortran.Parser.Fortran90 as F90 import Language.Fortran.ParserMonad import qualified Data.ByteString.Char8 as B@@ -27,16 +28,21 @@ uniExpr :: ProgramFile (Analysis A0) -> [Expression (Analysis A0)] uniExpr = universeBi +-- | Get the default 'SemType' for the given 'BaseType' (i.e. get its 'SemType'+--   and use the default kind).+defSTy :: BaseType -> SemType+defSTy = deriveSemTypeFromBaseType+ spec :: Spec spec = do   describe "Global type inference" $ do     it "types integer returning function" $ do       let entry = inferTable ex1 ! "f1"-      entry `shouldBe` IDType (Just TypeInteger) (Just CTFunction)+      entry `shouldBe` IDType (Just (defSTy TypeInteger)) (Just CTFunction)      it "types multiples program units" $ do       let mapping = inferTable ex2-      mapping ! "f1" `shouldBe` IDType (Just TypeInteger) (Just CTFunction)+      mapping ! "f1" `shouldBe` IDType (Just (defSTy TypeInteger)) (Just CTFunction)       mapping ! "s1" `shouldBe` IDType Nothing (Just CTSubroutine)      it "types ENTRY points within subprograms" $ do@@ -49,15 +55,14 @@     it "infers from type declarations" $ do       let mapping = inferTable ex4       let pf = typedProgramFile ex4-      mapping ! "x" `shouldBe` IDType (Just TypeInteger) (Just CTVariable)-      mapping ! "y" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 10)])-      mapping ! "c" `shouldBe` IDType (Just $ TypeCharacter Nothing Nothing) (Just CTVariable)-      mapping ! "log" `shouldBe` IDType (Just TypeLogical) (Just CTVariable)+      mapping ! "y" `shouldBe` IDType (Just (defSTy TypeInteger)) (Just $ CTArray [(Nothing, Just 10)])+      mapping ! "c" `shouldBe` IDType (Just (defSTy TypeCharacter)) (Just CTVariable)+      mapping ! "log" `shouldBe` IDType (Just (defSTy TypeLogical)) (Just CTVariable)       [ () | ExpValue a _ (ValVariable "x") <- uniExpr pf-           , idType a == Just (IDType (Just TypeInteger) (Just CTVariable)) ]+           , idType a == Just (IDType (Just (defSTy TypeInteger)) (Just CTVariable)) ]         `shouldNotSatisfy` null       [ () | ExpValue a _ (ValVariable "y") <- uniExpr pf-           , idType a == Just (IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 10)])) ]+           , idType a == Just (IDType (Just (defSTy TypeInteger)) (Just $ CTArray [(Nothing, Just 10)])) ]         `shouldNotSatisfy` null      it "infers from dimension declarations" $ do@@ -67,9 +72,9 @@      it "infers from function statements" $ do       let mapping = inferTable ex6-      mapping ! "a" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 1)])-      mapping ! "b" `shouldBe` IDType (Just TypeInteger) (Just $ CTArray [(Nothing, Just 1)])-      mapping ! "c" `shouldBe` IDType (Just TypeInteger) (Just CTFunction)+      mapping ! "a" `shouldBe` IDType (Just (defSTy TypeInteger)) (Just $ CTArray [(Nothing, Just 1)])+      mapping ! "b" `shouldBe` IDType (Just (defSTy TypeInteger)) (Just $ CTArray [(Nothing, Just 1)])+      mapping ! "c" `shouldBe` IDType (Just (defSTy TypeInteger)) (Just CTFunction)       mapping ! "d" `shouldBe` IDType Nothing (Just CTFunction)      describe "Intrinsics type analysis" $ do@@ -77,7 +82,7 @@         let mapping = inferTable intrinsics1         let pf = typedProgramFile intrinsics1         [ () | ExpValue a _ (ValVariable "x") <- uniExpr pf-             , idType a == Just (IDType (Just TypeReal) (Just CTVariable)) ]+             , idType a == Just (IDType (Just (defSTy TypeReal)) (Just CTVariable)) ]           `shouldSatisfy` ((== 5) . length)          -- the following are true because dabs and cabs are defined as function and array in this program.@@ -94,7 +99,7 @@         -- abs is an actual intrinsic         idCType (mapping ! "abs") `shouldBe` Just CTIntrinsic         [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeInteger) Nothing) ]+            , idType a == Just (IDType (Just (defSTy TypeInteger)) Nothing) ]           `shouldNotSatisfy` null        it "intrinsics and numeric types" $ do@@ -105,41 +110,42 @@         idCType (mapping ! "dabs") `shouldBe` Just CTIntrinsic         [ ty | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf              , Just (IDType (Just ty) Nothing) <- [idType a] ]-          `shouldBe` [TypeDoublePrecision, TypeComplex]+          `shouldBe` [defSTy TypeDoublePrecision, defSTy TypeComplex]         [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "cabs")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeComplex) Nothing) ]+            , idType a == Just (IDType (Just (defSTy TypeComplex)) Nothing) ]           `shouldNotSatisfy` null         [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "dabs")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeDoublePrecision) Nothing) ]+            , idType a == Just (IDType (Just (defSTy TypeDoublePrecision)) Nothing) ]           `shouldNotSatisfy` null      describe "Numeric types" $ do       it "Widening / upgrading" $ do         let pf = typedProgramFile numerics1         [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeReal) Nothing) ]+            , idType a == Just (IDType (Just (defSTy TypeReal)) Nothing) ]           `shouldNotSatisfy` null         [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "1")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeComplex) Nothing) ]+            , idType a == Just (IDType (Just (defSTy TypeComplex)) Nothing) ]           `shouldNotSatisfy` null         [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "2")) _ <- uniExpr pf-            , idType a == Just (IDType (Just TypeDoublePrecision) Nothing) ]+            , idType a == Just (IDType (Just (TReal 8)) Nothing) ]           `shouldNotSatisfy` null      describe "Character string types" $       it "examples of various character variables" $ do         let mapping = inferTable teststrings1-        idVType (mapping ! "a") `shouldBe` Just (TypeCharacter (Just (CharLenInt 5)) (Just "1"))-        idVType (mapping ! "b") `shouldBe` Just (TypeCharacter (Just (CharLenInt 10)) Nothing)-        idVType (mapping ! "c") `shouldBe` Just (TypeCharacter (Just (CharLenInt 3)) (Just "1"))-        idVType (mapping ! "d") `shouldBe` Just (TypeCharacter (Just CharLenExp) Nothing)+        idVType (mapping ! "a") `shouldBe` Just (TCharacter (CharLenInt 5) 1)+        idVType (mapping ! "b") `shouldBe` Just (TCharacter (CharLenInt 10) 1)+        idVType (mapping ! "c") `shouldBe` Just (TCharacter (CharLenInt 3) 1)+        idVType (mapping ! "d") `shouldBe` Just (TCharacter CharLenExp 1)         idCType (mapping ! "d") `shouldBe` Just (CTArray [(Nothing, Just 10)])-        idVType (mapping ! "e") `shouldBe` Just (TypeCharacter (Just (CharLenInt 10)) Nothing)+        idVType (mapping ! "e") `shouldBe` Just (TCharacter (CharLenInt 10) 1)         idCType (mapping ! "e") `shouldBe` Just (CTArray [(Nothing, Just 20)])+        idVType (mapping ! "f") `shouldBe` Just (TCharacter (CharLenInt 1) 2)         let pf = typedProgramFile teststrings1         [ () | ExpValue a _ (ValVariable "e") <- uniExpr pf-             , idType a == Just (IDType (Just (TypeCharacter (Just (CharLenInt 10)) Nothing))-                                        (Just (CTArray [(Nothing, Just 20)]))) ]+             , idType a == Just (IDType (Just (TCharacter (CharLenInt 10) 1))+                                        (Just (CTArray [(Nothing, Just 20)])))]           `shouldNotSatisfy` null  ex1 :: ProgramFile ()@@ -173,7 +179,7 @@         [ DeclVariable () u (varGen "x") Nothing Nothing         , DeclArray () u (varGen "y")             (AList () u [ DimensionDeclarator () u Nothing (Just $ intGen 10) ]) Nothing Nothing ]))-  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing+  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing       (AList () u [ DeclVariable () u (varGen "c") Nothing Nothing ]))   , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeLogical Nothing) Nothing       (AList () u [ DeclVariable () u (varGen "log") Nothing Nothing ])) ]@@ -296,6 +302,7 @@   , "  integer, parameter :: k = 8"   , "  character(k), dimension(10) :: d"   , "  character :: e(20)*10"+  , "  character(kind=2) :: f"   , "end program teststrings"   ] 

@@ -122,14 +122,14 @@        it "parses allocate with type_spec" $ do         let sel = Selector () u (Just (ExpValue () u ValColon)) (Just (varGen "foo"))-        let ty = TypeSpec () u (TypeCharacter (Just $ CharLenColon) (Just "foo")) (Just sel)+        let ty = TypeSpec () u TypeCharacter (Just sel)         let decls = [DeclVariable () u (varGen "s") Nothing Nothing]         let st = StDeclaration () u ty (Just (AList () u [AttrAllocatable () u])) (AList () u decls)         sParser "character(len=:,kind=foo), allocatable :: s" `shouldBe'` st        it "parses allocate with type_spec" $ do         let sel = Selector () u (Just (intGen 3)) (Just (varGen "foo"))-        let ty = TypeSpec () u (TypeCharacter (Just $ CharLenInt 3) (Just "foo")) (Just sel)+        let ty = TypeSpec () u TypeCharacter (Just sel)         let st = StAllocate () u (Just ty) (AList () u [varGen "s"]) Nothing         sParser "allocate(character(len=3,kind=foo) :: s)" `shouldBe'` st 

@@ -161,7 +161,7 @@       it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do         let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"]             sel = Selector () u (Just (intGen 30)) Nothing-            imp1 = ImpList () u (TypeSpec () u (TypeCharacter (Just $ CharLenInt 30) Nothing) (Just sel)) $ AList () u impEls+            imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just sel)) $ AList () u impEls             imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"]             st = StImplicit () u $ Just $ AList () u [imp1, imp2]         sParser "      implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st@@ -202,7 +202,7 @@      it "parses 'character a*8'" $ do       let decl = DeclVariable () u (varGen "a") (Just $ intGen 8) Nothing-          typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          typeSpec = TypeSpec () u TypeCharacter Nothing           st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])       sParser "      character a*8" `shouldBe'` st @@ -210,7 +210,7 @@       let args = AList () u [ IxSingle () u Nothing (ExpValue () u (ValString "A")) ]           lenExpr = ExpSubscript () u (ExpValue () u (ValVariable "ichar")) args           decl = DeclVariable () u (varGen "c") (Just $ lenExpr) Nothing-          typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          typeSpec = TypeSpec () u TypeCharacter Nothing           st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])       sParser "      character c*(ichar('A'))" `shouldBe'` st @@ -308,7 +308,7 @@        it "parses character declarations with unspecfied lengths" $ do         let src = "      character s*(*)"-            st = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $+            st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclVariable () u                                (ExpValue () u (ValVariable "s"))                                (Just (ExpValue () u ValStar))@@ -328,7 +328,7 @@          let src1 = "      character xs(2)*5 / 'hello', 'world' /"             inits1 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]-            st1 = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $+            st1 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclArray () u                                (ExpValue () u (ValVariable "xs"))                                (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])@@ -338,7 +338,7 @@          let src2 = "      character xs*5(2) / 'hello', 'world' /"             inits2 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]-            st2 = StDeclaration () u (TypeSpec () u (TypeCharacter Nothing Nothing) Nothing) Nothing $+            st2 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclArray () u                                (ExpValue () u (ValVariable "xs"))                                (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])

@@ -285,7 +285,7 @@           sParser "implicit none" `shouldBe'` st          it "parses implicit with single" $ do-          let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          let typeSpec = TypeSpec () u TypeCharacter Nothing           let impEls = [ ImpCharacter () u "k" ]           let impLists = [ ImpList () u typeSpec (fromList () impEls) ]           let st = StImplicit () u (Just $ fromList () impLists)@@ -299,7 +299,7 @@           sParser "implicit logical (x-z)" `shouldBe'` st          it "parses implicit statement" $ do-          let typeSpec1 = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing           let typeSpec2 = TypeSpec () u TypeInteger Nothing           let impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]           let impEls2 = [ ImpRange () u "x" "z" ]

@@ -337,7 +337,7 @@           sParser "implicit none" `shouldBe'` st          it "parses implicit with single" $ do-          let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          let typeSpec = TypeSpec () u TypeCharacter Nothing               impEls = [ ImpCharacter () u "k" ]               impLists = [ ImpList () u typeSpec (fromList () impEls) ]               st = StImplicit () u (Just $ fromList () impLists)@@ -351,7 +351,7 @@           sParser "implicit logical (x-z)" `shouldBe'` st          it "parses implicit statement" $ do-          let typeSpec1 = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing               typeSpec2 = TypeSpec () u TypeInteger Nothing               impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]               impEls2 = [ ImpRange () u "x" "z" ]

@@ -7,7 +7,8 @@ spec :: Spec spec =   describe "Fortran Parser Utils" $ do-    describe "readReal" $++    describe "readReal" $ do       it "tests" $ do         readReal "+12"       `shouldBe` Just 12         readReal "-1.2"      `shouldBe` Just (-1.2)@@ -17,7 +18,8 @@         readReal ".12"       `shouldBe` Just 0.12         readReal "-.12"      `shouldBe` Just (-0.12)         readReal "1_f"       `shouldBe` Just 1-    describe "readInteger" $++    describe "readInteger" $ do       it "tests" $ do         readInteger "b'101'" `shouldBe` Just 5         readInteger "o'22'"  `shouldBe` Just 18@@ -25,3 +27,54 @@         readInteger "1_f"    `shouldBe` Just 1         readInteger "+123"   `shouldBe` Just 123         readInteger "-123"   `shouldBe` Just (-123)++    describe "parseRealLiteral" $ do+      it "parses various well-formed valid real literals" $ do+        prl "1"         `shouldBe` rl "1"    n n+        prl "1."        `shouldBe` rl "1."   n n+        prl ".0"        `shouldBe` rl ".0"   n n+        prl "1e0"       `shouldBe` rl "1"    (jExp expE n 0) n+        prl "1e0_4"     `shouldBe` rl "1"    (jExp expE n 0) (j 4)+        --prl "1e0_k"     `shouldBe` rl "1" _ _+        prl "1.0e0_4"   `shouldBe` rl "1.0"  (jExp expE n 0) (j 4)+        prl "+1.0e0_4"  `shouldBe` rl "+1.0" (jExp expE n 0) (j 4)+        prl "-1.0e0_4"  `shouldBe` rl "-1.0" (jExp expE n 0) (j 4)+        prl "-1.0e+0_4" `shouldBe` rl "-1.0" (jExp expE (j SignPos) 0) (j 4)+        prl "-1.0e-0_4" `shouldBe` rl "-1.0" (jExp expE (j SignNeg) 0) (j 4)+        prl "-1.0d-0_4" `shouldBe` rl "-1.0" (jExp expD (j SignNeg) 0) (j 4)++      -- Literals we gladly parse, but that most Fortran specs consider invalid.+      -- These will prompt an error during type analysis.+      it "parses various well-formed invalid real literals" $ do+        -- only exponent letter e allows kind param+        -- even if you use kind 8 (== what d sets), it should be considered+        -- invalid+        prl "1d0_8"   `shouldBe` rl "1" (jExp expD n 0) (j 8)+        prl "1d0_4"   `shouldBe` rl "1" (jExp expD n 0) (j 4)++      -- parseRealLiteral runtime errors on poorly-formed real literals because+      -- the parser should ensure we only ever receive well-formed ones.+      -- TODO: unable to test these while the parser uses 'error'+      it "fails to parse poorly-formed real literals" $ do+        pending+        {-+        -- exponent number can't be empty+        fails $ prl "1e"++        -- exponent number must be an integer+        fails $ prl "1ex"+        fails $ prl "1ex1"+        --fails $ prl "1e0.0"       -- not detected, we take the digits before+                                    -- the decimal point+        -}+++      where+        prl = parseRealLiteral+        rl = RealLit+        n = Nothing+        j = Just+        jExp a b c = Just (Exponent a b c)+        expE = ExpLetterE+        expD = ExpLetterD+        fails test = return test `shouldThrow` anyException

@@ -106,7 +106,7 @@       describe "Declaration" $ do         it "prints 90 style with attributes" $ do           let sel = Selector () u (Just $ intGen 3) Nothing-          let typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) (Just sel)+          let typeSpec = TypeSpec () u TypeCharacter (Just sel)           let attrs = [ AttrIntent () u In , AttrPointer () u ]           let declList =                 [ DeclVariable () u (varGen "x") Nothing (Just $ intGen 42)@@ -254,7 +254,7 @@           it "prints allocate statement with type spec" $ do             let stat = AOStat () u (varGen "s")             let sel = Selector () u (Just (intGen 30)) Nothing-            let ty = TypeSpec () u (TypeCharacter (Just $ CharLenInt 30) Nothing) (Just sel)+            let ty = TypeSpec () u TypeCharacter (Just sel)             let st = StAllocate () u (Just ty) (AList () u [ varGen "x" ]) (Just (AList () u [stat]))             pprint Fortran2003 st Nothing `shouldBe` "allocate (character(len=30) :: x, stat=s)" 

@@ -3,7 +3,6 @@ import Test.Hspec import TestUtil -import Language.Fortran.Analysis import Language.Fortran.AST import Language.Fortran.Transformer