fortran-vars 0.3.0 → 0.3.1

raw patch · 25 files changed

+429/−341 lines, 25 filesdep ~aesondep ~fortran-srcdep ~fortran-src-extrasPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, fortran-src, fortran-src-extras

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−1
• fortran-vars.cabal +20/−10
• src/Language/Fortran/Vars/Assignments.hs +4/−4
• src/Language/Fortran/Vars/BozConstant.hs +51/−39
• src/Language/Fortran/Vars/Call.hs +5/−6
• src/Language/Fortran/Vars/CommonLayout.hs +1/−1
• src/Language/Fortran/Vars/Equivalence.hs +16/−7
• src/Language/Fortran/Vars/Eval.hs +7/−9
• src/Language/Fortran/Vars/Kind.hs +6/−9
• src/Language/Fortran/Vars/Memory.hs +18/−18
• src/Language/Fortran/Vars/MemoryLocation.hs +33/−31
• src/Language/Fortran/Vars/Operation.hs +17/−24
• src/Language/Fortran/Vars/Orphans.hs +21/−0
• src/Language/Fortran/Vars/PureExpression.hs +13/−1
• src/Language/Fortran/Vars/StructureTable.hs +4/−7
• src/Language/Fortran/Vars/SymbolTable.hs +29/−30
• src/Language/Fortran/Vars/TypeCheck.hs +101/−66
• src/Language/Fortran/Vars/Types.hs +10/−9
• src/Language/Fortran/Vars/Utils.hs +4/−7
• test/AssignmentsSpec.hs +6/−9
• test/BozConstantSpec.hs +11/−6
• test/StorageTableSpec.hs +4/−7
• test/StructureTableSpec.hs +17/−18
• test/SymbolTableSpec.hs +12/−13
• test/TypeCheckSpec.hs +10/−9

@@ -1,4 +1,12 @@-## 0.3.0 (10 Jan 2021)+## 0.3.1 (22 Aug 2022)+  * Update to fortran-src 0.10.2+  * Do some type checking for logical operators used with non LOGICAL arguments+    #6+  * Add type checking for `imag`, `lshift` intrinsics+  * MemoryLocation: change `getLocation` to return a `Maybe` type+  * Memory: expose `getTypeSize` function++## 0.3.0 (10 Jan 2022)   * Update to fortran-src 0.8.0   * Replace BozDecomposed with new Boz type in fortran-src     * Due to how the BozConstant module was used, this should have minimal

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-vars-version:        0.3.0+version:        0.3.1 synopsis:       Fortran memory model and other static analysis tools. description:    Various Fortran static analysis tools focusing on a memory model for Fortran types. Uses fortran-src for the syntax representation. category:       Language@@ -40,6 +40,7 @@       Language.Fortran.Vars.Memory       Language.Fortran.Vars.MemoryLocation       Language.Fortran.Vars.Operation+      Language.Fortran.Vars.Orphans       Language.Fortran.Vars.PureExpression       Language.Fortran.Vars.Range       Language.Fortran.Vars.StorageClass@@ -53,15 +54,18 @@       Paths_fortran_vars   hs-source-dirs:       src+  default-extensions:+      LambdaCase+      TypeApplications   build-depends:-      aeson >=1.2.3.0+      aeson >=1.5.0.0     , base >=4.7 && <5     , bytestring >=0.10.8.1     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.8.0 && <0.9-    , fortran-src-extras >=0.2.0+    , fortran-src >=0.10.2 && <0.11+    , fortran-src-extras >=0.3.1 && <0.4     , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010@@ -72,16 +76,19 @@       Paths_fortran_vars   hs-source-dirs:       app+  default-extensions:+      LambdaCase+      TypeApplications   ghc-options: -threaded -rtsopts   build-depends:-      aeson >=1.2.3.0+      aeson >=1.5.0.0     , base >=4.7 && <5     , bytestring >=0.10.8.1     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.8.0 && <0.9-    , fortran-src-extras >=0.2.0+    , fortran-src >=0.10.2 && <0.11+    , fortran-src-extras >=0.3.1 && <0.4     , fortran-vars     , text >=1.2.2.2     , uniplate >=1.6.10@@ -103,19 +110,22 @@       Paths_fortran_vars   hs-source-dirs:       test+  default-extensions:+      LambdaCase+      TypeApplications   ghc-options: -threaded -rtsopts   build-tool-depends:       hspec-discover:hspec-discover   build-depends:       HUnit-    , aeson >=1.2.3.0+    , aeson >=1.5.0.0     , base >=4.7 && <5     , bytestring >=0.10.8.1     , containers >=0.5.7.1     , deepseq >=1.4.4.0     , fgl >=5-    , fortran-src >=0.8.0 && <0.9-    , fortran-src-extras >=0.2.0+    , fortran-src >=0.10.2 && <0.11+    , fortran-src-extras >=0.3.1 && <0.4     , fortran-vars     , hspec     , text >=1.2.2.2

@@ -29,12 +29,11 @@                                                 ( collectStructures ) import           Language.Fortran.Vars.SymbolTable                                                 ( collectSymbols )-import           Language.Fortran.Vars.Types-                                                ( SymbolTable+import           Language.Fortran.Vars.Types    ( SymbolTable                                                 , StructureTable                                                 , SymbolTableEntry(..)                                                 , Dimensions-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 , TypeError(..)                                                 , typeError@@ -99,7 +98,8 @@   -> [Declarator (Analysis a)]   -> [Either TypeError (Type, Expression (Analysis a))] declarators strt symt = concatMap f where-  f (Declarator _ _ v ScalarDecl _ (Just e)) = pure $ (, e) <$> typeOf strt symt v+  f (Declarator _ _ v ScalarDecl _ (Just e)) =+    pure $ (, e) <$> typeOf strt symt v   f d@(Declarator _ _ (ExpValue _ s (ValVariable v)) ArrayDecl{} _ (Just (ExpInitialisation _ _ vals)))     = case M.lookup v symt of       Just (SVariable (TArray ty (Just dims)) _) ->

@@ -1,48 +1,36 @@ module Language.Fortran.Vars.BozConstant   ( resolveBozConstant   , bozToInt+  , bozToInt1   , bozToInt2   , bozToInt4   , bozToInt8   ) where -import           Data.Char                      ( digitToInt-                                                , intToDigit-                                                , toLower-                                                )-import qualified Data.Map                       as M-import           Numeric                        ( readInt-                                                , showIntAtBase-                                                )-import           Text.Read                      ( ReadS )+import qualified Data.Map                      as M -import qualified Language.Fortran.AST.Boz       as AST+import qualified Language.Fortran.AST.Literal.Boz as AST import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)-                                                , Type(..)                                                 , SemType(..)                                                 , Kind                                                 , ExpVal(..)                                                 , SymbolTable                                                 ) +import Data.Int+ -- | Given 'SymbolTable', contextual symbol name and BOZ Constant -- ('ExpVal' constructed with Boz String), resolve BOZ Constant considering -- contextual symbol. -- -- Currently, it only resolves BOZ Constants in context of INTEGER. resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal-resolveBozConstant symTable assignSymbol (Boz boz) =-  resolveBozConstant' symTable assignSymbol boz-resolveBozConstant _ _ _ = error "Can only resolve ExpVal Boz"--resolveBozConstant' :: SymbolTable -> String -> AST.Boz -> ExpVal-resolveBozConstant' symTable assignSymbol boz =-  let entry = M.lookup assignSymbol symTable-  in-    case entry of+resolveBozConstant symTable assignSymbol (Boz boz) = go boz+  where+    go boz = case entry of       Just (SVariable (TInteger kind) _) ->-        resolveBozConstantInContext boz kind+        bozToInt kind boz       Just (SVariable ty _) ->         error           $  assignSymbol@@ -59,28 +47,52 @@         ++ " could not be found. \                                           \Invalid fortran syntax"         )+    entry = M.lookup assignSymbol symTable -resolveBozConstantInContext :: AST.Boz -> Kind -> ExpVal-resolveBozConstantInContext boz kind =+resolveBozConstant _ _ _ = error "Can only resolve ExpVal Boz"++-- | Resolve a BOZ constant as an INTEGER(k).+--+-- Works on arbitrary kinds, including non-standard, assuming that kind+-- indicates size in bytes.+bozToInt :: Kind -> AST.Boz -> ExpVal+bozToInt kind boz = case kind of+  -- handle regular kinds via bitwise operations on sized machine integers,+  -- relying on overflow behaviour+  1 -> bozToInt1 boz+  2 -> bozToInt2 boz+  4 -> bozToInt4 boz+  8 -> bozToInt8 boz++  -- handle irregular kinds via explicit numeric operations+  -- (shouldn't really ever trigger, but no harm)+  k -> bozAsTwosCompExplicit boz k++--------------------------------------------------------------------------------++-- | Resolve a BOZ constant as an INTEGER(1).+bozToInt1 :: AST.Boz -> ExpVal+bozToInt1 = Int . fromIntegral . AST.bozAsTwosComp @Int8++-- | Resolve a BOZ constant as an INTEGER(2).+bozToInt2 :: AST.Boz -> ExpVal+bozToInt2 = Int . fromIntegral . AST.bozAsTwosComp @Int16++-- | Resolve a BOZ constant as an INTEGER(4).+bozToInt4 :: AST.Boz -> ExpVal+bozToInt4 = Int . fromIntegral . AST.bozAsTwosComp @Int32++-- | Resolve a BOZ constant as an INTEGER(8).+bozToInt8 :: AST.Boz -> ExpVal+bozToInt8 = Int . fromIntegral . AST.bozAsTwosComp @Int64++--------------------------------------------------------------------------------++bozAsTwosCompExplicit :: AST.Boz -> Kind -> ExpVal+bozAsTwosCompExplicit boz kind =   let allowedBinaryLength = kind * 8       maxBinaryValue      = 2 ^ (allowedBinaryLength - 1) - 1       minBinaryValue      = (-1) * 2 ^ (allowedBinaryLength - 1)       decimal             = AST.bozAsNatural boz       overflow            = decimal - maxBinaryValue   in  if overflow > 0 then Int (minBinaryValue + overflow - 1) else Int decimal---- Convert BOZ string to integer of specific kind-bozToInt :: Int -> ExpVal -> ExpVal-bozToInt kind (Boz boz) = resolveBozConstantInContext boz kind---- Convert BOZ string to integer*2-bozToInt2 :: ExpVal -> ExpVal-bozToInt2 = bozToInt 2---- Convert BOZ string to integer*4-bozToInt4 :: ExpVal -> ExpVal-bozToInt4 = bozToInt 4---- Convert BOZ string to integer*8-bozToInt8 :: ExpVal -> ExpVal-bozToInt8 = bozToInt 8

@@ -13,6 +13,7 @@                                                 , Expression(..)                                                 , Argument(..)                                                 , aStrip+                                                , argExprNormalize                                                 ) import           Language.Fortran.Analysis      ( Analysis                                                 , srcName@@ -42,18 +43,16 @@  -- | Given a function call 'Expression', return the list of argument 'Expression' functionArguments :: Expression a -> [Expression a]-functionArguments (ExpFunctionCall _ _ _ args) = case args of-  Just args' -> map (\(Argument _ _ _ e) -> e) (aStrip args')-  Nothing    -> []+functionArguments (ExpFunctionCall _ _ _ args) =+  map (\(Argument _ _ _ e) -> argExprNormalize e) (aStrip args) functionArguments e =   error $ "Expression at " ++ show (getSpan e) ++ " is not a function call"   -- | Given a subroutine call 'Statement', return the list of argument 'Expression' subroutineArguments :: Statement a -> [Expression a]-subroutineArguments (StCall _ _ _ args) = case args of-  Just args' -> map (\(Argument _ _ _ e) -> e) (aStrip args')-  Nothing    -> []+subroutineArguments (StCall _ _ _ args) =+  map (\(Argument _ _ _ e) -> argExprNormalize e) (aStrip args) subroutineArguments s =   error $ "Statement at " ++ show (getSpan s) ++ " is not a subroutine call" 

@@ -12,7 +12,7 @@                                                 , ProgramUnitModel                                                 , StorageClass(..)                                                 , Offset-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 )

@@ -5,7 +5,10 @@  import           Data.Data                      ( Data ) import           Data.List                      ( foldl' )-import           Language.Fortran.Analysis      ( Analysis )+import           Data.Maybe                     ( fromMaybe )+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                ) import           Language.Fortran.AST           ( AList                                                 , aStrip                                                 , Expression@@ -14,12 +17,10 @@  import           Language.Fortran.Vars.MemoryLocation                                                 ( getLocation )-import           Language.Fortran.Vars.Types-                                                ( Location+import           Language.Fortran.Vars.Types    ( Location                                                 , ProgramUnitModel                                                 )-import           Language.Fortran.Vars.Union-                                                ( union )+import           Language.Fortran.Vars.Union    ( union )  associate :: ProgramUnitModel -> [Location] -> ProgramUnitModel associate puModel locations =@@ -30,7 +31,7 @@  equivalence   :: Data a => ProgramUnitModel -> Statement (Analysis a) -> ProgramUnitModel-equivalence puModel0 (StEquivalence _ _ equivsList) = foldl'+equivalence puModel0 (StEquivalence _ ss equivsList) = foldl'   f   puModel0   (aStrip equivsList)@@ -41,7 +42,15 @@     -> AList Expression (Analysis a)     -> ProgramUnitModel   f model@(symTable, _) equivs =-    let locations = map (getLocation symTable) (aStrip equivs)+    let+      locations =+        (\x ->+            fromMaybe+                (error $ "Couldn't calculate location at " <> show ss <> srcName x+                )+              $ getLocation symTable x+          )+          <$> aStrip equivs     in  associate model locations equivalence model _ = model 

@@ -11,7 +11,7 @@                                                 , Expression(..)                                                 , Value(..)                                                 , AList(..)-                                                , Argument(..)+                                                , argExtractExpr                                                 ) import           Language.Fortran.Util.Position ( getSpan ) @@ -25,8 +25,7 @@                                                 , valueToExpVal'                                                 , intrinsicFunctionCall                                                 )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , ExpVal(..)                                                 , SymbolTable                                                 )@@ -44,17 +43,16 @@   ExpUnary _ _ op e -> transformEither (unaryOp' op) $ eval' symTable e   ExpBinary _ _ op e1 e2 ->     binaryTransformEither (binaryOp' op) (eval' symTable e1) (eval' symTable e2)-  ExpFunctionCall _ _ (ExpValue _ _ function) (Just (AList _ _ args)) ->-    transformEitherList intrinsicFunctionCall' $ evalArgs args+  ExpFunctionCall _ _ (ExpValue _ _ function) (AList _ _ args) ->+    transformEitherList intrinsicFunctionCall'+      $   eval' symTable+      .   argExtractExpr+      <$> args    where     intrinsicFunctionCall' = intrinsicFunctionCall $ functionName function     functionName (ValVariable  name) = name     functionName (ValIntrinsic name) = name     functionName _                   = ""-    evalArgs :: [Argument a] -> [Either String ExpVal]-    evalArgs []                           = []-    evalArgs [Argument _ _ _ arg        ] = [eval' symTable arg]-    evalArgs (Argument _ _ _ arg : args') = eval' symTable arg : evalArgs args'   _ -> Left $ "Unsupported expression at: " ++ show (getSpan expr)  -- | Given a 'SymbolTable' and some 'Expression', evaluate that expression

@@ -6,9 +6,9 @@   , getTypeSize   , setTypeSize   , deriveSemTypeFromBaseType-  ) where+  )+where -import           Data.Either                    ( either ) import           Data.Maybe                     ( fromJust ) import           Language.Fortran.Analysis      ( Analysis ) import           Language.Fortran.Analysis.Types@@ -25,13 +25,10 @@                                                 , setTypeSize                                                 ) -import           Language.Fortran.Vars.Errors-                                                ( invalidArg )-import           Language.Fortran.Vars.Eval-                                                ( eval' )-import           Language.Fortran.Vars.Types-                                                ( ExpVal(..)-                                                , Type(..)+import           Language.Fortran.Vars.Errors   ( invalidArg )+import           Language.Fortran.Vars.Eval     ( eval' )+import           Language.Fortran.Vars.Types    ( ExpVal(..)+                                                , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 , SymbolTable

@@ -1,13 +1,14 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}  module Language.Fortran.Vars.Memory   ( allocateMemoryBlocks   , processCommon+  , getTypeSize   ) where -import           Language.Fortran.Extras-                                                ( allPUS )+import           Language.Fortran.Extras        ( allPUS ) import           Data.Data                      ( Data ) import           Data.List                      ( foldl' ) import           Data.Maybe                     ( fromMaybe )@@ -27,20 +28,17 @@  import           Language.Fortran.Vars.MemoryLocation                                                 ( getStartLocation )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , MemoryBlock(..)                                                 , ProgramUnitModel                                                 , SymbolTable                                                 , StorageClass(..)                                                 , StorageTable-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 )-import           Language.Fortran.Vars.Kind-                                                ( getTypeKind )-import           Language.Fortran.Vars.Union-                                                ( union )+import           Language.Fortran.Vars.Kind     ( getTypeKind )+import           Language.Fortran.Vars.Union    ( union )  -- | Given a 'SymbolTable' and an 'Expression', return the size of -- the variable represented by the expression@@ -53,15 +51,17 @@         _          -> error "Unsupported expression"       Just entity = M.lookup symbol symTable   in  case entity of-        SVariable (TArray ty dims) _ ->-          fromMaybe (error "Can't calculate size of dynamic array")-            $   sizeOfStaticArray-            <$> getTypeKind ty-            <*> dims-        SVariable ty _ ->-          fromMaybe (error "Can't get size of dynamic variable")-            $ getTypeKind ty-        _ -> error (symbol ++ " is not a VariableEntry.")+        SVariable ty _ -> getTypeSize ty+        _              -> error (symbol ++ " is not a VariableEntry.")++getTypeSize :: Type -> Int+getTypeSize = \case+  TArray ty dims ->+    fromMaybe (error "Can't calculate size of dynamic array")+      $   sizeOfStaticArray+      <$> getTypeKind ty+      <*> dims+  ty -> fromMaybe (error "Can't get size of dynamic variable") $ getTypeKind ty  -- | Given a static array's 'kind' and 'dimension', calculate its size sizeOfStaticArray :: Int -> [(Int, Int)] -> Int

@@ -18,17 +18,12 @@                                                 , Value(..)                                                 ) -import           Language.Fortran.Vars.Eval-                                                ( eval )-import           Language.Fortran.Vars.Kind-                                                ( toInt+import           Language.Fortran.Vars.Eval     ( eval' )+import           Language.Fortran.Vars.Kind     ( toInt                                                 , getTypeKind                                                 )-import           Language.Fortran.Vars.Range-                                                ( Range )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)-                                                , Type(..)+import           Language.Fortran.Vars.Range    ( Range )+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , SemType(..)                                                 , Location                                                 , Offset@@ -77,52 +72,59 @@       ++ " at offset "       ++ show offset -calculateOffset :: Data a => SymbolTable -> Name -> [Index (Analysis a)] -> Int+calculateOffset+  :: Data a => SymbolTable -> Name -> [Index (Analysis a)] -> Maybe Int -- array index c(2,4) calculateOffset symTable symbol indices@(IxSingle{} : _) =   let Just entry = M.lookup symbol symTable-  in  case entry of-        SVariable (TArray ty (Just dims)) _ ->-          let ixSingles    = takeWhile isIxSingle indices-              Just kind    = getTypeKind ty-              arrayIndices = map toIndices ixSingles-                 where-                  toIndices (IxSingle _ _ _ expr) = toInt $ eval symTable expr-                  toIndices _ = error "toIndices: unexpected input"-          in  linearizedIndex arrayIndices dims * kind-        _ ->-          error "Only array-typed VariableEntries are expected at this point"+  in+    case entry of+      SVariable (TArray ty (Just dims)) _ ->+        let+          ixSingles    = takeWhile isIxSingle indices+          Just kind    = getTypeKind ty+          arrayIndices = either (const Nothing) Just+            $ traverse toIndices ixSingles+           where+            toIndices (IxSingle _ _ _ expr) = toInt <$> eval' symTable expr+            toIndices _ = error "toIndices: unexpected input"+        in+          (\x -> linearizedIndex x dims * kind) <$> arrayIndices+      _ -> error "Only array-typed VariableEntries are expected at this point" -- substring c(:5)-calculateOffset _ _ (IxRange _ _ Nothing _ _ : _) = 0+calculateOffset _ _ (IxRange _ _ Nothing _ _ : _) = Just 0 -- substring c(5:) calculateOffset symTable _ (IxRange _ _ (Just lowerIndex) _ _ : _) =-  toInt (eval symTable lowerIndex) - 1+  let val = eval' symTable lowerIndex+  in  either (const Nothing) (\x -> Just $ toInt x - 1) val calculateOffset _ _ _ = error "calculateOffset: invalid index"  -- | Given a 'SymbolTable' and some 'Expression' (which is assumed to have been predetermined -- to be of some variable type), return the 'Location' that the variable in question will be -- located in memory-getLocation :: Data a => SymbolTable -> Expression (Analysis a) -> Location+getLocation+  :: Data a => SymbolTable -> Expression (Analysis a) -> Maybe Location -- variable getLocation symTable e@(ExpValue _ _ (ValVariable _)) =-  findBlockOffset symTable (srcName e) 0+  Just $ findBlockOffset symTable (srcName e) 0 -- array index c(2,4) -- substring c(5:10) getLocation symTable (ExpSubscript _ _ e@ExpValue{} (AList _ _ indices)) =   let symbol = srcName e       offset = calculateOffset symTable symbol indices-  in  findBlockOffset symTable symbol offset+  in  findBlockOffset symTable symbol <$> offset -- array index and substring c(2,4)(1:20) getLocation symTable (ExpSubscript _ _ (ExpSubscript _ _ e@ExpValue{} (AList _ _ indices)) (AList _ _ subs))   = let symbol = srcName e         offset =-            calculateOffset symTable symbol indices-              + calculateOffset symTable symbol subs-    in  findBlockOffset symTable symbol offset+            (+)+              <$> calculateOffset symTable symbol indices+              <*> calculateOffset symTable symbol subs+    in  findBlockOffset symTable symbol <$> offset -- array within common block with dimensions declaration: common /block/ a, b(10) getLocation symTable (ExpFunctionCall _ _ e@ExpValue{} _) =-  findBlockOffset symTable (srcName e) 0-getLocation _ _ = error "getLocation : Not a variable expression"+  Just $ findBlockOffset symTable (srcName e) 0+getLocation _ _ = Nothing  -- | Given a 'SymbolTable' and some 'Expression' (which is assumed to have been -- predetermined to be of some variable type), return the start 'Location' that

@@ -17,18 +17,13 @@                                                 , EQ                                                 , LT                                                 )-import           Data.Char                      ( toUpper-                                                , chr-                                                )-import           Data.Either                    ( either )-import           Text.Read                      ( readMaybe )+import           Data.Char                      ( chr )  import           Language.Fortran.AST           ( BinaryOp(..)                                                 , UnaryOp(..)                                                 , Value(..)                                                 )-import           Language.Fortran.AST.RealLit   ( readRealLit )-import           Language.Fortran.AST.Boz       ( prettyBoz )+import           Language.Fortran.AST.Literal.Real ( readRealLit ) import           Language.Fortran.Util.Position ( SrcSpan )  @@ -36,10 +31,8 @@                                                 ( bozToInt8                                                 , bozToInt                                                 )-import           Language.Fortran.Vars.Errors-                                                ( invalidArg' )-import           Language.Fortran.Vars.Types-                                                ( ExpVal(..) )+import           Language.Fortran.Vars.Errors   ( invalidArg' )+import           Language.Fortran.Vars.Types    ( ExpVal(..) )  import           Data.Bits                      ( (.|.)                                                 , complement@@ -86,12 +79,12 @@ -- by that 'Value'. valueToExpVal' :: SrcSpan -> Value a -> Either String ExpVal valueToExpVal' s val = case val of-  ValInteger   i  _ -> Right $ Int     $ read i-  ValReal      r  _ -> Right $ Real    $ readRealLit r-  ValLogical   l  _ -> Right $ Logical l-  ValString    s'   -> Right $ Str s'-  ValHollerith h    -> Right $ Str h-  ValBoz       b    -> Right $ Boz b+  ValInteger i _  -> Right $ Int $ read i+  ValReal    r _  -> Right $ Real $ readRealLit r+  ValLogical l _  -> Right $ Logical l+  ValString    s' -> Right $ Str s'+  ValHollerith h  -> Right $ Str h+  ValBoz       b  -> Right $ Boz b   _               -> Left ("toExpVal: unsupported value at " ++ show s)  -- | Given a 'SrcSpan' and the 'Value' returnthe 'ExpVal' held@@ -108,8 +101,8 @@ nonLogicalToLogical (Real r) = Right $ r /= 0.0 nonLogicalToLogical (Str _) =   Left "Cannot transform a string value to a logical value"-nonLogicalToLogical (  Logical l) = Right l-nonLogicalToLogical b@(Boz     _) = nonLogicalToLogical $ bozToInt8 b+nonLogicalToLogical (Logical l) = Right l+nonLogicalToLogical (Boz     b) = nonLogicalToLogical $ bozToInt8 b  -- | Given a string representing a function call and a list of ExpVal -- values holding inputs to the function, evaluate the function call@@ -159,7 +152,7 @@ int' :: [ExpVal] -> Either String ExpVal int' [Int  i] = Right $ Int i int' [Real r] = Right $ Int (truncate r)-int' v@[boz@(Boz _), Int k] =+int' v@[(Boz boz), Int k] =   if k `elem` [2, 4, 8] then Right $ bozToInt k boz else invalidArg' "int" v int' vs = invalidArg' "int" vs @@ -218,13 +211,13 @@   (LT, Real a, Real b) -> Right $ Logical (a < b)   (LT, Int a, Real b) -> Right $ Logical (fromIntegral a < b)   (LT, Real a, Int b) -> Right $ Logical (a < fromIntegral b)-  (LT, a@(Boz _), b) -> binaryOp' LT (bozToInt8 a) b-  (LT, a, b@(Boz _)) -> binaryOp' LT a (bozToInt8 b)+  (LT, Boz boz, b) -> binaryOp' LT (bozToInt8 boz) b+  (LT, a, Boz boz) -> binaryOp' LT a (bozToInt8 boz)    (EQ, Int a, Real b) -> Right $ Logical (fromIntegral a == b)   (EQ, Real a, Int b) -> Right $ Logical (a == fromIntegral b)-  (EQ, a@(Boz _), b) -> binaryOp' EQ (bozToInt8 a) b-  (EQ, a, b@(Boz _)) -> binaryOp' EQ a (bozToInt8 b)+  (EQ, Boz boz, b) -> binaryOp' EQ (bozToInt8 boz) b+  (EQ, a, Boz boz) -> binaryOp' EQ a (bozToInt8 boz)   (EQ, Logical True, Int b) -> Right $ Logical (1 == b)   (EQ, Logical False, Int b) -> Right $ Logical (0 == b)   (EQ, Int a, Logical True) -> Right $ Logical (a == 1)

@@ -0,0 +1,21 @@+module Language.Fortran.Vars.Orphans where++import Language.Fortran.AST+import qualified Language.Fortran.AST.Literal.Boz as Boz+import Language.Fortran.Util.Position+import Language.Fortran.Analysis.SemanticTypes++import Data.Aeson ( ToJSON, FromJSON )++-- TODO temporary solution+instance   ToJSON SemType+instance FromJSON SemType+instance   ToJSON CharacterLen+instance FromJSON CharacterLen++instance FromJSON SrcSpan+instance FromJSON Position++instance FromJSON Boz.Boz+instance FromJSON Boz.BozPrefix+instance FromJSON Boz.Conforming

@@ -9,6 +9,10 @@                                                 , Value(..)                                                 , aStrip                                                 )+import           Language.Fortran.AST.Literal.Complex+                                                ( ComplexLit(..)+                                                , ComplexPart(..)+                                                ) import           Language.Fortran.Vars.Call                                                 ( functionArguments ) @@ -36,7 +40,7 @@ isPureValue :: Value a -> Bool isPureValue ValInteger{}       = True isPureValue ValReal{}          = True-isPureValue (ValComplex e1 e2) = isPureExpression e1 && isPureExpression e2+isPureValue (ValComplex c)     = complexLitIsPure c isPureValue ValString{}        = True isPureValue ValHollerith{}     = True isPureValue ValVariable{}      = True@@ -44,6 +48,14 @@ isPureValue ValLogical{}       = True isPureValue ValStar            = True isPureValue _                  = False++-- | Is the given COMPLEX literal "pure", i.e. does it have no named constant+--   components?+complexLitIsPure :: ComplexLit a -> Bool+complexLitIsPure c =+    check (complexLitRealPart c) && check (complexLitImagPart c)+  where check = \case ComplexPartNamed{} -> False+                      _                  -> True  -- | Given an 'Index', determine whether it is pure isPureIndex :: Index a -> Bool

@@ -30,25 +30,22 @@                                                 , DeclaratorType(..)                                                 , aStrip                                                 )-import           Language.Fortran.Extras-                                                ( allPUS+import           Language.Fortran.Extras        ( allPUS                                                 , allPU                                                 )  import           Language.Fortran.Vars.SymbolTable                                                 ( collectSymbols )-import           Language.Fortran.Vars.Types-                                                ( SymbolTable+import           Language.Fortran.Vars.Types    ( SymbolTable                                                 , StructureTableEntry(..)                                                 , Structure                                                 , StructureTable                                                 , ProgramStructureTables-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 , TypeError(..)                                                 )-import           Language.Fortran.Vars.Utils-                                                ( typeSpecToArrayType+import           Language.Fortran.Vars.Utils    ( typeSpecToArrayType                                                 , typeSpecToScalarType                                                 ) 

@@ -10,22 +10,19 @@                                                 ) import           Data.List                      ( foldl' ) import qualified Data.Map                      as M-import           Data.Maybe                     ( catMaybes )+import           Data.Maybe                     ( mapMaybe )  import           Language.Fortran.Analysis      ( Analysis                                                 , srcName                                                 ) import           Language.Fortran.AST           ( AList-                                                , Argument(..)                                                 , aStrip-                                                , BaseType(..)                                                 , Block(..)                                                 , CommonGroup(..)                                                 , Declarator(..)                                                 , DeclaratorType(..)                                                 , DimensionDeclarator(..)                                                 , Expression(..)-                                                , Index(..)                                                 , Name                                                 , ProgramUnit(..)                                                 , programUnitBody@@ -35,30 +32,25 @@                                                 , Value(..)                                                 ) -import           Language.Fortran.Vars.Eval-                                                ( eval+import           Language.Fortran.Vars.Eval     ( eval                                                 , eval'                                                 ) import           Language.Fortran.Vars.BozConstant                                                 ( resolveBozConstant )-import           Language.Fortran.Vars.Types-                                                ( ExpVal(..)+import           Language.Fortran.Vars.Types    ( ExpVal(..)                                                 , SymbolTableEntry(..)-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 , SymbolTable                                                 )-import           Language.Fortran.Vars.Utils-                                                ( typeSpecToScalarType+import           Language.Fortran.Vars.Utils    ( typeSpecToScalarType                                                 , typeSpecToArrayType                                                 )-import           Language.Fortran.Vars.Kind-                                                ( getKind+import           Language.Fortran.Vars.Kind     ( getKind                                                 , getTypeKind                                                 , setTypeKind                                                 , getKindOfExpVal-                                                , toInt                                                 , typeOfExpVal                                                 , baseToType                                                 , isStr@@ -221,19 +213,24 @@ -- skipped. handleArrayDecl   :: Data a-  => SymbolTable -> Expression (Analysis a) -> [DimensionDeclarator (Analysis a)]+  => SymbolTable+  -> Expression (Analysis a)+  -> [DimensionDeclarator (Analysis a)]   -> SymbolTable handleArrayDecl symTable varExp dimDecls =-    let symbol = srcName varExp-        dims   = traverse (resolveDimensionDimensionDeclarator symTable) dimDecls-     in case M.lookup symbol symTable of-          Just (SVariable TArray{} _) -> error "invalid declarator: duplicate array declarations"-          Just (SVariable ty loc) ->-            let ste = SVariable (TArray ty dims) loc-             in M.insert symbol ste symTable-          Nothing -> -- add array info, use a placeholder for scalar type-            let ste = SVariable (TArray placeholderIntrinsicType dims) (symbol, 0)-             in M.insert symbol ste symTable+  let symbol = srcName varExp+      dims   = traverse (resolveDimensionDimensionDeclarator symTable) dimDecls+  in  case M.lookup symbol symTable of+        Just (SVariable TArray{} _) ->+          error "invalid declarator: duplicate array declarations"+        Just (SVariable ty loc) ->+          let ste = SVariable (TArray ty dims) loc+          in  M.insert symbol ste symTable+        Just var -> error $ "Invalid declarator: " <> show var+        Nothing -> -- add array info, use a placeholder for scalar type+          let ste =+                  SVariable (TArray placeholderIntrinsicType dims) (symbol, 0)+          in  M.insert symbol ste symTable   where placeholderIntrinsicType = TInteger 4  -- | Given a 'SymbolTable' and a 'Statement' found in a 'ProgramUnit', return a new 'SymbolTable'@@ -254,9 +251,9 @@     -- in a correct parser.     Declarator _ _ _ ScalarDecl _ _ ->       error "non-array declaration in a DIMENSION statement"-  handleCommon symt (CommonGroup _ _ mName decls) =-    let arrayDecls = catMaybes . map extractArrayDecl . aStrip $ decls-     in foldl' (uncurry . handleArrayDecl) symt arrayDecls+  handleCommon symt (CommonGroup _ _ _ decls) =+    let arrayDecls = mapMaybe extractArrayDecl . aStrip $ decls+    in  foldl' (uncurry . handleArrayDecl) symt arrayDecls   extractArrayDecl = \case     Declarator _ _ v (ArrayDecl d) _ _ -> Just (v, aStrip d)     Declarator _ _ _ ScalarDecl    _ _ -> Nothing@@ -280,8 +277,10 @@ upgradeScalarToArray symbol dimDecls symTable =   case M.lookup symbol symTable of     Just (SVariable TArray{} _) ->-      error $  symbol <> " is array-typed variable."-            <> " Invalid fortran syntax (Duplicate DIMENSION attribute)"+      error+        $  symbol+        <> " is array-typed variable."+        <> " Invalid fortran syntax (Duplicate DIMENSION attribute)"     Just (SVariable ty loc) ->       let mdims = traverse (resolveDimensionDimensionDeclarator symTable)                            (aStrip dimDecls)

@@ -13,55 +13,57 @@                                                 , LT                                                 ) import qualified Data.Map                      as M-import           Data.Char                      ( toUpper ) import           Data.Data                      ( toConstr ) import           Data.Maybe                     ( fromJust )-import           Text.Read                      ( readMaybe ) import           Language.Fortran.AST           ( Expression(..)                                                 , Value(..)                                                 , AList(..)                                                 , aStrip                                                 , aStrip'                                                 , Argument(..)+                                                , argExprNormalize                                                 , DoSpecification(..)                                                 , Statement(..)                                                 , Name                                                 , BinaryOp(..)                                                 , Index(..)                                                 )-import           Language.Fortran.AST.RealLit   ( RealLit(..)+import           Language.Fortran.AST.Literal   ( KindParam(..) )+import           Language.Fortran.AST.Literal.Real+                                                ( RealLit(..)                                                 , Exponent(..)                                                 , ExponentLetter(..)                                                 )+import           Language.Fortran.AST.Literal.Complex+                                                ( ComplexLit(..)+                                                , ComplexPart(..)+                                                ) import           Language.Fortran.Intrinsics    ( getVersionIntrinsics                                                 , getIntrinsicReturnType                                                 , IntrinsicType(..)                                                 )-import           Language.Fortran.ParserMonad   ( FortranVersion(..) )+import           Language.Fortran.Version       ( FortranVersion(..) )  import           Language.Fortran.Util.Position ( SrcSpan                                                 , getSpan                                                 )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , ExpVal(..)                                                 , SymbolTable                                                 , StructureTable                                                 , Kind-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 , TypeError(..)                                                 , TypeOf                                                 , typeError                                                 )-import           Language.Fortran.Vars.Kind-                                                ( getTypeKind+import           Language.Fortran.Vars.Kind     ( getTypeKind                                                 , setTypeKind                                                 , toInt                                                 )-import           Language.Fortran.Vars.Eval-                                                ( eval' )+import           Language.Fortran.Vars.Eval     ( eval' ) import           Language.Fortran.Vars.StructureTable                                                 ( lookupField ) @@ -77,10 +79,10 @@   ExpValue _ s val                -> typeOfValue s strTable symTable val   ExpUnary _ _ _ e                -> typeOf strTable symTable e   ExpBinary _ s op e1 e2 -> typeOfBinaryExp s strTable symTable op e1 e2-  ExpFunctionCall _ _ (ExpValue _ s (ValVariable name)) margs ->-    typeOfFunctionCall s strTable symTable name (aStrip' margs)-  ExpFunctionCall _ _ (ExpValue _ s (ValIntrinsic name)) margs ->-    typeOfFunctionCall s strTable symTable name (aStrip' margs)+  ExpFunctionCall _ _ (ExpValue _ s (ValVariable name)) args ->+    typeOfFunctionCall s strTable symTable name (aStrip args)+  ExpFunctionCall _ _ (ExpValue _ s (ValIntrinsic name)) args ->+    typeOfFunctionCall s strTable symTable name (aStrip args)   ExpSubscript _ s arr (AList _ _ args@(IxSingle{} : _)) ->     let isIxRange = \case           IxRange{} -> True@@ -138,6 +140,8 @@   Nothing -> Left $ UnboundVariable name  -- | Internal function to determine the 'Type' of a constant+--+-- TODO ignoring kind param errors (should report better) typeOfValue   :: SrcSpan   -> StructureTable@@ -148,29 +152,32 @@   ValInteger _ mkp -> Right $ TInteger (kpOrDef 4 mkp)   ValReal r _ -> -- TODO ignoring kind param     let k = case exponentLetter (realLitExponent r) of-              ExpLetterE ->  4-              ExpLetterD ->  8-              ExpLetterQ -> 16-     in Right $ TReal k-  ValComplex real imaginary -> do-    tr <- typeOf strTable symTable real-    ti <- typeOf strTable symTable imaginary+          ExpLetterE -> 4+          ExpLetterD -> 8+          ExpLetterQ -> 16+    in  Right $ TReal k+  ValComplex c -> do+    tr <- typeOfComplexPart strTable symTable $ complexLitRealPart c+    ti <- typeOfComplexPart strTable symTable $ complexLitImagPart c     if tr == TReal 8 || ti == TReal 8       then return (TComplex 16)       else return (TComplex 8)-  ValString    s -> Right $ TCharacter (CharLenInt (length s)) 1-  ValHollerith s -> Right . TByte $ length s-  ValLogical   _ mkp -> Right $ TLogical (kpOrDef 4 mkp)-  ValBoz       b -> Right $ TByte 4-  _              -> Left $ UnknownType sp+  ValString    s   -> Right $ TCharacter (CharLenInt (length s)) 1+  ValHollerith s   -> Right . TByte $ length s+  ValLogical _ mkp -> Right $ TLogical (kpOrDef 4 mkp)+  ValBoz _         -> Right $ TByte 4+  _                -> Left $ UnknownType sp   where-    evalMaybeKind k = either (const Nothing) (Just . toInt) $ eval' symTable k-    -- TODO ignoring kind param errors (should report better)+    kpOrDef :: Kind -> Maybe (KindParam a) -> Kind     kpOrDef kDef = \case-       Nothing -> kDef-       Just kp -> case evalMaybeKind kp of-                    Nothing -> kDef-                    Just k  -> k+      Nothing -> kDef+      Just kp -> case kp of+        KindParamInt _ _ kpLit -> read kpLit+        KindParamVar _ _ kpVar ->+          let kpVarExpr = ExpValue undefined undefined (ValVariable kpVar)+          in  case eval' symTable kpVarExpr of+                Left{} -> kDef+                Right k -> toInt k  promote :: Type -> Type -> Type promote t1 t2@@ -224,15 +231,25 @@   -- TODO   -- = Right . TCharacter $ (+) <$> k1 <*> k2   = case t1 of-      TCharacter l1 k1 ->-        case t2 of-          TCharacter l2 k2 -> Right $ TCharacter (charLenConcat l1 l2) k1-          _ -> error "shit 1"-      _ -> error "shit 2"+    TCharacter l1 k1' -> case t2 of+      TCharacter l2 _ -> Right $ TCharacter (charLenConcat l1 l2) k1'+      _               -> error "shit 1"+    _ -> error "shit 2"   |   -- Logical+  -- NB when integer's are used with logical operators you get bitwise+  -- arithmetic behaviour     op `elem` [And, Or, Equivalent, NotEquivalent, XOr]-  = Right . TLogical . fromJust $ max <$> k1 <*> k2+  = let+      ty = case (t1, t2) of+        (TLogical _, TLogical _) -> Right . TLogical+        (TInteger _, _         ) -> Right . TInteger+        (_         , TInteger _) -> Right . TInteger+        (TByte _   , _         ) -> Right . TInteger+        (_         , TByte _   ) -> Right . TInteger+        _                        -> const+          (Left $ typeError sp "Unexpected types used with logical operators")+    in  ty . fromJust $ max <$> k1 <*> k2   |   -- Arithmetic     op `elem` [Addition, Subtraction, Multiplication, Division, Exponentiation]@@ -260,10 +277,9 @@   isInteger $ traverse (typeOf strt symt) upper   pure $ TCharacter calcLen 1  where-  calcLen =-      case (\x y -> y - x + 1) <$> lowerIndex <*> upperIndex of-        Nothing  -> CharLenStar-        Just len -> CharLenInt len+  calcLen = case (\x y -> y - x + 1) <$> lowerIndex <*> upperIndex of+    Nothing  -> CharLenStar+    Just len -> CharLenInt len   isInteger = \case     Right (Just (TInteger _)) -> Right ()     Right Nothing -> Right ()@@ -289,36 +305,48 @@ typeOfFunctionCall sp strT symT name argList =   checkIntrinsicFunction <> checkF77IntrinsicFunction <> checkExternalFunction  where-  args = [ e | Argument _ _ _ e <- argList ]+  args = [ argExprNormalize e | Argument _ _ _ e <- argList ]   -- If the function is any of the intrinsics below, determine its return type   -- accordingly   checkIntrinsicFunction :: Either TypeError Type   checkIntrinsicFunction-    | name `elem` ["int", "nint"], length args == 1 = Right (TInteger 4)-    | name `elem` ["int", "nint"], length args == 2 = case-        eval' symT (args !! 1)-      of-        Right (Int k) -> Right (TInteger k)-        _             -> Left $ typeError-          sp-          (  "Unable to determine the second argument value of "-          <> name-          <> " function"-          )-    | name == "int2" = Right (TInteger 2)-    | name `elem` ["loc", "sizeof", "iachar"] = Right (TInteger 4)-    | name == "dfloat" = Right (TReal 8)-    | name `elem` ["ishft", "rshift", "ibset", "ibits"], not (null args) = typeOf-      strT-      symT-      (head args)-    | name `elem` ["iand", "ior", "ieor", "and"], length args == 2 = do+    | name `elem` ["int", "nint"], length args == 1+    = Right (TInteger 4)+    | name `elem` ["int", "nint"], length args == 2+    = case eval' symT (args !! 1) of+      Right (Int k) -> Right (TInteger k)+      _             -> Left $ typeError+        sp+        (  "Unable to determine the second argument value of "+        <> name+        <> " function"+        )+    | name == "int2"+    = Right (TInteger 2)+    | name `elem` ["loc", "sizeof", "iachar"]+    = Right (TInteger 4)+    | name == "dfloat"+    = Right (TReal 8)+    | name `elem` ["ishft", "lshift", "rshift", "ibset", "ibits"], not+      (null args)+    = typeOf strT symT (head args)+    | name `elem` ["iand", "ior", "ieor", "and"], length args == 2+    = do       t1 <- typeOf strT symT (head args)       t2 <- typeOf strT symT (args !! 1)       return $ promote t1 t2-    | name == "btest", length args == 2 = return $ TLogical 4-    | name == "not", length args == 1 = typeOf strT symT (head args)-    | otherwise = Left $ typeError+    | name == "imag", length args == 1+    = do+      ty <- typeOf strT symT (head args)+      case ty of+        TComplex x -> Right . TReal $ x `div` 2+        _          -> Left $ typeError sp "Invalid argument to imag"+    | name == "btest", length args == 2+    = return $ TLogical 4+    | name == "not", length args == 1+    = typeOf strT symT (head args)+    | otherwise+    = Left $ typeError       sp       (name <> " is not in the extra list of intrinsic functions") @@ -347,3 +375,10 @@   -- in the symbol table.   checkExternalFunction :: Either TypeError Type   checkExternalFunction = typeOfSymbol symT name++typeOfComplexPart :: StructureTable -> SymbolTable -> ComplexPart a -> Either TypeError Type+typeOfComplexPart strTable symTable = \case+  ComplexPartReal   _ ss cpReal mkp -> tOfVal ss (ValReal    cpReal mkp)+  ComplexPartInt    _ ss cpInt  mkp -> tOfVal ss (ValInteger cpInt  mkp)+  ComplexPartNamed  _ _ nm         -> typeOfSymbol symTable nm+  where tOfVal ss v = typeOfValue ss strTable symTable v

@@ -8,9 +8,11 @@   , SemType(..)   , CharacterLen(..)   , Kind-  ) where+  )+where  import           Language.Fortran.Extras.Encoding+import           Language.Fortran.Vars.Orphans                                                 ( ) import           Data.Aeson                     ( FromJSON                                                 , ToJSON@@ -25,15 +27,16 @@ import           Language.Fortran.AST           ( Name                                                 , ProgramUnitName                                                 , Expression-                                                , Kind                                                 )-import qualified Language.Fortran.AST.Boz       as AST+import qualified Language.Fortran.AST.Literal.Boz      as AST import           Language.Fortran.Util.Position ( SrcSpan(..)                                                 , Position(..)                                                 ) import           Language.Fortran.Analysis.SemanticTypes                                                 ( SemType(..)-                                                , CharacterLen(..) )+                                                , CharacterLen(..)+                                                , Kind+                                                )  type Type = SemType @@ -46,10 +49,8 @@   | Boz     AST.Boz   deriving (Eq, Ord, Show, Data, Typeable, Generic, NFData) -instance FromJSON AST.Boz-instance ToJSON AST.Boz-instance FromJSON AST.BozPrefix-instance ToJSON AST.BozPrefix+-- instance FromJSON AST.Conforming+-- instance ToJSON AST.Conforming instance FromJSON ExpVal instance ToJSON ExpVal @@ -146,7 +147,7 @@  -- | Helper method for getting the FilePath out of SrcSpan typeError :: SrcSpan -> String -> TypeError-typeError sp = let SrcSpan p _ = sp in TypeError (filePath p) sp+typeError sp = let SrcSpan p _ = sp in TypeError (posFilePath p) sp  instance ToJSON TypeError instance FromJSON TypeError

@@ -2,18 +2,15 @@  import           Language.Fortran.Analysis      ( Analysis ) import           Language.Fortran.AST-import           Language.Fortran.Vars.Types-                                                ( SymbolTable+import           Language.Fortran.Vars.Types    ( SymbolTable                                                 , ExpVal(..)-                                                , Type(..)+                                                , Type                                                 , SemType(..)                                                 )-import           Language.Fortran.Vars.Eval-                                                ( eval+import           Language.Fortran.Vars.Eval     ( eval                                                 , eval'                                                 )-import           Language.Fortran.Vars.Kind-                                                ( setTypeKind+import           Language.Fortran.Vars.Kind     ( setTypeKind                                                 , kindOfBaseType                                                 , baseToType                                                 )

@@ -11,14 +11,10 @@ import           Language.Fortran.AST           ( Expression(..)                                                 , Value(..)                                                 )-import           Language.Fortran.Extras-                                                ( allPU )-import           Language.Fortran.Extras.Test-                                                ( getTestProgramAnalysis )+import           Language.Fortran.Extras        ( allPU )+import           Language.Fortran.Extras.Test   ( getTestProgramAnalysis ) import           Language.Fortran.Vars.Assignments-import           Language.Fortran.Vars.Types-                                                ( Type(..)-                                                , SemType(..)+import           Language.Fortran.Vars.Types    ( SemType(..)                                                 , CharacterLen(..)                                                 ) @@ -37,7 +33,7 @@     map fst stmts `shouldBe` replicate 9 (TReal 4)     let getVal = \case           ExpValue _ _ (ValInteger s _) -> s-          _                           -> error "Not value"+          _                             -> error "Not value"     map (getVal . snd) stmts       `shouldBe` ["1", "0", "0", "0", "1", "0", "0", "0", "1"] @@ -47,5 +43,6 @@     length errs `shouldBe` 0     length stmts `shouldBe` 1     case head stmts of-      (TCharacter CharLenStar _, ExpValue _ _ (ValString "ABCDEFGHI")) -> pure ()+      (TCharacter CharLenStar _, ExpValue _ _ (ValString "ABCDEFGHI")) ->+        pure ()       _ -> assertFailure "Wrong statement matched"

@@ -1,5 +1,11 @@-module BozConstantSpec ( spec ) where+-- TODO 2022-08-22 raehik: essentially obsoleted by+-- @Language.Fortran.AST.Literal.BozSpec@ in fortran-src +module BozConstantSpec+  ( spec+  )+where+ import           Test.Hspec  import           Language.Fortran.Vars.BozConstant@@ -7,12 +13,11 @@                                                 , bozToInt4                                                 , bozToInt8                                                 )-import           Language.Fortran.Vars.Types-                                                ( ExpVal(..) )-import qualified Language.Fortran.AST.Boz       as AST+import           Language.Fortran.Vars.Types    ( ExpVal(..) )+import qualified Language.Fortran.AST.Literal.Boz      as AST -boz :: String -> ExpVal-boz = Boz . AST.parseBoz+boz :: String -> AST.Boz+boz = AST.parseBoz  spec :: Spec spec = describe "Boz Constant Conversion" $ do

@@ -2,8 +2,7 @@  import           Test.Hspec -import           Language.Fortran.Util.Files-                                                ( flexReadFile )+import           Language.Fortran.Util.Files    ( flexReadFile ) import           Language.Fortran.Extras.ProgramFile                                                 ( versionedProgramFile ) import           Data.ByteString.Char8          ( ByteString )@@ -15,12 +14,11 @@ import           Language.Fortran.AST           ( Name                                                 , ProgramUnitName(..)                                                 )-import           Language.Fortran.ParserMonad   ( FortranVersion(..) )+import           Language.Fortran.Version       ( FortranVersion(..) ) import           Language.Fortran.Analysis      ( initAnalysis ) -import           Language.Fortran.Vars ( programFileModel )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)+import           Language.Fortran.Vars          ( programFileModel )+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)                                                 , Location                                                 , MemoryBlock(..)                                                 , MemoryBlockName@@ -28,7 +26,6 @@                                                 , StorageClass(..)                                                 , StorageTable                                                 , SymbolTable-                                                , Type(..)                                                 , SemType(..)                                                 , CharacterLen(..)                                                 )

@@ -10,10 +10,8 @@                                                 , Statement(..)                                                 , Expression(..)                                                 )-import           Language.Fortran.Extras-                                                ( allPU )-import           Language.Fortran.Extras.Test-                                                ( getTestProgramAnalysis )+import           Language.Fortran.Extras        ( allPU )+import           Language.Fortran.Extras.Test   ( getTestProgramAnalysis )  import           Language.Fortran.Vars.StructureTable                                                 ( StructureTable@@ -23,9 +21,7 @@                                                 ) import           Language.Fortran.Vars.SymbolTable                                                 ( collectSymbols )-import           Language.Fortran.Vars.Types-                                                ( SymbolTable-                                                , Type(..)+import           Language.Fortran.Vars.Types    ( SymbolTable                                                 , SemType(..)                                                 , CharacterLen(..)                                                 )@@ -76,15 +72,16 @@      it "multiple layer structures" $ do       structTable <- getStructureTable "test/structure_table/structure3.f"-      let-        graultEntries = [FieldEntry "garply" (TCustom "quuz")]-        quuzEntries =-          [FieldEntry "corge" (TCustom "baz"), FieldEntry "foobar" (TInteger 2)]-        fooEntries = [FieldEntry "bar" (TInteger 8)]-        bazEntries =-          [ FieldEntry "qux"  (TCustom "foo")-          , FieldEntry "quux" (TCharacter (CharLenInt 10) 1)-          ]+      let graultEntries = [FieldEntry "garply" (TCustom "quuz")]+          quuzEntries =+            [ FieldEntry "corge"  (TCustom "baz")+            , FieldEntry "foobar" (TInteger 2)+            ]+          fooEntries = [FieldEntry "bar" (TInteger 8)]+          bazEntries =+            [ FieldEntry "qux"  (TCustom "foo")+            , FieldEntry "quux" (TCharacter (CharLenInt 10) 1)+            ]       structTable `shouldBe` M.fromList         [ ("grault", graultEntries)         , ("quuz"  , quuzEntries)@@ -169,7 +166,8 @@                     universeBi pf :: [Expression (Analysis ())]                   ]           -- check looking up the expression succeeds and gives the correct type-          typeOf structTable st expr `shouldBe` Right (TCharacter (CharLenInt 10) 1)+          typeOf structTable st expr+            `shouldBe` Right (TCharacter (CharLenInt 10) 1)      it "Get type of union data reference expression"       $ testStructureTable "test/structure_table/union_struct3.f"@@ -180,7 +178,8 @@                   | e@ExpDataRef{} <-                     universeBi pf :: [Expression (Analysis ())]                   ]-          typeOf structTable st expr `shouldBe` Right (TCharacter (CharLenInt 13) 1)+          typeOf structTable st expr+            `shouldBe` Right (TCharacter (CharLenInt 13) 1)      it "Get combination of data references and subscripts" $ do       pf <- getTestProgramAnalysis "test/structure_table/structure4.f"

@@ -4,21 +4,19 @@ import           Language.Fortran.Extras.Analysis                                                 ( versionedExpandedProgramAnalysis                                                 )-import           Language.Fortran.Util.Files-                                                ( flexReadFile )+import           Language.Fortran.Util.Files    ( flexReadFile ) import           Language.Fortran.Extras.ProgramFile                                                 ( versionedProgramFile ) import           Data.ByteString.Char8          ( ByteString ) import qualified Data.Map                      as M import           Language.Fortran.AST           ( ProgramUnitName(..) )-import           Language.Fortran.ParserMonad   ( FortranVersion(..) )+import           Language.Fortran.Version       ( FortranVersion(..) ) import           Language.Fortran.Analysis      ( initAnalysis ) import           Test.Hspec -import           Language.Fortran.Vars ( programFileModel )-import           Language.Fortran.Vars.Types-                                                ( SymbolTableEntry(..)-                                                , Type(..)+import           Language.Fortran.Vars          ( programFileModel )+import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)+                                                , Type                                                 , SemType(..)                                                 , CharacterLen(..)                                                 , ExpVal(..)@@ -73,9 +71,9 @@         SDummy (TArray (TCharacter CharLenStar _) Nothing) ->           "DummyArrayDynamicCharacter"         SDummy (TCharacter CharLenStar _) -> "DummyDynamicCharacter"-        SDummy (TArray _ Nothing  ) -> "DummyDynamicArray"-        SDummy (TArray _ (Just _) ) -> "DummyStaticArray"-        SDummy _                    -> "DummyStaticScalar"+        SDummy (TArray _ Nothing) -> "DummyDynamicArray"+        SDummy (TArray _ (Just _)) -> "DummyStaticArray"+        SDummy _ -> "DummyStaticScalar"         v -> error (name ++ " is not a DummyVariableEntry it is a " ++ show v)  isDummy :: String -> SymbolTable -> Bool@@ -87,9 +85,9 @@ isDynamic name symTable = case M.lookup name symTable of   Just (SVariable ty _) -> case ty of     TArray (TCharacter CharLenStar _) _ -> True-    TArray _ Nothing   -> True+    TArray _ Nothing -> True     TCharacter CharLenStar _ -> True-    _                  -> False+    _ -> False   _ -> False  spec :: Spec@@ -583,7 +581,8 @@     it "Dynamic character static array" $ do       contents <- flexReadFile path       let st = getSymTable path contents "f4"-      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) (Just [(1, 5)])+      typeOf "arr" st+        `shouldBe` TArray (TCharacter CharLenStar 1) (Just [(1, 5)])       isDynamic "arr" st `shouldBe` True      it "Static character dynamic array" $ do

@@ -6,19 +6,17 @@ import           Data.List                      ( find ) import qualified Data.Map                      as M import           Data.Data                      ( Data )-import           Language.Fortran.Extras-                                                ( allPUS+import           Language.Fortran.Extras        ( allPUS                                                 , allPU                                                 )-import           Language.Fortran.Extras.Test-                                                ( getTestProgramAnalysis )+import           Language.Fortran.Extras.Test   ( getTestProgramAnalysis ) import           Language.Fortran.AST import           Language.Fortran.Analysis      ( stripAnalysis )-import           Language.Fortran.Vars ( programFileModel )-import           Language.Fortran.Vars.Types-                                                ( Type(..)+import           Language.Fortran.Vars          ( programFileModel )+import           Language.Fortran.Vars.Types    ( Type                                                 , SemType(..)-                                                , CharacterLen(..) )+                                                , CharacterLen(..)+                                                ) import           Language.Fortran.Vars.TypeCheck                                                 ( typeOf                                                 , TypeOf@@ -275,10 +273,11 @@     it "Logical Expression" $ do       (typeof, rhs) <- helper path puName       typeof (rhs "le1") `shouldBe` Right (TLogical 4)-      typeof (rhs "le2") `shouldBe` Right (TLogical 8)+      typeof (rhs "le2") `shouldBe` Right (TInteger 8)       typeof (rhs "le3") `shouldBe` Right (TLogical 2)       typeof (rhs "le4") `shouldBe` Right (TLogical 2)       typeof (rhs "le5") `shouldBe` Right (TLogical 4)+      typeof (rhs "le6") `shouldSatisfy` typeError      it "More expressions" $ do       (typeof, rhs) <- helper path puName@@ -350,6 +349,8 @@       typeof (rhs "b36") `shouldBe` Right (TInteger 4)       typeof (rhs "b37") `shouldBe` Right (TInteger 8)       typeof (rhs "b38") `shouldBe` Right (TLogical 4)+      typeof (rhs "b39") `shouldBe` Right (TReal 8)+      typeof (rhs "b40") `shouldBe` Right (TInteger 8)    describe "Implied Do" $ it "data statements" $ do     ProgramFile _ (pu : _) <- getTestProgramAnalysis