diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -146,6 +146,8 @@ bool IsFinalizable(const DerivedTypeSpec &); bool HasImpureFinal(const DerivedTypeSpec &); bool IsCoarray(const Symbol &); +bool IsInBlankCommon(const Symbol &); +bool IsAutomaticObject(const Symbol &); inline bool IsAssumedSizeArray(const Symbol &symbol) { const auto *details{symbol.detailsIf()}; return details && details->IsAssumedSize(); diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -59,7 +59,9 @@ } return true; } - + bool operator()(const Component &component) const { + return (*this)(component.base()); + } // Forbid integer division by zero in constants. template bool operator()( diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp --- a/flang/lib/Semantics/check-data.cpp +++ b/flang/lib/Semantics/check-data.cpp @@ -56,22 +56,69 @@ } bool operator()(const evaluate::Component &component) { hasComponent_ = true; - return (*this)(component.base()); + const Symbol &lastSymbol{component.GetLastSymbol()}; + if (isPointerAllowed_) { + if (IsPointer(lastSymbol) && hasSubscript_) { // C877 + context_.Say(source_, + "Rightmost data object pointer '%s' must not be subscripted"_err_en_US, + lastSymbol.name().ToString()); + return false; + } + RestrictPointer(); + } else { + if (IsPointer(lastSymbol)) { // C877 + context_.Say(source_, + "Data object must not contain pointer '%s' as a non-rightmost part"_err_en_US, + lastSymbol.name().ToString()); + return false; + } + } + if (!isFirstSymbolChecked_) { + isFirstSymbolChecked_ = true; + if (!CheckFirstSymbol(component.GetFirstSymbol())) { + return false; + } + } + return (*this)(component.base()) && (*this)(lastSymbol); } - bool operator()(const evaluate::Subscript &subs) { + bool operator()(const evaluate::ArrayRef &arrayRef) { hasSubscript_ = true; + return (*this)(arrayRef.base()) && (*this)(arrayRef.subscript()); + } + bool operator()(const evaluate::Substring &substring) { + hasSubscript_ = true; + return (*this)(substring.parent()) && (*this)(substring.lower()) && + (*this)(substring.upper()); + } + bool operator()(const evaluate::CoarrayRef &) { // C874 + hasSubscript_ = true; + context_.Say( + source_, "Data object must not be a coindexed variable"_err_en_US); + return false; + } + bool operator()(const evaluate::Symbol &symbol) { + if (!isFirstSymbolChecked_) { + return CheckFirstSymbol(symbol) && CheckAnySymbol(symbol); + } else { + return CheckAnySymbol(symbol); + } + } + bool operator()(const evaluate::Subscript &subs) { + DataVarChecker subscriptChecker{context_, source_}; + subscriptChecker.RestrictPointer(); return std::visit( - common::visitors{ - [&](const evaluate::IndirectSubscriptIntegerExpr &expr) { - return CheckSubscriptExpr(expr); - }, - [&](const evaluate::Triplet &triplet) { - return CheckSubscriptExpr(triplet.lower()) && - CheckSubscriptExpr(triplet.upper()) && - CheckSubscriptExpr(triplet.stride()); - }, - }, - subs.u); + common::visitors{ + [&](const evaluate::IndirectSubscriptIntegerExpr &expr) { + return CheckSubscriptExpr(expr); + }, + [&](const evaluate::Triplet &triplet) { + return CheckSubscriptExpr(triplet.lower()) && + CheckSubscriptExpr(triplet.upper()) && + CheckSubscriptExpr(triplet.stride()); + }, + }, + subs.u) && + subscriptChecker(subs.u); } template bool operator()(const evaluate::FunctionRef &) const { // C875 @@ -79,11 +126,7 @@ "Data object variable must not be a function reference"_err_en_US); return false; } - bool operator()(const evaluate::CoarrayRef &) const { // C874 - context_.Say( - source_, "Data object must not be a coindexed variable"_err_en_US); - return false; - } + void RestrictPointer() { isPointerAllowed_ = false; } private: bool CheckSubscriptExpr( @@ -104,21 +147,71 @@ return true; } } + bool CheckFirstSymbol(const Symbol &symbol); + bool CheckAnySymbol(const Symbol &symbol); SemanticsContext &context_; parser::CharBlock source_; bool hasComponent_{false}; bool hasSubscript_{false}; + bool isPointerAllowed_{true}; + bool isFirstSymbolChecked_{false}; }; -// TODO: C876, C877, C879 +bool DataVarChecker::CheckFirstSymbol(const Symbol &symbol) { // C876 + const Scope &scope{context_.FindScope(source_)}; + if (IsDummy(symbol)) { + context_.Say(source_, + "Data object part '%s' must not be a dummy argument"_err_en_US, + symbol.name().ToString()); + } else if (IsFunction(symbol)) { + context_.Say(source_, + "Data object part '%s' must not be a function name"_err_en_US, + symbol.name().ToString()); + } else if (symbol.IsFuncResult()) { + context_.Say(source_, + "Data object part '%s' must not be a function result"_err_en_US, + symbol.name().ToString()); + } else if (IsHostAssociated(symbol, scope)) { + context_.Say(source_, + "Data object part '%s' must not be accessed by host association"_err_en_US, + symbol.name().ToString()); + } else if (IsUseAssociated(symbol, scope)) { + context_.Say(source_, + "Data object part '%s' must not be accessed by use association"_err_en_US, + symbol.name().ToString()); + } else if (IsInBlankCommon(symbol)) { + context_.Say(source_, + "Data object part '%s' must not be in blank COMMON"_err_en_US, + symbol.name().ToString()); + } else { + return true; + } + return false; +} + +bool DataVarChecker::CheckAnySymbol(const Symbol &symbol) { // C876 + if (IsAutomaticObject(symbol)) { + context_.Say(source_, + "Data object part '%s' must not be an automatic object"_err_en_US, + symbol.name().ToString()); + } else if (IsAllocatable(symbol)) { + context_.Say(source_, + "Data object part '%s' must not be an allocatable object"_err_en_US, + symbol.name().ToString()); + } else { + return true; + } + return false; +} + void DataChecker::Leave(const parser::DataIDoObject &object) { if (const auto *designator{ std::get_if>>( &object.u)}) { if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) { auto source{designator->thing.value().source}; - if (evaluate::IsConstantExpr(*expr)) { // C878 + if (evaluate::IsConstantExpr(*expr)) { // C878,C879 exprAnalyzer_.Say( source, "Data implied do object must be a variable"_err_en_US); } else { diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp --- a/flang/lib/Semantics/resolve-names-utils.cpp +++ b/flang/lib/Semantics/resolve-names-utils.cpp @@ -595,16 +595,9 @@ msg = "Nonsequence derived type object '%s'" " is not allowed in an equivalence set"_err_en_US; } - } else if (symbol.IsObjectArray()) { - for (const ShapeSpec &spec : symbol.get().shape()) { - auto &lbound{spec.lbound().GetExplicit()}; - auto &ubound{spec.ubound().GetExplicit()}; - if ((lbound && !evaluate::ToInt64(*lbound)) || - (ubound && !evaluate::ToInt64(*ubound))) { - msg = "Automatic array '%s'" - " is not allowed in an equivalence set"_err_en_US; - } - } + } else if (IsAutomaticObject(symbol)) { + msg = "Automatic object '%s'" + " is not allowed in an equivalence set"_err_en_US; } } if (!msg.text().empty()) { diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -581,6 +581,35 @@ bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; } +bool IsAutomaticObject(const Symbol &symbol) { + if (IsDummy(symbol) || IsPointer(symbol) || IsAllocatable(symbol)) { + return false; + } + if (const DeclTypeSpec * type{symbol.GetType()}) { + if (type->category() == DeclTypeSpec::Character) { + ParamValue length{type->characterTypeSpec().length()}; + if (length.isExplicit()) { + if (MaybeIntExpr lengthExpr{length.GetExplicit()}) { + if (!ToInt64(lengthExpr)) { + return true; + } + } + } + } + } + if (symbol.IsObjectArray()) { + for (const ShapeSpec &spec : symbol.get().shape()) { + auto &lbound{spec.lbound().GetExplicit()}; + auto &ubound{spec.ubound().GetExplicit()}; + if ((lbound && !evaluate::ToInt64(*lbound)) || + (ubound && !evaluate::ToInt64(*ubound))) { + return true; + } + } + } + return false; +} + bool IsAssumedLengthCharacter(const Symbol &symbol) { if (const DeclTypeSpec * type{symbol.GetType()}) { return type->category() == DeclTypeSpec::Character && @@ -590,6 +619,20 @@ } } +bool IsInBlankCommon(const Symbol &symbol) { + if (FindCommonBlockContaining(symbol)) { + if (const auto *details{ + symbol.detailsIf()}) { + if (details->commonBlock()) { + if (details->commonBlock()->name().empty()) { + return true; + } + } + } + } + return false; +} + // C722 and C723: For a function to be assumed length, it must be external and // of CHARACTER type bool IsExternal(const Symbol &symbol) { diff --git a/flang/test/Lower/pre-fir-tree02.f90 b/flang/test/Lower/pre-fir-tree02.f90 --- a/flang/test/Lower/pre-fir-tree02.f90 +++ b/flang/test/Lower/pre-fir-tree02.f90 @@ -326,7 +326,7 @@ end subroutine ! CHECK: Subroutine sub4 -subroutine sub4(i, j) +subroutine sub4() integer :: i print*, "test" ! CHECK: DataStmt diff --git a/flang/test/Semantics/block-data01.f90 b/flang/test/Semantics/block-data01.f90 --- a/flang/test/Semantics/block-data01.f90 +++ b/flang/test/Semantics/block-data01.f90 @@ -11,9 +11,6 @@ procedure(sin), pointer :: p => cos !ERROR: 'p' is already declared as a procedure common /block/ pi, p - real :: inBlankCommon - data inBlankCommon / 1.0 / - common inBlankCommon !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block integer :: inDataButNotCommon data inDataButNotCommon /1/ diff --git a/flang/test/Semantics/data01.f90 b/flang/test/Semantics/data01.f90 --- a/flang/test/Semantics/data01.f90 +++ b/flang/test/Semantics/data01.f90 @@ -1,20 +1,16 @@ ! RUN: %S/test_errors.sh %s %t %f18 !Test for checking data constraints, C882-C887 -module m1 +subroutine CheckRepeat type person integer :: age character(len=25) :: name end type integer, parameter::digits(5) = ( /-11,-22,-33,44,55/ ) - integer ::notConstDigits(5) = ( /-11,-22,-33,44,55/ ) + integer ::notConstDigits(5) real, parameter::numbers(5) = ( /-11.11,-22.22,-33.33,44.44,55.55/ ) integer, parameter :: repeat = -1 integer :: myAge = 2 type(person) myName -end - -subroutine CheckRepeat - use m1 !C882 !ERROR: Missing initialization for parameter 'uninitialized' integer, parameter :: uninitialized @@ -39,7 +35,12 @@ end subroutine CheckValue - use m1 + type person + integer :: age + character(len=25) :: name + end type + integer :: myAge = 2 + type(person) myName !OK: constant structure constructor data myname / person(1, 'Abcd Ijkl') / !C883 diff --git a/flang/test/Semantics/data03.f90 b/flang/test/Semantics/data03.f90 --- a/flang/test/Semantics/data03.f90 +++ b/flang/test/Semantics/data03.f90 @@ -62,6 +62,12 @@ !C880 !ERROR: Data implied do structure component must be subscripted DATA(nums % one, i = 1, 5) / 5 * 1 / + !C879 + !ERROR: Data implied do object must be a variable + DATA(newNums % numbers(i), i = 1, 5) / 5 * 1 / + !C879 + !ERROR: Data implied do object must be a variable + DATA(newNumsArray(i) % one, i = 1, 5) / 5 * 1 / !C880 !OK: Correct use DATA(largeArray(j) % nums % one, j = 1, 10) / 10 * 1 / diff --git a/flang/test/Semantics/data04.f90 b/flang/test/Semantics/data04.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/data04.f90 @@ -0,0 +1,155 @@ +! RUN: %S/test_errors.sh %s %t %f18 +!Testing data constraints : C876, C877 +module m + integer :: first + contains + subroutine h + integer a,b + !C876 + !ERROR: Data object part 'first' must not be accessed by host association + DATA first /1/ + end subroutine + + function g(i) + integer ::i + g = i *1024 + end + + function f(i) + integer ::i + integer ::result + integer, allocatable :: a + integer :: b(i) + character(len=i), pointer:: charPtr + character(len=i), allocatable:: charAlloc + !C876 + !ERROR: Data object part 'i' must not be a dummy argument + DATA i /1/ + !C876 + !ERROR: Data object part 'f' must not be a function result + DATA f /1/ + !C876 + !ERROR: Data object part 'g' must not be a function name + DATA g /1/ + !C876 + !ERROR: Data object part 'a' must not be an allocatable object + DATA a /1/ + !C876 + !ERROR: Data object part 'b' must not be an automatic object + DATA b(0) /1/ + !C876 + !Ok: As charPtr is a pointer, it is not an automatic object + DATA charPtr / NULL() / + !C876 + !ERROR: Data object part 'charalloc' must not be an allocatable object + DATA charAlloc / 'abc' / + f = i *1024 + end + + subroutine CheckObject(i) + type specialNumbers + integer one + integer numbers(5) + type(specialNumbers), pointer :: headOfTheList + integer, pointer, dimension(:) :: ptoarray + character, pointer, dimension(:) :: ptochar + end type + type large + integer, allocatable :: allocVal + integer, allocatable :: elt(:) + integer val + type(specialNumbers) numsArray(5) + end type + type(large) largeNumber + type(large), allocatable :: allocatableLarge + type(large) :: largeNumberArray(i) + type(large) :: largeArray(5) + character :: name(i) + !C877 + !OK: Correct use + DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() / + !C877 + !ERROR: Data object must not contain pointer 'headofthelist' as a non-rightmost part + DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * NULL() / + !C877 + !ERROR: Rightmost data object pointer 'ptoarray' must not be subscripted + DATA(largeNumber % numsArray(j) % ptoarray(1), j = 1, 10) / 10 * 1 / + !C877 + !ERROR: Rightmost data object pointer 'ptochar' must not be subscripted + DATA largeNumber % numsArray(0) % ptochar(1:2) / 'ab' / + !C876 + !ERROR: Data object part 'elt' must not be an allocatable object + DATA(largeNumber % elt(j) , j = 1, 10) / 10 * 1/ + !C876 + !ERROR: Data object part 'allocval' must not be an allocatable object + DATA(largeArray(j) % allocVal , j = 1, 10) / 10 * 1/ + !C876 + !ERROR: Data object part 'allocatablelarge' must not be an allocatable object + DATA allocatableLarge % val / 1 / + !C876 + !ERROR: Data object part 'largenumberarray' must not be an automatic object + DATA(largeNumberArray(j) % val, j = 1, 10) / 10 * NULL() / + !C876 + !ERROR: Data object part 'name' must not be an automatic object + DATA name( : 2) / 'Ancd' / + end + end + + block data foo + integer :: a,b + common /c/ a,b + !C876 + !OK: Correct use + DATA a /1/ + end block data + + module m2 + integer m2_i + type newType + integer number + end type + type(newType) m2_number1 + contains + + subroutine checkDerivedType(m2_number) + type(newType) m2_number + type(newType) m2_number3 + !C876 + !ERROR: Data object part 'm2_number' must not be a dummy argument + DATA m2_number%number /1/ + !C876 + !ERROR: Data object part 'm2_number1' must not be accessed by host association + DATA m2_number1%number /1/ + !C876 + !OK: m2_number3 is not associated through use association + DATA m2_number3%number /1/ + end + end + + program new + use m2 + integer a + real b,c + type seqType + sequence + integer number + end type + type(SeqType) num + COMMON b,a,c,num + type(newType) m2_number2 + !C876 + !ERROR: Data object part 'b' must not be in blank COMMON + DATA b /1/ + !C876 + !ERROR: Data object part 'm2_i' must not be accessed by use association + DATA m2_i /1/ + !C876 + !ERROR: Data object part 'm2_number1' must not be accessed by use association + DATA m2_number1%number /1/ + !C876 + !OK: m2_number2 is not associated through use association + DATA m2_number2%number /1/ + !C876 + !ERROR: Data object part 'num' must not be in blank COMMON + DATA num%number /1/ + end program diff --git a/flang/test/Semantics/equivalence01.f90 b/flang/test/Semantics/equivalence01.f90 --- a/flang/test/Semantics/equivalence01.f90 +++ b/flang/test/Semantics/equivalence01.f90 @@ -128,7 +128,7 @@ subroutine s11(n) integer :: n real :: x(n), y - !ERROR: Automatic array 'x' is not allowed in an equivalence set + !ERROR: Automatic object 'x' is not allowed in an equivalence set equivalence(x(1), y) end