From 872e5ac2d6e973ca6a9ac51351d410b532a6a496 Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Tue, 22 Nov 2022 17:52:31 +0000 Subject: [PATCH] Support better type checking of array sections Previously it would just return the type of the array, not taking into account what the section is referring to, which is somewhat ok for 1 dimensional arrays but for more dimensions it really should tell us the expression is a single dimensional array. This helps us check whether interfaces usage is valid, which does care about the dimensionality. --- src/Language/Fortran/Vars/TypeCheck.hs | 91 +++++++++++++++++++------- test/TypeCheckSpec.hs | 8 ++- test/type_check/array_and_substring.f | 2 + 3 files changed, 76 insertions(+), 25 deletions(-) diff --git a/src/Language/Fortran/Vars/TypeCheck.hs b/src/Language/Fortran/Vars/TypeCheck.hs index 33d009d..76d0e55 100644 --- a/src/Language/Fortran/Vars/TypeCheck.hs +++ b/src/Language/Fortran/Vars/TypeCheck.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} module Language.Fortran.Vars.TypeCheck ( Kind @@ -12,10 +11,11 @@ import Prelude hiding ( GT , EQ , LT ) -import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import qualified Data.Map as M import Data.Data ( toConstr ) import Data.Maybe ( fromJust ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE import Language.Fortran.AST ( Expression(..) , Value(..) , AList(..) @@ -60,6 +60,7 @@ import Language.Fortran.Vars.Types ( SymbolTableEntry(..) , typeError , Dim(..) , Dims(..) + , dimsLength ) import Language.Fortran.Vars.Kind ( getTypeKind , setTypeKind @@ -70,7 +71,9 @@ import Language.Fortran.Vars.StructureTable ( lookupField ) import Language.Fortran.Analysis.SemanticTypes - ( charLenConcat ) + ( Dimensions + , charLenConcat + ) -- | Given 'SymbolTable' of a 'ProgramUnit', and an 'Expression' within @@ -96,11 +99,13 @@ typeOf strTable symTable expr = case expr of Right _ -> Left . typeError s $ "Tried to access elements of scalar" err -> err - ExpSubscript _ s arr (AList _ _ (r@IxRange{} : _)) -> do + ExpSubscript _ s arr (AList _ _ (r@IxRange{} : rs)) -> do ty <- typeOf strTable symTable arr case ty of TCharacter _ _ -> typeOfSubString s symTable strTable ty r - _ -> Right ty + TArray ety dims -> + typeOfArraySection s symTable strTable dims (r :| rs) ety + _ -> Right ty ExpImpliedDo _ _ es doSpec -> do dim <- specToDim symTable doSpec ty <- typeOf strTable symTable . head $ aStrip es @@ -264,6 +269,41 @@ typeOfBinaryExp' sp op t1 t2 k1 = getTypeKind t1 k2 = getTypeKind t2 +typeOfArraySection + :: SrcSpan + -> SymbolTable + -> StructureTable + -> Dimensions + -> NonEmpty (Index a) + -> Type + -> Either TypeError Type +typeOfArraySection ss symt strt dims ((IxRange _ _ lower upper _) :| ixs) ty + | any isIxRange ixs = Left . typeError ss $ "Unexpected ranges" + | (length ixs + 1) /= dimsLength dims = Left . typeError ss $ "Mismatched indices" + | otherwise = do + isInteger ss $ traverse (typeOf strt symt) lower + isInteger ss $ traverse (typeOf strt symt) upper + case calcLen of + Nothing -> Right $ TArray ty (DimsAssumedSize Nothing lowerIndex) + -- Always return lower 1 because it's not specified + Just len -> Right $ TArray ty (DimsExplicitShape $ Dim (Just 1) (Just len) :| []) + where + calcLen = (\x y -> y - x + 1) <$> lowerIndex <*> upperIndex + isIxRange = \case + IxRange{} -> True + _ -> False + upperIndex :: Maybe Int + upperIndex = case dims of + DimsExplicitShape dims' -> do + upperIx <- dimUpper $ NE.head dims' + getIndex symt upperIx upper + DimsAssumedSize (Just (Dim _ u :| _)) _ -> do + upperIx <- u + getIndex symt upperIx upper + DimsAssumedSize Nothing u -> u + DimsAssumedShape _ -> Nothing + lowerIndex = getIndex symt 1 lower +typeOfArraySection _ _ _ _ _ _ = error "Internal error" -- | Internal function to determine the type of a substring -- If either of the indexes cannot be evaluated then we return a dynamically @@ -277,27 +317,34 @@ typeOfSubString -> Index a -> Either TypeError Type typeOfSubString sp symt strt ty (IxRange _ _ lower upper _) = do - isInteger $ traverse (typeOf strt symt) lower - isInteger $ traverse (typeOf strt symt) upper + isInteger sp $ traverse (typeOf strt symt) lower + isInteger sp $ 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 - isInteger = \case - Right (Just (TInteger _)) -> Right () - Right Nothing -> Right () - _ -> Left . typeError sp $ "Index wasn't an integer type" - upperIndex = let Just k = getTypeKind ty in getIndex k upper - lowerIndex = getIndex 1 lower - getIndex :: Int -> Maybe (Expression a) -> Maybe Int - getIndex dflt Nothing = Just dflt - getIndex _ (Just e) = case eval' symt e of - Right (Int i) -> Just i - _ -> Nothing - + calcLen = maybe CharLenStar + CharLenInt + ((\x y -> y - x + 1) <$> lowerIndex <*> upperIndex) + upperIndex = do + k <- getTypeKind ty + getIndex symt k upper + lowerIndex = getIndex symt 1 lower typeOfSubString _ _ _ _ idx = Left $ UnknownType (getSpan idx) + +-- | Aux function used in typeOfSubstring and typeOfArraySection +getIndex :: SymbolTable -> Int -> Maybe (Expression a) -> Maybe Int +getIndex _ dflt Nothing = Just dflt +getIndex symt _ (Just e) = case eval' symt e of + Right (Int i) -> Just i + _ -> Nothing + +isInteger :: SrcSpan -> Either TypeError (Maybe SemType) -> Either TypeError () +isInteger sp = \case + Right (Just (TInteger _)) -> Right () + Right Nothing -> Right () + Left err -> Left err + _ -> Left . typeError sp $ "Index wasn't an integer type" + -- | determine the return type of a function call typeOfFunctionCall :: SrcSpan diff --git a/test/TypeCheckSpec.hs b/test/TypeCheckSpec.hs index e14cb88..8a83472 100644 --- a/test/TypeCheckSpec.hs +++ b/test/TypeCheckSpec.hs @@ -29,6 +29,7 @@ import Language.Fortran.Vars.SymbolTable ( collectSymbols ) import Language.Fortran.Vars.StructureTable ( collectStructures ) +import Language.Fortran.Analysis.SemanticTypes (Dims(DimsAssumedSize)) -- | Given a varaible name, 'RHSFunc' search assignment statements within a program -- unit and returns the RHS of first assignment statement whose LHS matches the @@ -183,9 +184,10 @@ spec = do it "Index ranges" $ do (typeof, rhs) <- helper path puName - typeof (rhs "i1") `shouldBe` Right (TArray (TInteger 4) (dess1 1 10)) - typeof (rhs "i2") `shouldBe` Right (TArray (TInteger 4) (dess1 1 10)) - typeof (rhs "i3") `shouldBe` Right (TArray (TInteger 4) (DimsExplicitShape (Dim (Just 1) Nothing :| []))) + typeof (rhs "i1") `shouldBe` Right (TArray (TInteger 4) (dess1 1 3)) + typeof (rhs "i2") `shouldBe` Right (TArray (TInteger 4) (dess1 1 1)) + typeof (rhs "i3") `shouldBe` Right (TArray (TInteger 4) (DimsAssumedSize Nothing (Just 3))) + typeof (rhs "i4") `shouldBe` Right (TArray (TInteger 2) (dess1 1 6)) it "Erroneous expressions" $ do -- These expressions aren't valid but any subscript can be assumed to diff --git a/test/type_check/array_and_substring.f b/test/type_check/array_and_substring.f index c219111..e73d382 100644 --- a/test/type_check/array_and_substring.f +++ b/test/type_check/array_and_substring.f @@ -4,6 +4,7 @@ subroutine array(c,d,N) integer N integer c(N) ! adjustable integer d(10, *) ! assumed-size + integer*2 e(10, 10) C test the types of RHS expressions arr1 = a(1) @@ -16,6 +17,7 @@ subroutine array(c,d,N) i1 = a(3:5) i2 = a(1:1) i3 = c(3:) + i4 = e(5:, 2) c test erroneous expressions where we have too many indices err1 = a(2, 3)