[flang] Add non standard feature for labeled do not ending with END DO or CONTINUE

* The warning was already here, this commit only refactors things so that
 it can be controled with -Mstandard.
* Also makes the warning point to the do-stmt and adds a note to the warning
  pointing to the statements where it ends.

Original-commit: flang-compiler/f18@11e1eb6edd
Reviewed-on: https://github.com/flang-compiler/f18/pull/552
Tree-same-pre-rewrite: false
This commit is contained in:
Jean Perier 2019-07-09 11:54:40 -07:00
parent 8a4b595bf6
commit 16cf494888
6 changed files with 181 additions and 196 deletions

View File

@ -32,7 +32,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
Hollerith, ArithmeticIF, Assign, AssignedGOTO, Pause, OpenMP,
CruftAfterAmpersand, ClassicCComments, AdditionalFormats, BigIntLiterals,
RealDoControls, EquivalenceNumericWithCharacter, AdditionalIntrinsics,
AnonymousParents)
AnonymousParents, OldLabelDoEndStatements)
using LanguageFeatures =
common::EnumSet<LanguageFeature, LanguageFeature_enumSize>;

View File

@ -13,9 +13,9 @@
// limitations under the License.
#include "resolve-labels.h"
#include "semantics.h"
#include "../common/enum-set.h"
#include "../common/template.h"
#include "../parser/message.h"
#include "../parser/parse-tree-visitor.h"
#include <cctype>
#include <cstdarg>
@ -227,8 +227,7 @@ static constexpr bool IsExecutableConstructEndStmt{
class ParseTreeAnalyzer {
public:
ParseTreeAnalyzer(ParseTreeAnalyzer &&that) = default;
ParseTreeAnalyzer(parser::Messages &errorHandler)
: errorHandler_{errorHandler} {}
ParseTreeAnalyzer(SemanticsContext &context) : context_{context} {}
template<typename A> constexpr bool Pre(const A &) { return true; }
template<typename A> constexpr void Post(const A &) {}
@ -360,14 +359,14 @@ public:
const auto &firstStmt{std::get<parser::Statement<FIRST>>(a.t)};
if (const parser::CharBlock * firstName{GetStmtName(firstStmt)}) {
if (*firstName != *name) {
errorHandler_
context_
.Say(*name,
parser::MessageFormattedText{
"%s name mismatch"_err_en_US, constructTag})
.Attach(*firstName, "should be"_en_US);
}
} else {
errorHandler_
context_
.Say(*name,
parser::MessageFormattedText{
"%s name not allowed"_err_en_US, constructTag})
@ -405,7 +404,7 @@ public:
if (const auto *otherPointer{
std::get_if<parser::Name>(&optionalGenericSpec->u)}) {
if (namePointer->source != otherPointer->source) {
errorHandler_
context_
.Say(currentPosition_,
parser::MessageFormattedText{
"INTERFACE generic-name (%s) mismatch"_en_US,
@ -442,11 +441,11 @@ public:
std::get<std::optional<parser::Statement<parser::ProgramStmt>>>(
mainProgram.t)}) {
if (*endName != program->statement.v.source) {
errorHandler_.Say(*endName, "END PROGRAM name mismatch"_err_en_US)
context_.Say(*endName, "END PROGRAM name mismatch"_err_en_US)
.Attach(program->statement.v.source, "should be"_en_US);
}
} else {
errorHandler_.Say(*endName,
context_.Say(*endName,
parser::MessageFormattedText{
"END PROGRAM has name without PROGRAM statement"_err_en_US});
}
@ -518,7 +517,7 @@ public:
const std::vector<UnitAnalysis> &ProgramUnits() const {
return programUnits_;
}
parser::Messages &ErrorHandler() { return errorHandler_; }
SemanticsContext &ErrorHandler() { return context_; }
private:
bool PushSubscope() {
@ -639,14 +638,14 @@ private:
if (const parser::CharBlock * constructName{GetStmtName(constructStmt)}) {
if (endName) {
if (*constructName != *endName) {
errorHandler_
context_
.Say(*endName,
parser::MessageFormattedText{
"%s construct name mismatch"_err_en_US, constructTag})
.Attach(*constructName, "should be"_en_US);
}
} else {
errorHandler_
context_
.Say(endStmt.source,
parser::MessageFormattedText{
"%s construct name required but missing"_err_en_US,
@ -654,7 +653,7 @@ private:
.Attach(*constructName, "should be"_en_US);
}
} else if (endName) {
errorHandler_
context_
.Say(*endName,
parser::MessageFormattedText{
"%s construct name unexpected"_err_en_US, constructTag})
@ -737,7 +736,7 @@ private:
const auto iter{std::find(constructNames_.crbegin(),
constructNames_.crend(), constructName.ToString())};
if (iter == constructNames_.crend()) {
errorHandler_.Say(constructName,
context_.Say(constructName,
parser::MessageFormattedText{
"%s construct-name is not in scope"_err_en_US, stmtString});
}
@ -746,7 +745,7 @@ private:
// 6.2.5, paragraph 2
void CheckLabelInRange(parser::Label label) {
if (label < 1 || label > 99999) {
errorHandler_.Say(currentPosition_,
context_.Say(currentPosition_,
parser::MessageFormattedText{
"label '%u' is out of range"_err_en_US, SayLabel(label)});
}
@ -762,7 +761,7 @@ private:
(useParent ? ParentScope() : currentScope_), currentPosition_,
labeledStmtClassificationSet, isExecutableConstructEndStmt})};
if (!pair.second) {
errorHandler_.Say(currentPosition_,
context_.Say(currentPosition_,
parser::MessageFormattedText{
"label '%u' is not distinct"_err_en_US, SayLabel(label)});
}
@ -793,7 +792,7 @@ private:
}
std::vector<UnitAnalysis> programUnits_;
parser::Messages &errorHandler_;
SemanticsContext &context_;
parser::CharBlock currentPosition_{nullptr};
ProxyForScope currentScope_;
std::vector<std::string> constructNames_;
@ -810,8 +809,8 @@ bool InInclusiveScope(const std::vector<ProxyForScope> &scopes,
}
ParseTreeAnalyzer LabelAnalysis(
parser::Messages &errorHandler, const parser::Program &program) {
ParseTreeAnalyzer analysis{errorHandler};
SemanticsContext &context, const parser::Program &program) {
ParseTreeAnalyzer analysis{context};
Walk(program, analysis);
return analysis;
}
@ -839,7 +838,7 @@ LabeledStatementInfoTuplePOD GetLabel(
// 11.1.7.3
void CheckBranchesIntoDoBody(const SourceStmtList &branches,
const TargetStmtMap &labels, const std::vector<ProxyForScope> &scopes,
const IndexList &loopBodies, parser::Messages &errorHandler) {
const IndexList &loopBodies, SemanticsContext &context) {
for (const auto branch : branches) {
const auto &label{branch.parserLabel};
auto branchTarget{GetLabel(labels, label)};
@ -848,8 +847,7 @@ void CheckBranchesIntoDoBody(const SourceStmtList &branches,
const auto &toPosition{branchTarget.parserCharBlock};
for (const auto body : loopBodies) {
if (!InBody(fromPosition, body) && InBody(toPosition, body)) {
errorHandler
.Say(fromPosition, "branch into loop body from outside"_en_US)
context.Say(fromPosition, "branch into loop body from outside"_en_US)
.Attach(body.first, "the loop branched into"_en_US);
}
}
@ -857,15 +855,14 @@ void CheckBranchesIntoDoBody(const SourceStmtList &branches,
}
}
void CheckDoNesting(
const IndexList &loopBodies, parser::Messages &errorHandler) {
void CheckDoNesting(const IndexList &loopBodies, SemanticsContext &context) {
for (auto i1{loopBodies.cbegin()}; i1 != loopBodies.cend(); ++i1) {
const auto &v1{*i1};
for (auto i2{i1 + 1}; i2 != loopBodies.cend(); ++i2) {
const auto &v2{*i2};
if (v2.first.begin() < v1.second.end() &&
v1.second.begin() < v2.second.begin()) {
errorHandler.Say(v1.first, "DO loop doesn't properly nest"_err_en_US)
context.Say(v1.first, "DO loop doesn't properly nest"_err_en_US)
.Attach(v2.first, "DO loop conflicts"_en_US);
}
}
@ -892,7 +889,7 @@ ProxyForScope ParentScope(
void CheckLabelDoConstraints(const SourceStmtList &dos,
const SourceStmtList &branches, const TargetStmtMap &labels,
const std::vector<ProxyForScope> &scopes, parser::Messages &errorHandler) {
const std::vector<ProxyForScope> &scopes, SemanticsContext &context) {
IndexList loopBodies;
for (const auto stmt : dos) {
const auto &label{stmt.parserLabel};
@ -901,12 +898,12 @@ void CheckLabelDoConstraints(const SourceStmtList &dos,
auto doTarget{GetLabel(labels, label)};
if (!HasScope(doTarget.proxyForScope)) {
// C1133
errorHandler.Say(position,
context.Say(position,
parser::MessageFormattedText{
"label '%u' cannot be found"_err_en_US, SayLabel(label)});
} else if (doTarget.parserCharBlock.begin() < position.begin()) {
// R1119
errorHandler.Say(position,
context.Say(position,
parser::MessageFormattedText{
"label '%u' doesn't lexically follow DO stmt"_err_en_US,
SayLabel(label)});
@ -916,17 +913,23 @@ void CheckLabelDoConstraints(const SourceStmtList &dos,
TargetStatementEnum::CompatibleDo)) ||
(doTarget.isExecutableConstructEndStmt &&
ParentScope(scopes, doTarget.proxyForScope) == scope)) {
// Accepted for legacy support
errorHandler.Say(doTarget.parserCharBlock,
parser::MessageFormattedText{
"A DO loop should terminate with an END DO or CONTINUE"_en_US});
if (context.warnOnNonstandardUsage() ||
context.ShouldWarn(
parser::LanguageFeature::OldLabelDoEndStatements)) {
context
.Say(position,
parser::MessageFormattedText{
"A DO loop should terminate with an END DO or CONTINUE"_en_US})
.Attach(doTarget.parserCharBlock,
"DO loop currently ends at statement:"_en_US);
}
} else if (!InInclusiveScope(scopes, scope, doTarget.proxyForScope)) {
errorHandler.Say(position,
context.Say(position,
parser::MessageFormattedText{
"label '%u' is not in DO loop scope"_err_en_US, SayLabel(label)});
} else if (!doTarget.labeledStmtClassificationSet.test(
TargetStatementEnum::Do)) {
errorHandler.Say(doTarget.parserCharBlock,
context.Say(doTarget.parserCharBlock,
parser::MessageFormattedText{
"A DO loop should terminate with an END DO or CONTINUE"_err_en_US});
} else {
@ -934,25 +937,25 @@ void CheckLabelDoConstraints(const SourceStmtList &dos,
}
}
CheckBranchesIntoDoBody(branches, labels, scopes, loopBodies, errorHandler);
CheckDoNesting(loopBodies, errorHandler);
CheckBranchesIntoDoBody(branches, labels, scopes, loopBodies, context);
CheckDoNesting(loopBodies, context);
}
// 6.2.5
void CheckScopeConstraints(const SourceStmtList &stmts,
const TargetStmtMap &labels, const std::vector<ProxyForScope> &scopes,
parser::Messages &errorHandler) {
SemanticsContext &context) {
for (const auto stmt : stmts) {
const auto &label{stmt.parserLabel};
const auto &scope{stmt.proxyForScope};
const auto &position{stmt.parserCharBlock};
auto target{GetLabel(labels, label)};
if (!HasScope(target.proxyForScope)) {
errorHandler.Say(position,
context.Say(position,
parser::MessageFormattedText{
"label '%u' was not found"_err_en_US, SayLabel(label)});
} else if (!InInclusiveScope(scopes, scope, target.proxyForScope)) {
errorHandler.Say(position,
context.Say(position,
parser::MessageFormattedText{
"label '%u' is not in scope"_en_US, SayLabel(label)});
}
@ -960,7 +963,7 @@ void CheckScopeConstraints(const SourceStmtList &stmts,
}
void CheckBranchTargetConstraints(const SourceStmtList &stmts,
const TargetStmtMap &labels, parser::Messages &errorHandler) {
const TargetStmtMap &labels, SemanticsContext &context) {
for (const auto stmt : stmts) {
const auto &label{stmt.parserLabel};
auto branchTarget{GetLabel(labels, label)};
@ -969,7 +972,7 @@ void CheckBranchTargetConstraints(const SourceStmtList &stmts,
TargetStatementEnum::Branch) &&
!branchTarget.labeledStmtClassificationSet.test(
TargetStatementEnum::CompatibleBranch)) {
errorHandler
context
.Say(branchTarget.parserCharBlock,
parser::MessageFormattedText{
"'%u' not a branch target"_err_en_US, SayLabel(label)})
@ -978,7 +981,7 @@ void CheckBranchTargetConstraints(const SourceStmtList &stmts,
"control flow use of '%u'"_en_US, SayLabel(label)});
} else if (!branchTarget.labeledStmtClassificationSet.test(
TargetStatementEnum::Branch)) {
errorHandler
context
.Say(branchTarget.parserCharBlock,
parser::MessageFormattedText{
"'%u' not a branch target"_en_US, SayLabel(label)})
@ -992,20 +995,20 @@ void CheckBranchTargetConstraints(const SourceStmtList &stmts,
void CheckBranchConstraints(const SourceStmtList &branches,
const TargetStmtMap &labels, const std::vector<ProxyForScope> &scopes,
parser::Messages &errorHandler) {
CheckScopeConstraints(branches, labels, scopes, errorHandler);
CheckBranchTargetConstraints(branches, labels, errorHandler);
SemanticsContext &context) {
CheckScopeConstraints(branches, labels, scopes, context);
CheckBranchTargetConstraints(branches, labels, context);
}
void CheckDataXferTargetConstraints(const SourceStmtList &stmts,
const TargetStmtMap &labels, parser::Messages &errorHandler) {
const TargetStmtMap &labels, SemanticsContext &context) {
for (const auto stmt : stmts) {
const auto &label{stmt.parserLabel};
auto ioTarget{GetLabel(labels, label)};
if (HasScope(ioTarget.proxyForScope)) {
if (!ioTarget.labeledStmtClassificationSet.test(
TargetStatementEnum::Format)) {
errorHandler
context
.Say(ioTarget.parserCharBlock,
parser::MessageFormattedText{
"'%u' not a FORMAT"_err_en_US, SayLabel(label)})
@ -1019,28 +1022,27 @@ void CheckDataXferTargetConstraints(const SourceStmtList &stmts,
void CheckDataTransferConstraints(const SourceStmtList &dataTransfers,
const TargetStmtMap &labels, const std::vector<ProxyForScope> &scopes,
parser::Messages &errorHandler) {
CheckScopeConstraints(dataTransfers, labels, scopes, errorHandler);
CheckDataXferTargetConstraints(dataTransfers, labels, errorHandler);
SemanticsContext &context) {
CheckScopeConstraints(dataTransfers, labels, scopes, context);
CheckDataXferTargetConstraints(dataTransfers, labels, context);
}
bool CheckConstraints(ParseTreeAnalyzer &&parseTreeAnalysis) {
auto &errorHandler{parseTreeAnalysis.ErrorHandler()};
auto &context{parseTreeAnalysis.ErrorHandler()};
for (const auto &programUnit : parseTreeAnalysis.ProgramUnits()) {
const auto &dos{programUnit.doStmtSources};
const auto &branches{programUnit.otherStmtSources};
const auto &labels{programUnit.targetStmts};
const auto &scopes{programUnit.scopeModel};
CheckLabelDoConstraints(dos, branches, labels, scopes, errorHandler);
CheckBranchConstraints(branches, labels, scopes, errorHandler);
CheckLabelDoConstraints(dos, branches, labels, scopes, context);
CheckBranchConstraints(branches, labels, scopes, context);
const auto &dataTransfers{programUnit.formatStmtSources};
CheckDataTransferConstraints(dataTransfers, labels, scopes, errorHandler);
CheckDataTransferConstraints(dataTransfers, labels, scopes, context);
}
return !errorHandler.AnyFatalError();
return !context.AnyFatalError();
}
bool ValidateLabels(
parser::Messages &errorHandler, const parser::Program &program) {
return CheckConstraints(LabelAnalysis(errorHandler, program));
bool ValidateLabels(SemanticsContext &context, const parser::Program &program) {
return CheckConstraints(LabelAnalysis(context, program));
}
}

View File

@ -16,16 +16,16 @@
#define FORTRAN_SEMANTICS_RESOLVE_LABELS_H_
namespace Fortran::parser {
class Messages;
struct Program;
}
namespace Fortran::semantics {
class SemanticsContext;
/// \brief Validate the labels in the program
/// \param messages where to emit messages
/// \param context semantic context for errors
/// \param program the parse tree of the program
/// \return true, iff the program's labels pass semantics checks
bool ValidateLabels(parser::Messages &messages, const parser::Program &program);
bool ValidateLabels(SemanticsContext &context, const parser::Program &program);
}
#endif // FORTRAN_SEMANTICS_RESOLVE_LABELS_H_

View File

@ -169,7 +169,7 @@ Scope &SemanticsContext::FindScope(parser::CharBlock source) {
}
bool Semantics::Perform() {
return ValidateLabels(context_.messages(), program_) &&
return ValidateLabels(context_, program_) &&
parser::CanonicalizeDo(program_) && // force line break
PerformStatementSemantics(context_, program_) &&
ModFileWriter{context_}.WriteAll();

View File

@ -15,10 +15,126 @@
! Error test -- DO loop uses obsolete loop termination statement
! See R1131 and C1131
! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
! RUN: ${F18} -funparse-with-symbols -Mstandard %s 2>&1 | ${FileCheck} %s
module iso_fortran_env
type :: team_type
end type
end
subroutine foo0()
do 1 j=1,2
if (.true.) then
! CHECK: A DO loop should terminate with an END DO or CONTINUE
1 end if
do 2 k=1,2
do i=3,4
print*, i+k
! CHECK: A DO loop should terminate with an END DO or CONTINUE
2 end do
do 3 l=1,2
do 3 m=1,2
select case (l)
case default
print*, "default", m, l
case (1)
print*, "start"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
! CHECK: A DO loop should terminate with an END DO or CONTINUE
3 end select
end subroutine
subroutine foo1()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,2
forall (i = 1:10, j = 1:10, b(i, j) /= 0.0)
a(i, j) = real (i + j - k)
b(i, j) = a(i, j) + b(i, j) * real (i * j)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end forall
end subroutine
subroutine foo2()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
where (a<k)
a = a + b
b = a - b
elsewhere
a = a*2
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end where
end subroutine
subroutine foo3()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
associate (x=>a(k+1, 2*k), y=>b(k, 2*k-1))
x = 4*x*x + x*y -2*y
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end associate
end subroutine
subroutine foo4()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
block
real b
b = a(k, k)
a(k, k) = k*b
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end block
end subroutine
subroutine foo5()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
critical
b(k+1, k) = a(k, k+1)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end critical
end subroutine
subroutine foo6(a)
type whatever
class(*), allocatable :: x
end type
type(whatever) :: a(10)
do 4 k=1,10
select type (ax => a(k)%x)
type is (integer)
print*, "integer: ", ax
class default
print*, "not useable"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end select
end subroutine
subroutine foo7(a)
integer :: a(..)
do 4 k=1,10
select rank (a)
rank (0)
a = a+k
rank (1)
a(k) = a(k)+k
rank default
print*, "error"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end select
end subroutine
subroutine foo8()
use :: iso_fortran_env, only : team_type
type(team_type) :: odd_even
do 1 k=1,10
change team (odd_even)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
1 end team
end subroutine
program endDo
do 10 i = 1, 5
! CHECK: A DO loop should terminate with an END DO or CONTINUE
10 print *, "in loop"
end program endDo

View File

@ -1,133 +0,0 @@
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
module iso_fortran_env
type :: team_type
end type
end
subroutine foo0()
do 1 j=1,2
if (.true.) then
! CHECK: A DO loop should terminate with an END DO or CONTINUE
1 end if
do 2 k=1,2
do i=3,4
print*, i+k
! CHECK: A DO loop should terminate with an END DO or CONTINUE
2 end do
do 3 l=1,2
do 3 m=1,2
select case (l)
case default
print*, "default", m, l
case (1)
print*, "start"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
! CHECK: A DO loop should terminate with an END DO or CONTINUE
3 end select
end subroutine
subroutine foo1()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,2
forall (i = 1:10, j = 1:10, b(i, j) /= 0.0)
a(i, j) = real (i + j - k)
b(i, j) = a(i, j) + b(i, j) * real (i * j)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end forall
end subroutine
subroutine foo2()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
where (a<k)
a = a + b
b = a - b
elsewhere
a = a*2
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end where
end subroutine
subroutine foo3()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
associate (x=>a(k+1, 2*k), y=>b(k, 2*k-1))
x = 4*x*x + x*y -2*y
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end associate
end subroutine
subroutine foo4()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
block
real b
b = a(k, k)
a(k, k) = k*b
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end block
end subroutine
subroutine foo5()
real :: a(10, 10), b(10, 10) = 1.0
do 4 k=1,4
critical
b(k+1, k) = a(k, k+1)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end critical
end subroutine
subroutine foo6(a)
type whatever
class(*), allocatable :: x
end type
type(whatever) :: a(10)
do 4 k=1,10
select type (ax => a(k)%x)
type is (integer)
print*, "integer: ", ax
class default
print*, "not useable"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end select
end subroutine
subroutine foo7(a)
integer :: a(..)
do 4 k=1,10
select rank (a)
rank (0)
a = a+k
rank (1)
a(k) = a(k)+k
rank default
print*, "error"
! CHECK: A DO loop should terminate with an END DO or CONTINUE
4 end select
end subroutine
subroutine foo8()
use :: iso_fortran_env, only : team_type
type(team_type) :: odd_even
do 1 k=1,10
change team (odd_even)
! CHECK: A DO loop should terminate with an END DO or CONTINUE
1 end team
end subroutine
end