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 @@ -164,6 +164,19 @@ const auto *details{symbol.detailsIf()}; return details && details->IsAssumedRank(); } +inline bool IsAutomaticArray(const Symbol &symbol) { + 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 &); bool IsExternal(const Symbol &); // Is the symbol modifiable in this scope diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h --- a/flang/lib/Semantics/check-data.h +++ b/flang/lib/Semantics/check-data.h @@ -27,7 +27,8 @@ SemanticsContext &context_; template void CheckIfConstantSubscript(const T &); void CheckSubscript(const parser::SectionSubscript &); - bool CheckAllSubscriptsInDataRef(const parser::DataRef &, parser::CharBlock); + bool CheckDataRef(const parser::DataRef &, parser::CharBlock, bool); + void CheckDesignator(const parser::Designator &); }; } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_CHECK_DATA_H_ 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 @@ -20,6 +20,59 @@ } } +void DataChecker::CheckDesignator(const parser::Designator &designator) { + const auto name{parser::GetLastName(designator)}; + const Scope &scope{context_.FindScope(designator.source)}; + if (const Symbol * + symbol{name.symbol ? &name.symbol->GetUltimate() : nullptr}) { // C876 + if (symbol->IsDummy()) { + context_.Say( + name.source, "Data object must not be a dummy argument"_err_en_US); + } else if (IsFunction(*symbol)) { + context_.Say( + name.source, "Data object must not be a function name"_err_en_US); + } else if (symbol->IsFuncResult()) { + context_.Say( + name.source, "Data object must not be a function result"_err_en_US); + } else if (IsHostAssociated(*symbol, scope)) { + context_.Say(name.source, + "Data object must not be accessed by host association"_err_en_US); + } else if (IsUseAssociated(*symbol, scope)) { + context_.Say(name.source, + "Data object must not be accessed by use association"_err_en_US); + } + } + evaluate::ExpressionAnalyzer exprAnalyzer{context_}; + if (MaybeExpr checked{exprAnalyzer.Analyze(designator)}) { + for (const Symbol &symbol : evaluate::CollectSymbols(*checked)) { + if (FindCommonBlockContaining(symbol)) { + if (const auto *details{ + symbol.detailsIf()}) { + if (details->commonBlock()) { + if (details->commonBlock()->name().empty()) { + context_.Say(designator.source, + "Data object part '%s' must not be in blank COMMON"_err_en_US, + symbol.name().ToString()); + } else if (scope.kind() != Scope::Kind::BlockData) { + context_.Say(designator.source, + "Data object part '%s' must not be in a named COMMON block outside a BLOCK DATA program unit"_err_en_US, + symbol.name().ToString()); + } + } + } + } else if (IsAutomaticArray(symbol)) { + context_.Say(designator.source, + "Data object part '%s' must not be an automatic array"_err_en_US, + symbol.name().ToString()); + } else if (IsAllocatable(symbol)) { + context_.Say(designator.source, + "Data object part '%s' must not be an allocatable object"_err_en_US, + symbol.name().ToString()); + } + } + } +} + void DataChecker::CheckSubscript(const parser::SectionSubscript &subscript) { std::visit(common::visitors{ [&](const parser::SubscriptTriplet &triplet) { @@ -35,28 +88,35 @@ } // Returns false if DataRef has no subscript -bool DataChecker::CheckAllSubscriptsInDataRef( - const parser::DataRef &dataRef, parser::CharBlock source) { +bool DataChecker::CheckDataRef(const parser::DataRef &dataRef, + parser::CharBlock source, bool isRightMostRef) { + if (!isRightMostRef) { + const auto name{parser::GetLastName(dataRef)}; + const Symbol *symbol{name.symbol ? &name.symbol->GetUltimate() : nullptr}; + if (IsPointer(*symbol)) { // C877 + context_.Say(name.source, + "Only right-most part of data object can be a pointer"_err_en_US); + } + } return std::visit( common::visitors{ [&](const parser::Name &) { return false; }, [&](const common::Indirection &structureComp) { - return CheckAllSubscriptsInDataRef( - structureComp.value().base, source); + return CheckDataRef(structureComp.value().base, source, false); }, [&](const common::Indirection &arrayElem) { for (auto &subscript : arrayElem.value().subscripts) { CheckSubscript(subscript); } - CheckAllSubscriptsInDataRef(arrayElem.value().base, source); + CheckDataRef(arrayElem.value().base, source, false); return true; }, [&](const common::Indirection &coindexedObj) { // C874 context_.Say(source, "Data object must not be a coindexed variable"_err_en_US); - CheckAllSubscriptsInDataRef(coindexedObj.value().base, source); + CheckDataRef(coindexedObj.value().base, source, false); return true; }, }, @@ -64,7 +124,7 @@ } void DataChecker::Leave(const parser::DataStmtConstant &dataConst) { - if (auto *structure{ + if (const auto *structure{ std::get_if(&dataConst.u)}) { for (const auto &component : std::get>(structure->t)) { @@ -80,11 +140,12 @@ } } -// TODO: C876, C877, C879 +// TODO: C879 void DataChecker::Leave(const parser::DataImpliedDo &dataImpliedDo) { for (const auto &object : std::get>(dataImpliedDo.t)) { if (const auto *designator{parser::Unwrap(object)}) { + CheckDesignator(*designator); if (auto *dataRef{std::get_if(&designator->u)}) { evaluate::ExpressionAnalyzer exprAnalyzer{context_}; if (MaybeExpr checked{exprAnalyzer.Analyze(*dataRef)}) { @@ -93,8 +154,7 @@ "Data implied do object must be a variable"_err_en_US); } } - if (!CheckAllSubscriptsInDataRef(*dataRef, - designator->source)) { // C880 + if (!CheckDataRef(*dataRef, designator->source, true)) { // C880 context_.Say(designator->source, "Data implied do object must be subscripted"_err_en_US); } @@ -107,8 +167,9 @@ if (std::get_if>(&dataObject.u)) { if (const auto *designator{ parser::Unwrap(dataObject)}) { + CheckDesignator(*designator); if (auto *dataRef{std::get_if(&designator->u)}) { - CheckAllSubscriptsInDataRef(*dataRef, designator->source); + CheckDataRef(*dataRef, designator->source, true); } } else { // C875 context_.Say(parser::FindSourceLocation(dataObject), 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 (IsAutomaticArray(symbol)) { + msg = "Automatic array '%s'" + " is not allowed in an equivalence set"_err_en_US; } } if (!msg.text().empty()) { 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,6 +1,7 @@ ! RUN: %B/test/Semantics/test_errors.sh %s %flang %t !Test for checking data constraints, C882-C887 -module m1 + +subroutine CheckRepeat type person integer :: age character(len=25) :: name @@ -11,10 +12,6 @@ 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,15 +36,20 @@ 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') / + data myName / person(1, 'Abcd Ijkl') / !C883 !ERROR: 'persn' is not an array - data myname / persn(2, 'Abcd Efgh') / + data myName / persn(2, 'Abcd Efgh') / !C884 !ERROR: Structure constructor in data value must be a constant expression - data myname / person(myAge, 'Abcd Ijkl') / + data myName / person(myAge, 'Abcd Ijkl') / integer, parameter :: a(5) =(/11, 22, 33, 44, 55/) integer :: b(5) =(/11, 22, 33, 44, 55/) integer :: i 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,113 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +!Testing data constraints : C876, C877 +module m + integer :: first + contains + subroutine h + integer a,b + !ERROR: Data object must not be accessed by host association + DATA first /1/ + common /c/ a,b + !ERROR: Data object part 'a' must not be in a named COMMON block outside a BLOCK DATA program unit + DATA a /1/ + end subroutine + + function g(i) + type newType + sequence + integer number + end type + type(newType) num + common /c/ num + !ERROR: Data object part 'num' must not be in a named COMMON block outside a BLOCK DATA program unit + DATA num%number /1/ + integer ::i + g = i *1024 + end + + function f(i) + integer ::i + integer ::result + integer, allocatable :: a + integer :: b(i) + !C876 + !ERROR: Data object must not be a dummy argument + DATA i /1/ + !C876 + !ERROR: Data object must not be a function result + DATA f /1/ + !C876 + !ERROR: Data object 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 array + DATA b(0) /1/ + f = i *1024 + end + + subroutine CheckObject(i) + type specialNumbers + integer one + integer numbers(5) + type(specialNumbers), pointer :: headOfTheList + end type + type large + integer, allocatable :: elt(:) + integer val + type(specialNumbers) numsArray(5) + end type + type(large) largeNumber + type(large), allocatable :: allocatableLarge + type(large) :: largeNumberArray(i) + !C877 + !OK: Correct use + DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() / + !C877 + !ERROR: Only right-most part of data object can be a pointer + DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * NULL() / + !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 'largenumberarray' must not be an automatic array + DATA(largeNumberArray(j) % val, j = 1, 10) / 10 * NULL() / + !C876 + !ERROR: Data object part 'allocatablelarge' must not be an allocatable object + DATA allocatableLarge % val / 1 / + 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 + end + + program new + use m2 + integer a + real b,c + COMMON b,a,c + !C876 + !ERROR: Data object part 'b' must not be in blank COMMON + DATA b /1/ + !C876 + !ERROR: Data object must not be accessed by use association + DATA m2_i /1/ + !C876 + !ERROR: Data object must not be accessed by use association + DATA m2_number1%number /1/ + end program