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,57 @@ } } +void DataChecker::CheckDesignator(const parser::Designator &designator) { + evaluate::ExpressionAnalyzer exprAnalyzer{context_}; + 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 (IsAllocatable(*symbol)) { + context_.Say(name.source, + "Data Object must not be an allocatable object"_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); + } else if (FindCommonBlockContaining(*symbol)) { + if (const auto *details{ + (*symbol).detailsIf()}) { + if (details->commonBlock()) { + if (details->commonBlock()->name().empty()) { + context_.Say(name.source, + "Data Object must not be in blank COMMON"_err_en_US); + } else if (scope.kind() != Scope::Kind::BlockData) { + context_.Say(name.source, + "Data Object must not be in a named COMMON block"_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))) { + context_.Say(name.source, + "Data Object must not be an automatic array"_err_en_US); + } + } + } + } +} + void DataChecker::CheckSubscript(const parser::SectionSubscript &subscript) { std::visit(common::visitors{ [&](const parser::SubscriptTriplet &triplet) { @@ -35,28 +86,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(source, + "Only right most reference 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; }, }, @@ -80,11 +138,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 +152,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 +165,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/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,92 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +!Testing data constraints : C876, C877 +module m + integer :: first + real :: second, third + 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 must not be in a named COMMON block + DATA a /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) + !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 must not be an allocatable object + DATA a /1/ + !C876 + !ERROR: Data Object must not be an automatic array + DATA b(0) /1/ + f = i *1024 + end + + subroutine CheckObject + type specialNumbers + integer one + integer numbers(5) + type(specialNumbers), pointer :: headOfTheList + end type + type large + integer elt(10) + integer val + type(specialNumbers) nums + type(specialNumbers) numsArray(5) + end type + type(large) largeNumber + !C877 + !OK: Correct use + DATA(largeNumber % numsArray(j) % headOfTheList, j = 1, 10) / 10 * NULL() / + !C877 + !ERROR: Only right most reference of data object can be a pointer + DATA(largeNumber % numsArray(j) % headOfTheList % one, j = 1, 10) / 10 * NULL() / + 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 i + end + + program new + use m2 + integer a,b + real f,r,x,y + COMMON r,a,f + r = 1 + a = 1 + f = 1 + !C876 + !ERROR: Data Object must not be in blank COMMON + DATA r /1/ + !C876 + !ERROR: Data Object must not be accessed by use association + DATA i /1/ + end program