diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/fortran-vars.cabal b/fortran-vars.cabal --- a/fortran-vars.cabal +++ b/fortran-vars.cabal @@ -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 diff --git a/src/Language/Fortran/Vars/Assignments.hs b/src/Language/Fortran/Vars/Assignments.hs --- a/src/Language/Fortran/Vars/Assignments.hs +++ b/src/Language/Fortran/Vars/Assignments.hs @@ -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)) _) -> diff --git a/src/Language/Fortran/Vars/BozConstant.hs b/src/Language/Fortran/Vars/BozConstant.hs --- a/src/Language/Fortran/Vars/BozConstant.hs +++ b/src/Language/Fortran/Vars/BozConstant.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Call.hs b/src/Language/Fortran/Vars/Call.hs --- a/src/Language/Fortran/Vars/Call.hs +++ b/src/Language/Fortran/Vars/Call.hs @@ -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" diff --git a/src/Language/Fortran/Vars/CommonLayout.hs b/src/Language/Fortran/Vars/CommonLayout.hs --- a/src/Language/Fortran/Vars/CommonLayout.hs +++ b/src/Language/Fortran/Vars/CommonLayout.hs @@ -12,7 +12,7 @@ , ProgramUnitModel , StorageClass(..) , Offset - , Type(..) + , Type , SemType(..) , CharacterLen(..) ) diff --git a/src/Language/Fortran/Vars/Equivalence.hs b/src/Language/Fortran/Vars/Equivalence.hs --- a/src/Language/Fortran/Vars/Equivalence.hs +++ b/src/Language/Fortran/Vars/Equivalence.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Eval.hs b/src/Language/Fortran/Vars/Eval.hs --- a/src/Language/Fortran/Vars/Eval.hs +++ b/src/Language/Fortran/Vars/Eval.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Kind.hs b/src/Language/Fortran/Vars/Kind.hs --- a/src/Language/Fortran/Vars/Kind.hs +++ b/src/Language/Fortran/Vars/Kind.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Memory.hs b/src/Language/Fortran/Vars/Memory.hs --- a/src/Language/Fortran/Vars/Memory.hs +++ b/src/Language/Fortran/Vars/Memory.hs @@ -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 diff --git a/src/Language/Fortran/Vars/MemoryLocation.hs b/src/Language/Fortran/Vars/MemoryLocation.hs --- a/src/Language/Fortran/Vars/MemoryLocation.hs +++ b/src/Language/Fortran/Vars/MemoryLocation.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Operation.hs b/src/Language/Fortran/Vars/Operation.hs --- a/src/Language/Fortran/Vars/Operation.hs +++ b/src/Language/Fortran/Vars/Operation.hs @@ -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) diff --git a/src/Language/Fortran/Vars/Orphans.hs b/src/Language/Fortran/Vars/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Vars/Orphans.hs @@ -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 diff --git a/src/Language/Fortran/Vars/PureExpression.hs b/src/Language/Fortran/Vars/PureExpression.hs --- a/src/Language/Fortran/Vars/PureExpression.hs +++ b/src/Language/Fortran/Vars/PureExpression.hs @@ -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 diff --git a/src/Language/Fortran/Vars/StructureTable.hs b/src/Language/Fortran/Vars/StructureTable.hs --- a/src/Language/Fortran/Vars/StructureTable.hs +++ b/src/Language/Fortran/Vars/StructureTable.hs @@ -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 ) diff --git a/src/Language/Fortran/Vars/SymbolTable.hs b/src/Language/Fortran/Vars/SymbolTable.hs --- a/src/Language/Fortran/Vars/SymbolTable.hs +++ b/src/Language/Fortran/Vars/SymbolTable.hs @@ -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) diff --git a/src/Language/Fortran/Vars/TypeCheck.hs b/src/Language/Fortran/Vars/TypeCheck.hs --- a/src/Language/Fortran/Vars/TypeCheck.hs +++ b/src/Language/Fortran/Vars/TypeCheck.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Types.hs b/src/Language/Fortran/Vars/Types.hs --- a/src/Language/Fortran/Vars/Types.hs +++ b/src/Language/Fortran/Vars/Types.hs @@ -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 diff --git a/src/Language/Fortran/Vars/Utils.hs b/src/Language/Fortran/Vars/Utils.hs --- a/src/Language/Fortran/Vars/Utils.hs +++ b/src/Language/Fortran/Vars/Utils.hs @@ -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 ) diff --git a/test/AssignmentsSpec.hs b/test/AssignmentsSpec.hs --- a/test/AssignmentsSpec.hs +++ b/test/AssignmentsSpec.hs @@ -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" diff --git a/test/BozConstantSpec.hs b/test/BozConstantSpec.hs --- a/test/BozConstantSpec.hs +++ b/test/BozConstantSpec.hs @@ -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 diff --git a/test/StorageTableSpec.hs b/test/StorageTableSpec.hs --- a/test/StorageTableSpec.hs +++ b/test/StorageTableSpec.hs @@ -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(..) ) diff --git a/test/StructureTableSpec.hs b/test/StructureTableSpec.hs --- a/test/StructureTableSpec.hs +++ b/test/StructureTableSpec.hs @@ -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" diff --git a/test/SymbolTableSpec.hs b/test/SymbolTableSpec.hs --- a/test/SymbolTableSpec.hs +++ b/test/SymbolTableSpec.hs @@ -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 diff --git a/test/TypeCheckSpec.hs b/test/TypeCheckSpec.hs --- a/test/TypeCheckSpec.hs +++ b/test/TypeCheckSpec.hs @@ -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