diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -58,6 +58,11 @@ print "('>',a10,'<')", buffer end ``` +* The name of the control variable in an implied DO loop in an array + constructor or DATA statement has a scope over the value-list only, + not the bounds of the implied DO loop. It is not advisable to use + an object of the same name as the index variable in a bounds + expression, but it will work, instead of being needlessly undefined. ## Extensions, deletions, and legacy features supported by default diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1409,15 +1409,6 @@ if (const auto dynamicType{DynamicType::From(symbol)}) { kind = dynamicType->kind(); } - if (!exprAnalyzer_.AddImpliedDo(name, kind)) { - if (!(messageDisplayedSet_ & 0x20)) { - exprAnalyzer_.SayAt(name, - "Implied DO index is active in surrounding implied DO loop " - "and may not have the same name"_err_en_US); // C7115 - messageDisplayedSet_ |= 0x20; - } - return; - } std::optional> lower{ GetSpecificIntExpr(bounds.lower)}; std::optional> upper{ @@ -1428,49 +1419,57 @@ if (!stride) { stride = Expr{1}; } - // Check for constant bounds; the loop may require complete unrolling - // of the parse tree if all bounds are constant in order to allow the - // implied DO loop index to qualify as a constant expression. - auto cLower{ToInt64(lower)}; - auto cUpper{ToInt64(upper)}; - auto cStride{ToInt64(stride)}; - if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) { - exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source, - "The stride of an implied DO loop must not be zero"_err_en_US); - messageDisplayedSet_ |= 0x10; - } - bool isConstant{cLower && cUpper && cStride && *cStride != 0}; - bool isNonemptyConstant{isConstant && - ((*cStride > 0 && *cLower <= *cUpper) || - (*cStride < 0 && *cLower >= *cUpper))}; - bool unrollConstantLoop{false}; - parser::Messages buffer; - auto saveMessagesDisplayed{messageDisplayedSet_}; - { - auto messageRestorer{ - exprAnalyzer_.GetContextualMessages().SetMessages(buffer)}; - auto v{std::move(values_)}; - for (const auto &value : - std::get>(impliedDo.t)) { - Add(value); - } - std::swap(v, values_); - if (isNonemptyConstant && buffer.AnyFatalError()) { - unrollConstantLoop = true; - } else { - values_.Push(ImpliedDo{name, std::move(*lower), - std::move(*upper), std::move(*stride), std::move(v)}); + if (exprAnalyzer_.AddImpliedDo(name, kind)) { + // Check for constant bounds; the loop may require complete unrolling + // of the parse tree if all bounds are constant in order to allow the + // implied DO loop index to qualify as a constant expression. + auto cLower{ToInt64(lower)}; + auto cUpper{ToInt64(upper)}; + auto cStride{ToInt64(stride)}; + if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) { + exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source, + "The stride of an implied DO loop must not be zero"_err_en_US); + messageDisplayedSet_ |= 0x10; + } + bool isConstant{cLower && cUpper && cStride && *cStride != 0}; + bool isNonemptyConstant{isConstant && + ((*cStride > 0 && *cLower <= *cUpper) || + (*cStride < 0 && *cLower >= *cUpper))}; + bool unrollConstantLoop{false}; + parser::Messages buffer; + auto saveMessagesDisplayed{messageDisplayedSet_}; + { + auto messageRestorer{ + exprAnalyzer_.GetContextualMessages().SetMessages(buffer)}; + auto v{std::move(values_)}; + for (const auto &value : + std::get>(impliedDo.t)) { + Add(value); + } + std::swap(v, values_); + if (isNonemptyConstant && buffer.AnyFatalError()) { + unrollConstantLoop = true; + } else { + values_.Push(ImpliedDo{name, std::move(*lower), + std::move(*upper), std::move(*stride), std::move(v)}); + } } - } - if (unrollConstantLoop) { - messageDisplayedSet_ = saveMessagesDisplayed; - UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride); - } else if (auto *messages{ - exprAnalyzer_.GetContextualMessages().messages()}) { - messages->Annex(std::move(buffer)); + if (unrollConstantLoop) { + messageDisplayedSet_ = saveMessagesDisplayed; + UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride); + } else if (auto *messages{ + exprAnalyzer_.GetContextualMessages().messages()}) { + messages->Annex(std::move(buffer)); + } + exprAnalyzer_.RemoveImpliedDo(name); + } else if (!(messageDisplayedSet_ & 0x20)) { + exprAnalyzer_.SayAt(name, + "Implied DO index '%s' is active in a surrounding implied DO loop " + "and may not have the same name"_err_en_US, + name); // C7115 + messageDisplayedSet_ |= 0x20; } } - exprAnalyzer_.RemoveImpliedDo(name); } // Fortran considers an implied DO index of an array constructor to be diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -901,11 +901,12 @@ // it comes from the entity in the containing scope, or implicit rules. // Return pointer to the new symbol, or nullptr on error. Symbol *DeclareLocalEntity(const parser::Name &); - // Declare a statement entity (e.g., an implied DO loop index). - // If there isn't a type specified, implicit rules apply. - // Return pointer to the new symbol, or nullptr on error. - Symbol *DeclareStatementEntity( - const parser::Name &, const std::optional &); + // Declare a statement entity (i.e., an implied DO loop index for + // a DATA statement or an array constructor). If there isn't an explict + // type specified, implicit rules apply. Return pointer to the new symbol, + // or nullptr on error. + Symbol *DeclareStatementEntity(const parser::DoVariable &, + const std::optional &); Symbol &MakeCommonBlockSymbol(const parser::Name &); Symbol &MakeCommonBlockSymbol(const std::optional &); bool CheckUseError(const parser::Name &); @@ -926,6 +927,16 @@ Symbol *NoteInterfaceName(const parser::Name &); bool IsUplevelReference(const Symbol &); + std::optional BeginCheckOnIndexUseInOwnBounds( + const parser::DoVariable &name) { + std::optional result{checkIndexUseInOwnBounds_}; + checkIndexUseInOwnBounds_ = name.thing.thing.source; + return result; + } + void EndCheckOnIndexUseInOwnBounds(const std::optional &restore) { + checkIndexUseInOwnBounds_ = restore; + } + private: // The attribute corresponding to the statement containing an ObjectDecl std::optional objectDeclAttr_; @@ -956,6 +967,9 @@ } enumerationState_; // Set for OldParameterStmt processing bool inOldStyleParameterStmt_{false}; + // Set when walking DATA & array constructor implied DO loop bounds + // to warn about use of the implied DO intex therein. + std::optional checkIndexUseInOwnBounds_; bool HandleAttributeStmt(Attr, const std::list &); Symbol &HandleAttributeStmt(Attr, const parser::Name &); @@ -5010,8 +5024,10 @@ return &MakeHostAssocSymbol(name, prev); } -Symbol *DeclarationVisitor::DeclareStatementEntity(const parser::Name &name, +Symbol *DeclarationVisitor::DeclareStatementEntity( + const parser::DoVariable &doVar, const std::optional &type) { + const parser::Name &name{doVar.thing.thing}; const DeclTypeSpec *declTypeSpec{nullptr}; if (auto *prev{FindSymbol(name)}) { if (prev->owner() == currScope()) { @@ -5037,7 +5053,9 @@ } else { ApplyImplicitRules(symbol); } - return Resolve(name, &symbol); + Symbol *result{Resolve(name, &symbol)}; + AnalyzeExpr(context(), doVar); // enforce INTEGER type + return result; } // Set the type of an entity or report an error. @@ -5321,9 +5339,7 @@ bool ConstructVisitor::Pre(const parser::AcSpec &x) { ProcessTypeSpec(x.type); - PushScope(Scope::Kind::ImpliedDos, nullptr); Walk(x.values); - PopScope(); return false; } @@ -5334,9 +5350,18 @@ auto &control{std::get(x.t)}; auto &type{std::get>(control.t)}; auto &bounds{std::get(control.t)}; + // F'2018 has the scope of the implied DO variable covering the entire + // implied DO production (19.4(5)), which seems wrong in cases where the name + // of the implied DO variable appears in one of the bound expressions. Thus + // this extension, which shrinks the scope of the variable to exclude the + // expressions in the bounds. + auto restore{BeginCheckOnIndexUseInOwnBounds(bounds.name)}; + Walk(bounds.lower); + Walk(bounds.upper); + Walk(bounds.step); + EndCheckOnIndexUseInOwnBounds(restore); PushScope(Scope::Kind::ImpliedDos, nullptr); - DeclareStatementEntity(bounds.name.thing.thing, type); - Walk(bounds); + DeclareStatementEntity(bounds.name, type); Walk(values); PopScope(); return false; @@ -5346,9 +5371,21 @@ auto &objects{std::get>(x.t)}; auto &type{std::get>(x.t)}; auto &bounds{std::get(x.t)}; - DeclareStatementEntity(bounds.name.thing.thing, type); - Walk(bounds); + // See comment in Pre(AcImpliedDo) above. + auto restore{BeginCheckOnIndexUseInOwnBounds(bounds.name)}; + Walk(bounds.lower); + Walk(bounds.upper); + Walk(bounds.step); + EndCheckOnIndexUseInOwnBounds(restore); + bool pushScope{currScope().kind() != Scope::Kind::ImpliedDos}; + if (pushScope) { + PushScope(Scope::Kind::ImpliedDos, nullptr); + } + DeclareStatementEntity(bounds.name, type); Walk(objects); + if (pushScope) { + PopScope(); + } return false; } @@ -5887,6 +5924,12 @@ ConvertToObjectEntity(*symbol); ApplyImplicitRules(*symbol); } + if (checkIndexUseInOwnBounds_ && + *checkIndexUseInOwnBounds_ == name.source) { + Say(name, + "Implied DO index '%s' uses an object of the same name in its bounds expressions"_en_US, + name.source); + } return &name; } if (isImplicitNoneType()) { @@ -5894,6 +5937,11 @@ return nullptr; } // Create the symbol then ensure it is accessible + if (checkIndexUseInOwnBounds_ && *checkIndexUseInOwnBounds_ == name.source) { + Say(name, + "Implied DO index '%s' uses itself in its own bounds expressions"_err_en_US, + name.source); + } MakeSymbol(InclusiveScope(), name.source, Attrs{}); auto *symbol{FindSymbol(name)}; if (!symbol) { diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90 --- a/flang/test/Semantics/array-constr-values.f90 +++ b/flang/test/Semantics/array-constr-values.f90 @@ -58,7 +58,7 @@ real, dimension(10), parameter :: good1 = [(99.9, i = 1, 10)] real, dimension(100), parameter :: good2 = [((88.8, i = 1, 10), j = 1, 10)] real, dimension(-1:0), parameter :: good3 = [77.7, 66.6] - !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name + !ERROR: Implied DO index 'i' is active in a surrounding implied DO loop and may not have the same name real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)] !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value diff --git a/flang/test/Semantics/data11.f90 b/flang/test/Semantics/data11.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/data11.f90 @@ -0,0 +1,9 @@ +! RUN: %flang_fc1 -fsyntax-only -fdebug-dump-symbols %s 2>&1 | FileCheck %s +! CHECK: Implied DO index 'j' uses an object of the same name in its bounds expressions +! CHECK: ObjectEntity type: REAL(4) shape: 1_8:5_8 init:[REAL(4)::1._4,2._4,3._4,4._4,5._4] +! Verify that the scope of a DATA statement implied DO loop index does +! not include the bounds expressions (language extension, with warning) +integer, parameter :: j = 5 +real, save :: a(j) +data (a(j),j=1,j)/1,2,3,4,5/ +end diff --git a/flang/test/Semantics/modfile25.f90 b/flang/test/Semantics/modfile25.f90 --- a/flang/test/Semantics/modfile25.f90 +++ b/flang/test/Semantics/modfile25.f90 @@ -39,7 +39,9 @@ ! integer(8),parameter::a1ss(1_8:*)=[INTEGER(8)::3_8] ! integer(8),parameter::a1sss(1_8:*)=[INTEGER(8)::1_8] ! integer(8),parameter::a1rs(1_8:*)=[INTEGER(8)::3_8,1_8,1_8,1_8] +! intrinsic::rank ! integer(8),parameter::a1n(1_8:*)=[INTEGER(8)::125_8,5_8,5_8] +! intrinsic::size ! integer(8),parameter::a1sn(1_8:*)=[INTEGER(8)::3_8,1_8,1_8] ! integer(8),parameter::ac1s(1_8:*)=[INTEGER(8)::1_8] ! integer(8),parameter::ac2s(1_8:*)=[INTEGER(8)::3_8] diff --git a/flang/test/Semantics/modfile26.f90 b/flang/test/Semantics/modfile26.f90 --- a/flang/test/Semantics/modfile26.f90 +++ b/flang/test/Semantics/modfile26.f90 @@ -66,12 +66,15 @@ !Expect: m1.mod !module m1 !integer(4),parameter::iranges(1_8:*)=[INTEGER(4)::2_4,4_4,9_4,18_4,38_4] +!intrinsic::range !logical(4),parameter::ircheck=.true._4 !intrinsic::all !integer(4),parameter::intpvals(1_8:*)=[INTEGER(4)::0_4,2_4,3_4,4_4,5_4,9_4,10_4,18_4,19_4,38_4,39_4] !integer(4),parameter::intpkinds(1_8:*)=[INTEGER(4)::1_4,1_4,2_4,2_4,4_4,4_4,8_4,8_4,16_4,16_4,-1_4] +!intrinsic::size !logical(4),parameter::ipcheck=.true._4 !integer(4),parameter::realprecs(1_8:*)=[INTEGER(4)::3_4,2_4,6_4,15_4,18_4,33_4] +!intrinsic::precision !logical(4),parameter::rpreccheck=.true._4 !integer(4),parameter::realpvals(1_8:*)=[INTEGER(4)::0_4,3_4,4_4,6_4,7_4,15_4,16_4,18_4,19_4,33_4,34_4] !integer(4),parameter::realpkinds(1_8:*)=[INTEGER(4)::2_4,2_4,4_4,4_4,8_4,8_4,10_4,10_4,16_4,16_4,-1_4] @@ -82,7 +85,9 @@ !integer(4),parameter::realrkinds(1_8:*)=[INTEGER(4)::2_4,2_4,3_4,3_4,8_4,8_4,10_4,10_4,-2_4] !logical(4),parameter::realrcheck=.true._4 !logical(4),parameter::radixcheck=.true._4 +!intrinsic::radix !integer(4),parameter::intdigits(1_8:*)=[INTEGER(4)::7_4,15_4,31_4,63_4,127_4] +!intrinsic::digits !logical(4),parameter::intdigitscheck=.true._4 !integer(4),parameter::realdigits(1_8:*)=[INTEGER(4)::11_4,8_4,24_4,53_4,64_4,113_4] !logical(4),parameter::realdigitscheck=.true._4 diff --git a/flang/test/Semantics/resolve106.f90 b/flang/test/Semantics/resolve106.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve106.f90 @@ -0,0 +1,5 @@ +!RUN: %flang -fsyntax-only %s 2>&1 | FileCheck %s +integer, parameter :: j = 10 +! CHECK: Implied DO index 'j' uses an object of the same name in its bounds expressions +real :: a(10) = [(j, j=1,j)] +end diff --git a/flang/test/Semantics/resolve30.f90 b/flang/test/Semantics/resolve30.f90 --- a/flang/test/Semantics/resolve30.f90 +++ b/flang/test/Semantics/resolve30.f90 @@ -31,9 +31,9 @@ end subroutine s4 - real :: i, j + real :: j !ERROR: Must have INTEGER type, but is REAL(4) - real :: a(16) = [(i, i=1, 16)] + real :: a(16) = [(x, x=1, 16)] real :: b(16) !ERROR: Must have INTEGER type, but is REAL(4) data(b(j), j=1, 16) / 16 * 0.0 / diff --git a/flang/test/Semantics/symbol05.f90 b/flang/test/Semantics/symbol05.f90 --- a/flang/test/Semantics/symbol05.f90 +++ b/flang/test/Semantics/symbol05.f90 @@ -48,10 +48,10 @@ !DEF: /s3/Block1/t DerivedType type :: t !DEF: /s3/Block1/t/x ObjectEntity REAL(4) - !DEF: /s3/Block1/t/ImpliedDos1/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4) + !DEF: /s3/Block1/t/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4) real :: x(10) = [(i, i=1,10)] !DEF: /s3/Block1/t/y ObjectEntity REAL(4) - !DEF: /s3/Block1/t/ImpliedDos2/ImpliedDos1/j ObjectEntity INTEGER(8) + !DEF: /s3/Block1/t/ImpliedDos2/j ObjectEntity INTEGER(8) real :: y(10) = [(j, j=1,10)] end type end block