diff --git a/flang/documentation/Extensions.md b/flang/documentation/Extensions.md index 138dacfa0a0d..5e0d7f7c07cd 100644 --- a/flang/documentation/Extensions.md +++ b/flang/documentation/Extensions.md @@ -62,7 +62,7 @@ Extensions, deletions, and legacy features supported by default files are easier to write and use. * $ and \ edit descriptors are supported in FORMAT to suppress newline output on user prompts. -* REAL variable and bounds in DO loops +* REAL and DOUBLE PRECISION variable and bounds in DO loops * Integer literals without explicit kind specifiers that are out of range for the default kind of INTEGER are assumed to have the least larger kind that can hold them, if one exists. diff --git a/flang/lib/parser/parse-tree.cc b/flang/lib/parser/parse-tree.cc index edd23c21ee7a..6349c16fe76d 100644 --- a/flang/lib/parser/parse-tree.cc +++ b/flang/lib/parser/parse-tree.cc @@ -80,9 +80,26 @@ Expr::Expr(Designator &&x) Expr::Expr(FunctionReference &&x) : u{common::Indirection::Make(std::move(x))} {} +const std::optional &DoConstruct::GetLoopControl() const { + NonLabelDoStmt const &doStmt{ + std::get>(t).statement}; + std::optional const &control{ + std::get>(doStmt.t)}; + return control; +} + +bool DoConstruct::IsDoNormal() const { + std::optional const &control{GetLoopControl()}; + return control && std::holds_alternative(control->u); +} + +bool DoConstruct::IsDoWhile() const { + std::optional const &control{GetLoopControl()}; + return control && std::holds_alternative(control->u); +} + bool DoConstruct::IsDoConcurrent() const { - auto &doStmt{std::get>(t).statement}; - auto &control{std::get>(doStmt.t)}; + std::optional const &control{GetLoopControl()}; return control && std::holds_alternative(control->u); } diff --git a/flang/lib/parser/parse-tree.h b/flang/lib/parser/parse-tree.h index 5e6cb0702f5f..ddc20c767c69 100644 --- a/flang/lib/parser/parse-tree.h +++ b/flang/lib/parser/parse-tree.h @@ -2217,6 +2217,9 @@ WRAPPER_CLASS(EndDoStmt, std::optional); // CONTINUE; multiple "label DO" loops ending on the same label struct DoConstruct { TUPLE_CLASS_BOILERPLATE(DoConstruct); + const std::optional &GetLoopControl() const; + bool IsDoNormal() const; + bool IsDoWhile() const; bool IsDoConcurrent() const; std::tuple, Block, Statement> t; }; diff --git a/flang/lib/semantics/CMakeLists.txt b/flang/lib/semantics/CMakeLists.txt index 4498db28366f..3210179ff92c 100644 --- a/flang/lib/semantics/CMakeLists.txt +++ b/flang/lib/semantics/CMakeLists.txt @@ -20,7 +20,7 @@ add_library(FortranSemantics check-arithmeticif.cc check-coarray.cc check-deallocate.cc - check-do-concurrent.cc + check-do-stmt.cc check-if-stmt.cc check-io.cc check-nullify.cc diff --git a/flang/lib/semantics/check-do-concurrent.cc b/flang/lib/semantics/check-do-stmt.cc similarity index 83% rename from flang/lib/semantics/check-do-concurrent.cc rename to flang/lib/semantics/check-do-stmt.cc index ab296fd135f8..db75fc6c4e8c 100644 --- a/flang/lib/semantics/check-do-concurrent.cc +++ b/flang/lib/semantics/check-do-stmt.cc @@ -12,13 +12,14 @@ // See the License for the specific language governing permissions and // limitations under the License. -#include "check-do-concurrent.h" +#include "check-do-stmt.h" #include "attr.h" #include "scope.h" #include "semantics.h" #include "symbol.h" #include "tools.h" #include "type.h" +#include "../evaluate/expression.h" #include "../evaluate/traversal.h" #include "../parser/message.h" #include "../parser/parse-tree-visitor.h" @@ -31,6 +32,7 @@ static bool isPure(const Attrs &attrs) { return attrs.test(Attr::PURE) || (attrs.test(Attr::ELEMENTAL) && !attrs.test(Attr::IMPURE)); } + static bool isProcedure(const Symbol::Flags &flags) { return flags.test(Symbol::Flag::Function) || flags.test(Symbol::Flag::Subroutine); @@ -51,57 +53,70 @@ public: } return true; } + // C1167 bool Pre(const parser::WhereConstructStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::ForallConstructStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::ChangeTeamStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::CriticalStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::LabelDoStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::NonLabelDoStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::IfThenStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::SelectCaseStmt &s) { addName(std::get>(s.t)); return true; } + bool Pre(const parser::SelectRankStmt &s) { addName(std::get<0>(s.t)); return true; } + bool Pre(const parser::SelectTypeStmt &s) { addName(std::get<0>(s.t)); return true; } + // C1136 void Post(const parser::ReturnStmt &) { messages_.Say(currentStatementSourcePosition_, "RETURN not allowed in DO CONCURRENT"_err_en_US); } + // C1137 void NoImageControl() { messages_.Say(currentStatementSourcePosition_, "image control statement not allowed in DO CONCURRENT"_err_en_US); } + void Post(const parser::SyncAllStmt &) { NoImageControl(); } void Post(const parser::SyncImagesStmt &) { NoImageControl(); } void Post(const parser::SyncMemoryStmt &) { NoImageControl(); } @@ -122,6 +137,7 @@ public: "ALLOCATE coarray not allowed in DO CONCURRENT"_err_en_US); } } + void Post(const parser::DeallocateStmt &) { if (anyObjectIsCoarray()) { messages_.Say(currentStatementSourcePosition_, @@ -134,6 +150,7 @@ public: " in DO CONCURRENT"_err_en_US); } } + template void Post(const parser::Statement &) { if (EndTDeallocatesCoarray()) { messages_.Say(currentStatementSourcePosition_, @@ -141,6 +158,7 @@ public: " in DO CONCURRENT"_err_en_US); } } + // C1141: cannot call ieee_get_flag, ieee_[gs]et_halting_mode void Post(const parser::ProcedureDesignator &procedureDesignator) { if (auto *name{std::get_if(&procedureDesignator.u)}) { @@ -203,6 +221,7 @@ private: } return false; } + void addName(const std::optional &nm) { if (nm.has_value()) { names_.insert(nm.value().source); @@ -227,10 +246,12 @@ public: currentStatementSourcePosition_ = statement.source; return true; } + bool Pre(const parser::DoConstruct &) { ++do_depth_; return true; } + template void Post(const T &) {} // C1138: branch from within a DO CONCURRENT shall not target outside loop @@ -241,22 +262,27 @@ public: checkLabelUse(i); } } + void Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) { checkLabelUse(std::get<1>(arithmeticIfStmt.t)); checkLabelUse(std::get<2>(arithmeticIfStmt.t)); checkLabelUse(std::get<3>(arithmeticIfStmt.t)); } + void Post(const parser::AssignStmt &assignStmt) { checkLabelUse(std::get(assignStmt.t)); } + void Post(const parser::AssignedGotoStmt &assignedGotoStmt) { for (auto &i : std::get>(assignedGotoStmt.t)) { checkLabelUse(i); } } + void Post(const parser::AltReturnSpec &altReturnSpec) { checkLabelUse(altReturnSpec.v); } + void Post(const parser::ErrLabel &errLabel) { checkLabelUse(errLabel.v); } void Post(const parser::EndLabel &endLabel) { checkLabelUse(endLabel.v); } void Post(const parser::EorLabel &eorLabel) { checkLabelUse(eorLabel.v); } @@ -276,6 +302,7 @@ public: doConcurrentSourcePosition_, nm.value().source); } } + void checkLabelUse(const parser::Label &labelUsed) { if (labels_.find(labelUsed) == labels_.end()) { messages_.Say(currentStatementSourcePosition_, @@ -302,6 +329,7 @@ struct GatherSymbols { }; enum GatherWhichVariables { All, NotShared, Local }; + static CS GatherVariables(const std::list &localitySpecs, GatherWhichVariables which) { CS symbols; @@ -344,41 +372,108 @@ static CS GatherReferencesFromExpression(const parser::Expr &expression) { } } -// Find a canonical DO CONCURRENT and enforce semantics checks on its body -class DoConcurrentContext { +// Find a DO statement and enforce semantics checks on its body +class DoStmtContext { public: - DoConcurrentContext(SemanticsContext &context) - : messages_{context.messages()} {} + DoStmtContext(SemanticsContext &context) + : context_{context}, messages_{context.messages()} {} - bool operator==(const DoConcurrentContext &x) const { return this == &x; } + bool operator==(const DoStmtContext &x) const { return this == &x; } void Check(const parser::DoConstruct &doConstruct) { + if (doConstruct.IsDoConcurrent()) { + CheckDoConcurrent(doConstruct); + return; + } + if (doConstruct.IsDoNormal()) { + CheckDoNormal(doConstruct); + return; + } + // TODO: handle the other cases + } + +private: + using Bounds = parser::LoopControl::Bounds; + + const Bounds &GetBounds(const parser::DoConstruct &doConstruct) { auto &doStmt{ std::get>(doConstruct.t)}; auto &optionalLoopControl{ std::get>(doStmt.statement.t)}; - if (optionalLoopControl) { - currentStatementSourcePosition_ = doStmt.source; - if (auto *concurrent{std::get_if( - &optionalLoopControl->u)}) { - DoConcurrentEnforcement doConcurrentEnforcement{messages_}; - parser::Walk( - std::get(doConstruct.t), doConcurrentEnforcement); - DoConcurrentLabelEnforce doConcurrentLabelEnforce{messages_, - doConcurrentEnforcement.labels(), doConcurrentEnforcement.names(), - currentStatementSourcePosition_}; - parser::Walk( - std::get(doConstruct.t), doConcurrentLabelEnforce); - EnforceConcurrentLoopControl(*concurrent); - } + auto &loopControl{optionalLoopControl.value()}; + return std::get(loopControl.u); + } + + void CheckDoControl(parser::CharBlock sourceLocation, bool isReal) { + if ((isReal) && (!context_.warnOnNonstandardUsage())) { + // No messages for the default case + } else if (isReal && context_.warnOnNonstandardUsage() && + (!context_.warningsAreErrors())) { + messages_.Say(sourceLocation, + "DO controls not of type INTEGER are a non-standard " + "extension"_en_US); + } else { + messages_.Say(sourceLocation, "DO controls should be INTEGER"_err_en_US); } } -private: + void CheckDoVariable(const parser::ScalarName &scalarName) { + const DeclTypeSpec *symType{scalarName.thing.symbol->GetType()}; + if (symType->IsNumeric(TypeCategory::Integer)) { + return; // No warnings or errors for INTEGER + } + const parser::CharBlock &sourceLocation{scalarName.thing.source}; + CheckDoControl(sourceLocation, symType->IsNumeric(TypeCategory::Real)); + } + + void CheckDoExpression(const parser::ScalarExpr &scalarExpression) { + const evaluate::Expr *expr{GetExpr(scalarExpression)}; + if (ExprHasTypeCategory(*expr, TypeCategory::Integer)) { + return; // No warnings or errors for INTEGER + } + const parser::CharBlock &sourceLocation{ + scalarExpression.thing.value().source}; + CheckDoControl( + sourceLocation, ExprHasTypeCategory(*expr, TypeCategory::Real)); + } + + void CheckDoNormal(const parser::DoConstruct &doConstruct) { + // Get the bounds, then check the variable, init, final, and step + const Bounds &bounds{GetBounds(doConstruct)}; + CheckDoVariable(bounds.name); + CheckDoExpression(bounds.lower); + CheckDoExpression(bounds.upper); + if (bounds.step.has_value()) { + CheckDoExpression(bounds.step.value()); + } + } + + void CheckDoConcurrent(const parser::DoConstruct &doConstruct) { + auto &doStmt{ + std::get>(doConstruct.t)}; + auto &loopControl{ + std::get>(doStmt.statement.t)}; + currentStatementSourcePosition_ = doStmt.source; + + DoConcurrentEnforcement doConcurrentEnforcement{messages_}; + parser::Walk( + std::get(doConstruct.t), doConcurrentEnforcement); + + DoConcurrentLabelEnforce doConcurrentLabelEnforce{messages_, + doConcurrentEnforcement.labels(), doConcurrentEnforcement.names(), + currentStatementSourcePosition_}; + parser::Walk( + std::get(doConstruct.t), doConcurrentLabelEnforce); + + auto &concurrent{std::get(loopControl->u)}; + EnforceConcurrentLoopControl(concurrent); + } + bool InnermostEnclosingScope(const semantics::Symbol &symbol) const { // TODO - implement return true; } + void CheckZeroOrOneDefaultNone( const std::list &localitySpecs) const { // C1127 @@ -394,6 +489,7 @@ private: } } } + void CheckScopingConstraints(const CS &symbols) const { // C1124 for (auto *symbol : symbols) { @@ -453,6 +549,7 @@ private: // C1130 // TODO - implement } + // check constraints [C1121 .. C1130] void EnforceConcurrentLoopControl( const parser::LoopControl::Concurrent &concurrent) const { @@ -498,21 +595,15 @@ private: CheckDefaultNoneImpliesExplicitLocality(localitySpecs); } + SemanticsContext &context_; parser::Messages &messages_; parser::CharBlock currentStatementSourcePosition_; }; -DoConcurrentChecker::DoConcurrentChecker(SemanticsContext &context) - : context_{new DoConcurrentContext{context}} {} - -DoConcurrentChecker::~DoConcurrentChecker() = default; - // DO loops must be canonicalized prior to calling -void DoConcurrentChecker::Leave(const parser::DoConstruct &x) { - context_.value().Check(x); +void DoStmtChecker::Leave(const parser::DoConstruct &x) { + DoStmtContext doContext{context_}; + doContext.Check(x); } } // namespace Fortran::semantics - -template class Fortran::common::Indirection< - Fortran::semantics::DoConcurrentContext>; diff --git a/flang/lib/semantics/check-do-concurrent.h b/flang/lib/semantics/check-do-stmt.h similarity index 56% rename from flang/lib/semantics/check-do-concurrent.h rename to flang/lib/semantics/check-do-stmt.h index 517da49ffc02..cc9b0f41bfeb 100644 --- a/flang/lib/semantics/check-do-concurrent.h +++ b/flang/lib/semantics/check-do-stmt.h @@ -12,30 +12,21 @@ // See the License for the specific language governing permissions and // limitations under the License. -#ifndef FORTRAN_SEMANTICS_CHECK_DO_CONCURRENT_H_ -#define FORTRAN_SEMANTICS_CHECK_DO_CONCURRENT_H_ +#ifndef FORTRAN_SEMANTICS_CHECK_DO_STMT_H_ +#define FORTRAN_SEMANTICS_CHECK_DO_STMT_H_ #include "semantics.h" -#include "../common/indirection.h" - -namespace Fortran::parser { -struct DoConstruct; -} -namespace Fortran::semantics { -class DoConcurrentContext; -} -extern template class Fortran::common::Indirection< - Fortran::semantics::DoConcurrentContext>; +#include "../parser/parse-tree.h" namespace Fortran::semantics { -class DoConcurrentChecker : public virtual BaseChecker { + +class DoStmtChecker : public virtual BaseChecker { public: - explicit DoConcurrentChecker(SemanticsContext &); - ~DoConcurrentChecker(); + explicit DoStmtChecker(SemanticsContext &context) : context_{context} {} void Leave(const parser::DoConstruct &); private: - common::Indirection context_; + SemanticsContext &context_; }; } -#endif // FORTRAN_SEMANTICS_CHECK_DO_CONCURRENT_H_ +#endif // FORTRAN_SEMANTICS_CHECK_DO_STMT_H_ diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc index 37e5260c4cc8..5389b7beb1ee 100644 --- a/flang/lib/semantics/semantics.cc +++ b/flang/lib/semantics/semantics.cc @@ -19,7 +19,7 @@ #include "check-arithmeticif.h" #include "check-coarray.h" #include "check-deallocate.h" -#include "check-do-concurrent.h" +#include "check-do-stmt.h" #include "check-if-stmt.h" #include "check-io.h" #include "check-nullify.h" @@ -34,7 +34,6 @@ #include "symbol.h" #include "../common/default-kinds.h" #include "../parser/parse-tree-visitor.h" -#include namespace Fortran::semantics { @@ -83,7 +82,7 @@ private: using StatementSemanticsPass1 = ExprChecker; using StatementSemanticsPass2 = SemanticsVisitor; static bool PerformStatementSemantics( diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index dc64f5e767d2..12a8a8883040 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/flang/test/semantics/CMakeLists.txt @@ -124,6 +124,8 @@ set(ERROR_TESTS allocate13.f90 dosemantics01.f90 dosemantics02.f90 + dosemantics03.f90 + dosemantics04.f90 expr-errors01.f90 null01.f90 ) diff --git a/flang/test/semantics/dosemantics03.f90 b/flang/test/semantics/dosemantics03.f90 new file mode 100644 index 000000000000..df0accdfce63 --- /dev/null +++ b/flang/test/semantics/dosemantics03.f90 @@ -0,0 +1,250 @@ +! 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. + +! Issue 458 -- semantic checks for a normal DO loop. The DO variable +! and the initial, final, and step expressions must be INTEGER if the +! options for standard conformance and turning warnings into errors +! are both in effect. This test turns on the options for standards +! conformance and turning warnings into errors. This produces error +! messages for the cases where REAL and DOUBLE PRECISION variables +! and expressions are used in the DO controls. +! +! This test is just like dosemantics04.f90 but with the options +! to produce error messages when using REAL and DOUBLE PRECISION DO +! loop controls. + +! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s +!OPTIONS: -Mstandard -Werror + +PROGRAM do_issue_458 + IMPLICIT NONE + INTEGER :: ivar + REAL :: rvar + DOUBLE PRECISION :: dvar + LOGICAL :: lvar + COMPLEX :: cvar + CHARACTER :: chvar + INTEGER, DIMENSION(3) :: avar + TYPE derived + REAL :: first + INTEGER :: second + END TYPE derived + TYPE(derived) :: devar + INTEGER, POINTER :: pivar + REAL, POINTER :: prvar + DOUBLE PRECISION, POINTER :: pdvar + LOGICAL, POINTER :: plvar + +! DO variables +! INTEGER DO variable + DO ivar = 1, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! REAL DO variable +!ERROR: DO controls should be INTEGER + DO rvar = 1, 10, 3 + PRINT *, "rvar is: ", rvar + END DO + +! DOUBLE PRECISISON DO variable +!ERROR: DO controls should be INTEGER + DO dvar = 1, 10, 3 + PRINT *, "dvar is: ", dvar + END DO + +! Pointer to INTEGER DO variable + ALLOCATE(pivar) + DO pivar = 1, 10, 3 + PRINT *, "pivar is: ", pivar + END DO + +! Pointer to REAL DO variable + ALLOCATE(prvar) +!ERROR: DO controls should be INTEGER + DO prvar = 1, 10, 3 + PRINT *, "prvar is: ", prvar + END DO + +! Pointer to DOUBLE PRECISION DO variable + ALLOCATE(pdvar) +!ERROR: DO controls should be INTEGER + DO pdvar = 1, 10, 3 + PRINT *, "pdvar is: ", pdvar + END DO + +! CHARACTER DO variable +!ERROR: DO controls should be INTEGER + DO chvar = 1, 10, 3 + PRINT *, "chvar is: ", chvar + END DO + +! LOGICAL DO variable +!ERROR: DO controls should be INTEGER + DO lvar = 1, 10, 3 + PRINT *, "lvar is: ", lvar + END DO + +! COMPLEX DO variable +!ERROR: DO controls should be INTEGER + DO cvar = 1, 10, 3 + PRINT *, "cvar is: ", cvar + END DO + +! Derived type DO variable +!ERROR: DO controls should be INTEGER + DO devar = 1, 10, 3 + PRINT *, "devar is: ", devar + END DO + +! Pointer to LOGICAL DO variable + ALLOCATE(plvar) +!ERROR: DO controls should be INTEGER + DO plvar = 1, 10, 3 + PRINT *, "plvar is: ", plvar + END DO + +! Initial expressions +! REAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = rvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION initial expression +!ERROR: DO controls should be INTEGER + DO ivar = dvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER initial expression + DO ivar = pivar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = prvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION initial expression +!ERROR: DO controls should be INTEGER + DO ivar = pdvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! LOGICAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = lvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX initial expression +!ERROR: DO controls should be INTEGER + DO ivar = cvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Derived type initial expression +!ERROR: DO controls should be INTEGER + DO ivar = devar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to LOGICAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = plvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Final expression +! REAL final expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, rvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION final expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, dvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER final expression + DO ivar = 1, pivar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL final expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, prvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION final expression +!ERROR: DO controls should be INTEGER + DO ivar = pdvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX final expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, cvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Step expression +! REAL step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, rvar + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, dvar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER step expression + DO ivar = 1, 10, pivar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, prvar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, pdvar + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX Step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, cvar + PRINT *, "ivar is: ", ivar + END DO + +! Array DO variable +!ERROR: Must be a scalar value, but is a rank-1 array + DO avar = 1, 10, 3 + PRINT *, "plvar is: ", plvar + END DO + +END PROGRAM do_issue_458 diff --git a/flang/test/semantics/dosemantics04.f90 b/flang/test/semantics/dosemantics04.f90 new file mode 100644 index 000000000000..696dcf80a535 --- /dev/null +++ b/flang/test/semantics/dosemantics04.f90 @@ -0,0 +1,233 @@ +! 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. + +! Issue 458 -- semantic checks for a normal DO loop. The DO variable +! and the initial, final, and step expressions must be INTEGER if the +! options for standard conformance and turning warnings into errors +! are both in effect. This test turns on the options for standards +! conformance and turning warnings into errors. This produces error +! messages for the cases where REAL and DOUBLE PRECISION variables +! and expressions are used in the DO controls. +! +! This test is just like dosemantics03.f90 but without the options +! to produce error messages when using REAL and DOUBLE PRECISION DO +! loop controls. + +! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s + +PROGRAM do_issue_458 + IMPLICIT NONE + INTEGER :: ivar + REAL :: rvar + DOUBLE PRECISION :: dvar + LOGICAL :: lvar + COMPLEX :: cvar + CHARACTER :: chvar + INTEGER, DIMENSION(3) :: avar + TYPE derived + REAL :: first + INTEGER :: second + END TYPE derived + TYPE(derived) :: devar + INTEGER, POINTER :: pivar + REAL, POINTER :: prvar + DOUBLE PRECISION, POINTER :: pdvar + LOGICAL, POINTER :: plvar + +! DO variables +! INTEGER DO variable + DO ivar = 1, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! REAL DO variable + DO rvar = 1, 10, 3 + PRINT *, "rvar is: ", rvar + END DO + +! DOUBLE PRECISISON DO variable + DO dvar = 1, 10, 3 + PRINT *, "dvar is: ", dvar + END DO + +! Pointer to INTEGER DO variable + ALLOCATE(pivar) + DO pivar = 1, 10, 3 + PRINT *, "pivar is: ", pivar + END DO + +! Pointer to REAL DO variable + ALLOCATE(prvar) + DO prvar = 1, 10, 3 + PRINT *, "prvar is: ", prvar + END DO + +! Pointer to DOUBLE PRECISION DO variable + ALLOCATE(pdvar) + DO pdvar = 1, 10, 3 + PRINT *, "pdvar is: ", pdvar + END DO + +! CHARACTER DO variable +!ERROR: DO controls should be INTEGER + DO chvar = 1, 10, 3 + PRINT *, "chvar is: ", chvar + END DO + +! LOGICAL DO variable +!ERROR: DO controls should be INTEGER + DO lvar = 1, 10, 3 + PRINT *, "lvar is: ", lvar + END DO + +! COMPLEX DO variable +!ERROR: DO controls should be INTEGER + DO cvar = 1, 10, 3 + PRINT *, "cvar is: ", cvar + END DO + +! Derived type DO variable +!ERROR: DO controls should be INTEGER + DO devar = 1, 10, 3 + PRINT *, "devar is: ", devar + END DO + +! Pointer to LOGICAL DO variable + ALLOCATE(plvar) +!ERROR: DO controls should be INTEGER + DO plvar = 1, 10, 3 + PRINT *, "plvar is: ", plvar + END DO + +! Initial expressions +! REAL initial expression + DO ivar = rvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION initial expression + DO ivar = dvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER initial expression + DO ivar = pivar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL initial expression + DO ivar = prvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION initial expression + DO ivar = pdvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! LOGICAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = lvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX initial expression +!ERROR: DO controls should be INTEGER + DO ivar = cvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Derived type initial expression +!ERROR: DO controls should be INTEGER + DO ivar = devar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to LOGICAL initial expression +!ERROR: DO controls should be INTEGER + DO ivar = plvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Final expression +! REAL final expression + DO ivar = 1, rvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION final expression + DO ivar = 1, dvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER final expression + DO ivar = 1, pivar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL final expression + DO ivar = 1, prvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION final expression + DO ivar = pdvar, 10, 3 + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX final expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, cvar, 3 + PRINT *, "ivar is: ", ivar + END DO + +! Step expression +! REAL step expression + DO ivar = 1, 10, rvar + PRINT *, "ivar is: ", ivar + END DO + +! DOUBLE PRECISION step expression + DO ivar = 1, 10, dvar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to INTEGER step expression + DO ivar = 1, 10, pivar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to REAL step expression + DO ivar = 1, 10, prvar + PRINT *, "ivar is: ", ivar + END DO + +! Pointer to DOUBLE PRECISION step expression + DO ivar = 1, 10, pdvar + PRINT *, "ivar is: ", ivar + END DO + +! COMPLEX Step expression +!ERROR: DO controls should be INTEGER + DO ivar = 1, 10, cvar + PRINT *, "ivar is: ", ivar + END DO + +! Array DO variable +!ERROR: Must be a scalar value, but is a rank-1 array + DO avar = 1, 10, 3 + PRINT *, "plvar is: ", plvar + END DO + +END PROGRAM do_issue_458 diff --git a/flang/test/semantics/test_errors.sh b/flang/test/semantics/test_errors.sh index 74f03eabb996..10cff80ff837 100755 --- a/flang/test/semantics/test_errors.sh +++ b/flang/test/semantics/test_errors.sh @@ -36,8 +36,12 @@ log=$temp/log actual=$temp/actual expect=$temp/expect diffs=$temp/diffs +options=$temp/options -cmd="$CMD $src" +# See if there are additional options +awk '/^ *!OPTIONS: / {gsub (/^! OPTIONS: /, " " ); print}' $src > $options + +cmd="$CMD `cat $options` $src" ( cd $temp; $cmd ) > $log 2>&1 if [[ $? -ge 128 ]]; then cat $log