Index: flang/docs/Parsing.md =================================================================== --- flang/docs/Parsing.md +++ flang/docs/Parsing.md @@ -134,8 +134,9 @@ Message texts, and snprintf-like formatting strings for constructing messages, are instantiated in the various components of the parser with C++ user defined character literals tagged with `_err_en_US`, `_warn_en_US`, -`port_en_US`, and `_en_US` to signify severity and language; the default -language is the dialect of English used in the United States. +`port_en_US`, `because_en_US`, `todo_en_US`, and `_en_US` to signify severity +and language. +The default language is the dialect of English used in the United States. All "fatal" errors that do not immediately abort compilation but do prevent the generation of binary and module files are `_err_en_US`. @@ -143,8 +144,9 @@ problems worth attention are `_warn_en_US`. Non-conforming extensions, legacy features, and obsolescent or deleted features will raise `_port_en_US` messages when those are enabled. -Other messages have a simple `_en_US` suffix, including all messages -that are explanatory attachments. +Messages that are explanatory attachments to others are `_because_en_US`. +Messages signifying an incomplete compiler feature are `_todo_en_US`. +Other messages have a simple `_en_US` suffix. As described above, messages are associated with source code positions by means of provenance values. Index: flang/include/flang/Parser/message.h =================================================================== --- flang/include/flang/Parser/message.h +++ flang/include/flang/Parser/message.h @@ -29,9 +29,9 @@ namespace Fortran::parser { -// Use "..."_err_en_US, "..."_warn_en_US, "..."_port_en_US, and "..."_en_US -// string literals to define the static text and fatality of a message. -// +// Use "..."_err_en_US, "..."_warn_en_US, "..."_port_en_US, "..."_because_en_US, +// "..."_todo_en_US, and "..."_en_US string literals to define the static text +// and severity of a message or attachment. enum class Severity { Error, // fatal error that prevents code and module file generation Warning, // likely problem @@ -81,6 +81,10 @@ const char str[], std::size_t n) { return MessageFixedText{str, n, Severity::Portability}; } +constexpr MessageFixedText operator""_because_en_US( + const char str[], std::size_t n) { + return MessageFixedText{str, n, Severity::Because}; +} constexpr MessageFixedText operator""_todo_en_US( const char str[], std::size_t n) { return MessageFixedText{str, n, Severity::Todo}; @@ -343,6 +347,17 @@ return Say(at_, std::forward(args)...); } + Message *Say(Message &&msg) { + if (messages_ != nullptr) { + if (contextMessage_) { + msg.SetContext(contextMessage_.get()); + } + return &messages_->Say(std::move(msg)); + } else { + return nullptr; + } + } + private: CharBlock at_; Messages *messages_{nullptr}; Index: flang/include/flang/Semantics/tools.h =================================================================== --- flang/include/flang/Semantics/tools.h +++ flang/include/flang/Semantics/tools.h @@ -177,11 +177,6 @@ bool IsAssumedLengthCharacter(const Symbol &); bool IsExternal(const Symbol &); bool IsModuleProcedure(const Symbol &); -// Is the symbol modifiable in this scope -std::optional WhyNotModifiable(const Symbol &, const Scope &); -std::optional WhyNotModifiable(SourceName, const SomeExpr &, - const Scope &, bool vectorSubscriptIsOk = false); -const Symbol *IsExternalInPureContext(const Symbol &, const Scope &); bool HasCoarray(const parser::Expr &); bool IsAssumedType(const Symbol &); bool IsPolymorphic(const Symbol &); @@ -221,7 +216,8 @@ // Determines whether an object might be visible outside a // pure function (C1594); returns a non-null Symbol pointer for // diagnostic purposes if so. -const Symbol *FindExternallyVisibleObject(const Symbol &, const Scope &); +const Symbol *FindExternallyVisibleObject( + const Symbol &, const Scope &, bool isPointerDefinition); template const Symbol *FindExternallyVisibleObject(const A &, const Scope &) { @@ -232,7 +228,7 @@ const Symbol *FindExternallyVisibleObject( const evaluate::Designator &designator, const Scope &scope) { if (const Symbol * symbol{designator.GetBaseObject().symbol()}) { - return FindExternallyVisibleObject(*symbol, scope); + return FindExternallyVisibleObject(*symbol, scope, false); } else if (std::holds_alternative(designator.u)) { // Coindexed values are visible even if their image-local objects are not. return designator.GetBaseObject().symbol(); Index: flang/lib/Semantics/CMakeLists.txt =================================================================== --- flang/lib/Semantics/CMakeLists.txt +++ flang/lib/Semantics/CMakeLists.txt @@ -26,6 +26,7 @@ check-stop.cpp compute-offsets.cpp data-to-inits.cpp + definable.cpp expression.cpp mod-file.cpp pointer-assignment.cpp Index: flang/lib/Semantics/assignment.h =================================================================== --- flang/lib/Semantics/assignment.h +++ flang/lib/Semantics/assignment.h @@ -29,9 +29,6 @@ class Scope; class Symbol; -// Applies checks from C1594(1-2) on definitions in pure subprograms -bool CheckDefinabilityInPureScope(parser::ContextualMessages &, const Symbol &, - const Scope &context, const Scope &pure); // Applies checks from C1594(5-6) on copying pointers in pure subprograms bool CheckCopyabilityInPureScope(parser::ContextualMessages &, const evaluate::Expr &, const Scope &); Index: flang/lib/Semantics/assignment.cpp =================================================================== --- flang/lib/Semantics/assignment.cpp +++ flang/lib/Semantics/assignment.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "assignment.h" +#include "definable.h" #include "pointer-assignment.h" #include "flang/Common/idioms.h" #include "flang/Common/restorer.h" @@ -43,8 +44,8 @@ void Analyze(const parser::ConcurrentControl &); private: - bool CheckForPureContext(const SomeExpr &lhs, const SomeExpr &rhs, - parser::CharBlock rhsSource, bool isPointerAssignment); + bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource, + bool isPointerAssignment); void CheckShape(parser::CharBlock, const SomeExpr *); template parser::Message *Say(parser::CharBlock at, A &&...args) { @@ -65,16 +66,16 @@ const SomeExpr &lhs{assignment->lhs}; const SomeExpr &rhs{assignment->rhs}; auto lhsLoc{std::get(stmt.t).GetSource()}; - auto rhsLoc{std::get(stmt.t).source}; - if (CheckForPureContext(lhs, rhs, rhsLoc, false)) { - const Scope &scope{context_.FindScope(lhsLoc)}; - if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) { - if (auto *msg{Say(lhsLoc, - "Left-hand side of assignment is not modifiable"_err_en_US)}) { - msg->Attach(*whyNot); - } + const Scope &scope{context_.FindScope(lhsLoc)}; + if (auto whyNot{WhyNotDefinable(lhsLoc, scope, + DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, lhs)}) { + if (auto *msg{Say(lhsLoc, + "Left-hand side of assignment is not definable"_err_en_US)}) { + msg->Attach(std::move(*whyNot)); } } + auto rhsLoc{std::get(stmt.t).source}; + CheckForPureContext(rhs, rhsLoc, false); if (whereDepth_ > 0) { CheckShape(lhsLoc, &lhs); } @@ -84,52 +85,13 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) { CHECK(whereDepth_ == 0); if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) { - const SomeExpr &lhs{assignment->lhs}; const SomeExpr &rhs{assignment->rhs}; - CheckForPureContext(lhs, rhs, std::get(stmt.t).source, true); - auto restorer{ - foldingContext().messages().SetLocation(context_.location().value())}; - CheckPointerAssignment(foldingContext(), *assignment); - } -} - -// C1594 checks -static bool IsPointerDummyOfPureFunction(const Symbol &x) { - return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) && - x.owner().symbol() && IsFunction(*x.owner().symbol()); -} - -static const char *WhyBaseObjectIsSuspicious( - const Symbol &x, const Scope &scope) { - // See C1594, first paragraph. These conditions enable checks on both - // left-hand and right-hand sides in various circumstances. - if (IsHostAssociatedIntoSubprogram(x, scope)) { - return "host-associated"; - } else if (IsUseAssociated(x, scope)) { - return "USE-associated"; - } else if (IsPointerDummyOfPureFunction(x)) { - return "a POINTER dummy argument of a pure function"; - } else if (IsIntentIn(x)) { - return "an INTENT(IN) dummy argument"; - } else if (FindCommonBlockContaining(x)) { - return "in a COMMON block"; - } else { - return nullptr; - } -} - -// Checks C1594(1,2); false if check fails -bool CheckDefinabilityInPureScope(parser::ContextualMessages &messages, - const Symbol &lhs, const Scope &context, const Scope &pure) { - if (pure.symbol()) { - if (const char *why{WhyBaseObjectIsSuspicious(lhs, context)}) { - evaluate::SayWithDeclaration(messages, lhs, - "Pure subprogram '%s' may not define '%s' because it is %s"_err_en_US, - pure.symbol()->name(), lhs.name(), why); - return false; - } + CheckForPureContext(rhs, std::get(stmt.t).source, true); + parser::CharBlock at{context_.location().value()}; + auto restorer{foldingContext().messages().SetLocation(at)}; + const Scope &scope{context_.FindScope(at)}; + CheckPointerAssignment(foldingContext(), *assignment, scope); } - return true; } static std::optional GetPointerComponentDesignatorName( @@ -149,7 +111,8 @@ bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages, const SomeExpr &expr, const Scope &scope) { if (const Symbol * base{GetFirstSymbol(expr)}) { - if (const char *why{WhyBaseObjectIsSuspicious(*base, scope)}) { + if (const char *why{ + WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)}) { if (auto pointer{GetPointerComponentDesignatorName(expr)}) { evaluate::SayWithDeclaration(messages, *base, "A pure subprogram may not copy the value of '%s' because it is %s" @@ -162,56 +125,26 @@ return true; } -bool AssignmentContext::CheckForPureContext(const SomeExpr &lhs, - const SomeExpr &rhs, parser::CharBlock source, bool isPointerAssignment) { - const Scope &scope{context_.FindScope(source)}; - if (const Scope * pure{FindPureProcedureContaining(scope)}) { - parser::ContextualMessages messages{ - context_.location().value(), &context_.messages()}; - if (evaluate::ExtractCoarrayRef(lhs)) { - messages.Say( - "A pure subprogram may not define a coindexed object"_err_en_US); - } else if (const Symbol * base{GetFirstSymbol(lhs)}) { - if (const auto *assoc{base->detailsIf()}) { - auto dataRef{ExtractDataRef(assoc->expr(), true)}; - // ASSOCIATE(a=>x) -- check x, not a, for "a=..." - base = dataRef ? &dataRef->GetFirstSymbol() : nullptr; - } - if (base && - !CheckDefinabilityInPureScope(messages, *base, scope, *pure)) { - return false; - } - } - if (isPointerAssignment) { - if (const Symbol * base{GetFirstSymbol(rhs)}) { - if (const char *why{ - WhyBaseObjectIsSuspicious(*base, scope)}) { // C1594(3) - evaluate::SayWithDeclaration(messages, *base, - "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US, - base->name(), why); - return false; - } - } - } else if (auto type{evaluate::DynamicType::From(lhs)}) { - // C1596 checks for polymorphic deallocation in a pure subprogram - // due to automatic reallocation on assignment - if (type->IsPolymorphic()) { - context_.Say( - "Deallocation of polymorphic object is not permitted in a pure subprogram"_err_en_US); +bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs, + parser::CharBlock rhsSource, bool isPointerAssignment) { + const Scope &scope{context_.FindScope(rhsSource)}; + if (!FindPureProcedureContaining(scope)) { + return true; + } + parser::ContextualMessages messages{ + context_.location().value(), &context_.messages()}; + if (isPointerAssignment) { + if (const Symbol * base{GetFirstSymbol(rhs)}) { + if (const char *why{WhyBaseObjectIsSuspicious( + base->GetUltimate(), scope)}) { // C1594(3) + evaluate::SayWithDeclaration(messages, *base, + "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US, + base->name(), why); return false; } - if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) { - if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent( - *derived)}) { - evaluate::SayWithDeclaration(messages, *bad, - "Deallocation of polymorphic non-coarray component '%s' is not permitted in a pure subprogram"_err_en_US, - bad.BuildResultDesignatorName()); - return false; - } else { - return CheckCopyabilityInPureScope(messages, rhs, scope); - } - } } + } else { + return CheckCopyabilityInPureScope(messages, rhs, scope); } return true; } Index: flang/lib/Semantics/check-call.cpp =================================================================== --- flang/lib/Semantics/check-call.cpp +++ flang/lib/Semantics/check-call.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "check-call.h" +#include "definable.h" #include "pointer-assignment.h" #include "flang/Evaluate/characteristics.h" #include "flang/Evaluate/check-expression.h" @@ -389,13 +390,15 @@ reason = "INTENT(IN OUT)"; } if (reason && scope) { - bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21) - if (auto why{WhyNotModifiable( - messages.at(), actual, *scope, vectorSubscriptIsOk)}) { + DefinabilityFlags flags; + if (isElemental || dummyIsValue) { // 15.5.2.4(21) + flags.set(DefinabilityFlag::VectorSubscriptIsOk); + } + if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) { if (auto *msg{messages.Say( - "Actual argument associated with %s %s must be definable"_err_en_US, + "Actual argument associated with %s %s is not definable"_err_en_US, reason, dummyName)}) { - msg->Attach(*why); + msg->Attach(std::move(*whyNot)); } } } @@ -459,8 +462,10 @@ } if (!actualIsPointer) { if (dummy.intent == common::Intent::In) { - semantics::CheckPointerAssignment( - context, parser::CharBlock{}, dummyName, dummy, actual); + if (scope) { + semantics::CheckPointerAssignment( + context, messages.at(), dummyName, dummy, actual, *scope); + } } else { messages.Say( "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US, Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -671,7 +671,8 @@ if (auto designator{evaluate::AsGenericExpr(symbol)}) { auto restorer{messages_.SetLocation(symbol.name())}; context_.set_location(symbol.name()); - CheckInitialTarget(foldingContext_, *designator, *object->init()); + CheckInitialTarget( + foldingContext_, *designator, *object->init(), DEREF(scope_)); } } } else if (const auto *proc{symbol.detailsIf()}) { Index: flang/lib/Semantics/check-io.cpp =================================================================== --- flang/lib/Semantics/check-io.cpp +++ flang/lib/Semantics/check-io.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "check-io.h" +#include "definable.h" #include "flang/Common/format.h" #include "flang/Evaluate/tools.h" #include "flang/Parser/tools.h" @@ -1005,11 +1006,12 @@ if (const auto *var{parser::Unwrap(variable)}) { if (auto expr{AnalyzeExpr(context_, *var)}) { auto at{var->GetSource()}; - if (auto whyNot{WhyNotModifiable(at, *expr, context_.FindScope(at), - true /*vectorSubscriptIsOk*/)}) { + if (auto whyNot{WhyNotDefinable(at, context_.FindScope(at), + DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk}, + *expr)}) { const Symbol *base{GetFirstSymbol(*expr)}; context_ - .Say(at, "%s variable '%s' must be definable"_err_en_US, s, + .Say(at, "%s variable '%s' is not definable"_err_en_US, s, (base ? base->name() : at).ToString()) .Attach(std::move(*whyNot)); } Index: flang/lib/Semantics/check-nullify.cpp =================================================================== --- flang/lib/Semantics/check-nullify.cpp +++ flang/lib/Semantics/check-nullify.cpp @@ -7,7 +7,7 @@ //===----------------------------------------------------------------------===// #include "check-nullify.h" -#include "assignment.h" +#include "definable.h" #include "flang/Evaluate/expression.h" #include "flang/Parser/message.h" #include "flang/Parser/parse-tree.h" @@ -19,37 +19,32 @@ void NullifyChecker::Leave(const parser::NullifyStmt &nullifyStmt) { CHECK(context_.location()); const Scope &scope{context_.FindScope(*context_.location())}; - const Scope *pure{FindPureProcedureContaining(scope)}; - parser::ContextualMessages messages{ - *context_.location(), &context_.messages()}; for (const parser::PointerObject &pointerObject : nullifyStmt.v) { common::visit( common::visitors{ [&](const parser::Name &name) { - const Symbol *symbol{name.symbol}; - if (context_.HasError(symbol)) { - // already reported an error - } else if (!IsVariableName(*symbol) && - !IsProcedurePointer(*symbol)) { - messages.Say(name.source, - "name in NULLIFY statement must be a variable or procedure pointer"_err_en_US); - } else if (!IsPointer(*symbol)) { // C951 - messages.Say(name.source, - "name in NULLIFY statement must have the POINTER attribute"_err_en_US); - } else if (pure) { - CheckDefinabilityInPureScope(messages, *symbol, scope, *pure); + if (name.symbol) { + if (auto whyNot{WhyNotDefinable(name.source, scope, + DefinabilityFlags{DefinabilityFlag::PointerDefinition}, + *name.symbol)}) { + context_.messages() + .Say(name.source, + "'%s' may not appear in NULLIFY"_err_en_US, + name.source) + .Attach(std::move(*whyNot)); + } } }, [&](const parser::StructureComponent &structureComponent) { + const auto &component{structureComponent.component}; + SourceName at{component.source}; if (const auto *checkedExpr{GetExpr(context_, pointerObject)}) { - if (!IsPointer(*structureComponent.component.symbol)) { // C951 - messages.Say(structureComponent.component.source, - "component in NULLIFY statement must have the POINTER attribute"_err_en_US); - } else if (pure) { - if (const Symbol * symbol{GetFirstSymbol(*checkedExpr)}) { - CheckDefinabilityInPureScope( - messages, *symbol, scope, *pure); - } + if (auto whyNot{WhyNotDefinable(at, scope, + DefinabilityFlags{DefinabilityFlag::PointerDefinition}, + *checkedExpr)}) { + context_.messages() + .Say(at, "'%s' may not appear in NULLIFY"_err_en_US, at) + .Attach(std::move(*whyNot)); } } }, Index: flang/lib/Semantics/check-omp-structure.cpp =================================================================== --- flang/lib/Semantics/check-omp-structure.cpp +++ flang/lib/Semantics/check-omp-structure.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "check-omp-structure.h" +#include "definable.h" #include "flang/Parser/parse-tree.h" #include "flang/Semantics/tools.h" #include @@ -1963,9 +1964,9 @@ "in a %s clause"_err_en_US, symbol->name(), parser::ToUpperCaseLetters(getClauseName(clause).str())); - } - if (auto msg{ - WhyNotModifiable(*symbol, context_.FindScope(name->source))}) { + } else if (auto msg{WhyNotDefinable(name->source, + context_.FindScope(name->source), DefinabilityFlags{}, + *symbol)}) { context_ .Say(GetContext().clauseSource, "Variable '%s' on the %s clause is not definable"_err_en_US, @@ -2572,7 +2573,8 @@ for (auto it{symbols.begin()}; it != symbols.end(); ++it) { const auto *symbol{it->first}; const auto source{it->second}; - if (auto msg{WhyNotModifiable(*symbol, context_.FindScope(source))}) { + if (auto msg{WhyNotDefinable(source, context_.FindScope(source), + DefinabilityFlags{}, *symbol)}) { context_ .Say(source, "Variable '%s' on the %s clause is not definable"_err_en_US, Index: flang/lib/Semantics/data-to-inits.cpp =================================================================== --- flang/lib/Semantics/data-to-inits.cpp +++ flang/lib/Semantics/data-to-inits.cpp @@ -123,6 +123,7 @@ DataInitializations &inits_; evaluate::ExpressionAnalyzer &exprAnalyzer_; ValueListIterator values_; + const Scope *scope_{nullptr}; }; template @@ -141,7 +142,9 @@ template bool DataInitializationCompiler::Scan(const parser::Variable &var) { if (const auto *expr{GetExpr(exprAnalyzer_.context(), var)}) { - exprAnalyzer_.GetFoldingContext().messages().SetLocation(var.GetSource()); + parser::CharBlock at{var.GetSource()}; + exprAnalyzer_.GetFoldingContext().messages().SetLocation(at); + scope_ = &exprAnalyzer_.context().FindScope(at); if (InitDesignator(*expr)) { return true; } @@ -153,8 +156,9 @@ bool DataInitializationCompiler::Scan( const parser::Designator &designator) { if (auto expr{exprAnalyzer_.Analyze(designator)}) { - exprAnalyzer_.GetFoldingContext().messages().SetLocation( - parser::FindSourceLocation(designator)); + parser::CharBlock at{parser::FindSourceLocation(designator)}; + exprAnalyzer_.GetFoldingContext().messages().SetLocation(at); + scope_ = &exprAnalyzer_.context().FindScope(at); if (InitDesignator(*expr)) { return true; } @@ -361,7 +365,7 @@ return true; } else if (isProcPointer) { if (evaluate::IsProcedure(*expr)) { - if (CheckPointerAssignment(context, designator, *expr)) { + if (CheckPointerAssignment(context, designator, *expr, DEREF(scope_))) { if (lastSymbol->has()) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; @@ -382,7 +386,7 @@ exprAnalyzer_.Say( "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US, expr->AsFortran(), DescribeElement()); - } else if (CheckInitialTarget(context, designator, *expr)) { + } else if (CheckInitialTarget(context, designator, *expr, DEREF(scope_))) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; } Index: flang/lib/Semantics/definable.h =================================================================== --- /dev/null +++ flang/lib/Semantics/definable.h @@ -0,0 +1,50 @@ +//===-- lib/Semantics/definable.h -------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_SEMANTICS_DEFINABLE_H_ +#define FORTRAN_SEMANTICS_DEFINABLE_H_ + +// Utilities for checking the definability of variables and pointers in context, +// including checks for attempted definitions in PURE subprograms. +// Fortran 2018 C1101, C1158, C1594, &c. + +#include "flang/Common/enum-set.h" +#include "flang/Common/idioms.h" +#include "flang/Evaluate/expression.h" +#include "flang/Parser/char-block.h" +#include "flang/Parser/message.h" +#include + +namespace Fortran::semantics { + +class Symbol; +class Scope; + +ENUM_CLASS(DefinabilityFlag, + VectorSubscriptIsOk, // a vector subscript may appear (i.e., assignment) + PointerDefinition) // a pointer is being defined, not its target + +using DefinabilityFlags = + common::EnumSet; + +// Tests a symbol or LHS variable or pointer for definability in a given scope. +// When the entity is not definable, returns a "because:" Message suitable for +// attachment to an error message to explain why the entity cannot be defined. +// When the entity can be defined in that context, returns std::nullopt. +std::optional WhyNotDefinable( + parser::CharBlock, const Scope &, DefinabilityFlags, const Symbol &); +std::optional WhyNotDefinable(parser::CharBlock, const Scope &, + DefinabilityFlags, const evaluate::Expr &); + +// If a symbol would not be definable in a pure scope, or not be usable as the +// target of a pointer assignment in a pure scope, return a constant string +// describing why. +const char *WhyBaseObjectIsSuspicious(const Symbol &, const Scope &); + +} // namespace Fortran::semantics +#endif // FORTRAN_SEMANTICS_DEFINABLE_H_ Index: flang/lib/Semantics/definable.cpp =================================================================== --- /dev/null +++ flang/lib/Semantics/definable.cpp @@ -0,0 +1,246 @@ +//===-- lib/Semantics/definable.cpp ---------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "definable.h" +#include "flang/Evaluate/tools.h" +#include "flang/Semantics/tools.h" + +using namespace Fortran::parser::literals; + +namespace Fortran::semantics { + +template +static parser::Message BlameSymbol(parser::CharBlock at, + const parser::MessageFixedText &text, const Symbol &original, A &&...x) { + parser::Message message{at, text, original.name(), std::forward(x)...}; + message.set_severity(parser::Severity::Because); + evaluate::AttachDeclaration(message, original); + return message; +} + +static bool IsPointerDummyOfPureFunction(const Symbol &x) { + return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) && + x.owner().symbol() && IsFunction(*x.owner().symbol()); +} + +// See C1594, first paragraph. These conditions enable checks on both +// left-hand and right-hand sides in various circumstances. +const char *WhyBaseObjectIsSuspicious(const Symbol &x, const Scope &scope) { + if (IsHostAssociatedIntoSubprogram(x, scope)) { + return "host-associated"; + } else if (IsUseAssociated(x, scope)) { + return "USE-associated"; + } else if (IsPointerDummyOfPureFunction(x)) { + return "a POINTER dummy argument of a pure function"; + } else if (IsIntentIn(x)) { + return "an INTENT(IN) dummy argument"; + } else if (FindCommonBlockContaining(x)) { + return "in a COMMON block"; + } else { + return nullptr; + } +} + +// Checks C1594(1,2); false if check fails +static std::optional CheckDefinabilityInPureScope( + SourceName at, const Symbol &original, const Symbol &ultimate, + const Scope &context, const Scope &pure) { + if (pure.symbol()) { + if (const char *why{WhyBaseObjectIsSuspicious(ultimate, context)}) { + return BlameSymbol(at, + "'%s' may not be defined in pure subprogram '%s' because it is %s"_en_US, + original, pure.symbol()->name(), why); + } + } + return std::nullopt; +} + +// When a DataRef contains pointers, gets the rightmost one (unless it is +// the entity being defined, in which case the last pointer above it); +// otherwise, returns the leftmost symbol. The resulting symbol is the +// relevant base object for definabiliy checking. Examples: +// ptr1%ptr2 => ... -> ptr1 +// nonptr%ptr => ... -> nonptr +// nonptr%ptr = ... -> ptr +// ptr1%ptr2 = ... -> ptr2 +// ptr1%ptr2%nonptr = ... -> ptr2 +// nonptr1%nonptr2 = ... -> nonptr1 +static const Symbol &GetRelevantSymbol( + const evaluate::DataRef &dataRef, bool isPointerDefinition) { + if (isPointerDefinition) { + if (const auto *component{std::get_if(&dataRef.u)}) { + if (IsPointer(component->GetLastSymbol())) { + return GetRelevantSymbol(component->base(), false); + } + } + } + if (const Symbol * lastPointer{GetLastPointerSymbol(dataRef)}) { + return *lastPointer; + } else { + return dataRef.GetFirstSymbol(); + } +} + +// Check the leftmost (or only) symbol from a data-ref or expression. +static std::optional WhyNotDefinableBase(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, const Symbol &original) { + const Symbol &ultimate{original.GetUltimate()}; + bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)}; + bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)}; + if (const auto *association{ultimate.detailsIf()}) { + if (association->rank().has_value()) { + return std::nullopt; // SELECT RANK always modifiable variable + } else if (!IsVariable(association->expr())) { + return BlameSymbol(at, + "'%s' is construct associated with an expression"_en_US, original); + } else if (evaluate::HasVectorSubscript(association->expr().value())) { + return BlameSymbol(at, + "Construct association '%s' has a vector subscript"_en_US, original); + } else if (auto dataRef{evaluate::ExtractDataRef( + *association->expr(), true, true)}) { + return WhyNotDefinableBase( + at, scope, flags, GetRelevantSymbol(*dataRef, isPointerDefinition)); + } + } + if (isTargetDefinition) { + } else if (!isPointerDefinition && !IsVariableName(ultimate)) { + return BlameSymbol(at, "'%s' is not a variable"_en_US, original); + } else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) { + return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original); + } else if (IsIntentIn(ultimate)) { + return BlameSymbol( + at, "'%s' is an INTENT(IN) dummy argument"_en_US, original); + } + if (const Scope * pure{FindPureProcedureContaining(scope)}) { + // Additional checking for pure subprograms. + if (!isTargetDefinition) { + if (auto msg{CheckDefinabilityInPureScope( + at, original, ultimate, scope, *pure)}) { + return msg; + } + } + if (const Symbol * + visible{FindExternallyVisibleObject( + ultimate, *pure, isPointerDefinition)}) { + return BlameSymbol(at, + "'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US, + original, visible->name()); + } + } + return std::nullopt; +} + +static std::optional WhyNotDefinableLast(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, const Symbol &original) { + const Symbol &ultimate{original.GetUltimate()}; + if (flags.test(DefinabilityFlag::PointerDefinition)) { + if (!IsPointer(ultimate)) { + return BlameSymbol(at, "'%s' is not a pointer"_en_US, original); + } + return std::nullopt; // pointer assignment - skip following checks + } + if (IsOrContainsEventOrLockComponent(ultimate)) { + return BlameSymbol(at, + "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US, + original); + } + if (FindPureProcedureContaining(scope)) { + if (auto dyType{evaluate::DynamicType::From(ultimate)}) { + if (dyType->IsPolymorphic()) { // C1596 + return BlameSymbol(at, + "'%s' is polymorphic in a pure subprogram"_because_en_US, original); + } + if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) { + if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent( + *derived)}) { + return BlameSymbol(at, + "'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US, + original, bad.BuildResultDesignatorName()); + } + } + } + } + return std::nullopt; +} + +// Checks a data-ref +static std::optional WhyNotDefinable(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, + const evaluate::DataRef &dataRef) { + const Symbol &base{GetRelevantSymbol( + dataRef, flags.test(DefinabilityFlag::PointerDefinition))}; + if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) { + return whyNot; + } else { + return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol()); + } +} + +// Checks a NOPASS procedure pointer component +static std::optional WhyNotDefinable(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, + const evaluate::Component &component) { + const evaluate::DataRef &dataRef{component.base()}; + const Symbol &base{GetRelevantSymbol(dataRef, false)}; + DefinabilityFlags baseFlags{flags}; + baseFlags.reset(DefinabilityFlag::PointerDefinition); + return WhyNotDefinableBase(at, scope, baseFlags, base); +} + +std::optional WhyNotDefinable(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, const Symbol &original) { + if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) { + return base; + } + return WhyNotDefinableLast(at, scope, flags, original); +} + +std::optional WhyNotDefinable(parser::CharBlock at, + const Scope &scope, DefinabilityFlags flags, + const evaluate::Expr &expr) { + if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) { + if (!flags.test(DefinabilityFlag::VectorSubscriptIsOk) && + evaluate::HasVectorSubscript(expr)) { + return parser::Message{at, + "Variable '%s' has a vector subscript"_because_en_US, + expr.AsFortran()}; + } + if (FindPureProcedureContaining(scope) && + evaluate::ExtractCoarrayRef(expr)) { + return parser::Message(at, + "A pure subprogram may not define the coindexed object '%s'"_because_en_US, + expr.AsFortran()); + } + return WhyNotDefinable(at, scope, flags, *dataRef); + } + if (evaluate::IsVariable(expr)) { + return std::nullopt; // result of function returning a pointer - ok + } + if (flags.test(DefinabilityFlag::PointerDefinition)) { + if (const auto *procDesignator{ + std::get_if(&expr.u)}) { + // Defining a procedure pointer + if (const Symbol * procSym{procDesignator->GetSymbol()}) { + if (evaluate::ExtractCoarrayRef(expr)) { // C1027 + return BlameSymbol(at, + "Procedure pointer '%s' may not be a coindexed object"_because_en_US, + *procSym, expr.AsFortran()); + } + if (const auto *component{procDesignator->GetComponent()}) { + return WhyNotDefinable(at, scope, flags, *component); + } else { + return WhyNotDefinable(at, scope, flags, *procSym); + } + } + } + } + return parser::Message{ + at, "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()}; +} + +} // namespace Fortran::semantics Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -1783,11 +1783,11 @@ } unavailable.insert(symbol->name()); if (value) { + const auto &innermost{context_.FindScope(expr.source)}; if (symbol->has()) { CHECK(IsPointer(*symbol)); } else if (symbol->has()) { // C1594(4) - const auto &innermost{context_.FindScope(expr.source)}; if (const auto *pureProc{FindPureProcedureContaining(innermost)}) { if (const Symbol * pointer{FindPointerComponent(*symbol)}) { if (const Symbol * @@ -1817,8 +1817,8 @@ continue; } if (IsPointer(*symbol)) { - semantics::CheckPointerAssignment( - GetFoldingContext(), *symbol, *value); // C7104, C7105 + semantics::CheckStructConstructorPointerComponent( + GetFoldingContext(), *symbol, *value, innermost); // C7104, C7105 result.Add(*symbol, Fold(std::move(*value))); } else if (MaybeExpr converted{ ConvertToType(*symbol, std::move(*value))}) { Index: flang/lib/Semantics/pointer-assignment.h =================================================================== --- flang/lib/Semantics/pointer-assignment.h +++ flang/lib/Semantics/pointer-assignment.h @@ -27,19 +27,20 @@ class Symbol; bool CheckPointerAssignment( - evaluate::FoldingContext &, const evaluate::Assignment &); + evaluate::FoldingContext &, const evaluate::Assignment &, const Scope &); bool CheckPointerAssignment(evaluate::FoldingContext &, const SomeExpr &lhs, - const SomeExpr &rhs, bool isBoundsRemapping = false); -bool CheckPointerAssignment( - evaluate::FoldingContext &, const Symbol &lhs, const SomeExpr &rhs); + const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false); +bool CheckStructConstructorPointerComponent(evaluate::FoldingContext &, + const Symbol &lhs, const SomeExpr &rhs, const Scope &); bool CheckPointerAssignment(evaluate::FoldingContext &, parser::CharBlock source, const std::string &description, - const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs); + const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs, + const Scope &); // Checks whether an expression is a valid static initializer for a // particular pointer designator. -bool CheckInitialTarget( - evaluate::FoldingContext &, const SomeExpr &pointer, const SomeExpr &init); +bool CheckInitialTarget(evaluate::FoldingContext &, const SomeExpr &pointer, + const SomeExpr &init, const Scope &); } // namespace Fortran::semantics Index: flang/lib/Semantics/pointer-assignment.cpp =================================================================== --- flang/lib/Semantics/pointer-assignment.cpp +++ flang/lib/Semantics/pointer-assignment.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "pointer-assignment.h" +#include "definable.h" #include "flang/Common/idioms.h" #include "flang/Common/restorer.h" #include "flang/Evaluate/characteristics.h" @@ -40,10 +41,13 @@ class PointerAssignmentChecker { public: PointerAssignmentChecker(evaluate::FoldingContext &context, - parser::CharBlock source, const std::string &description) - : context_{context}, source_{source}, description_{description} {} - PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs) - : context_{context}, source_{lhs.name()}, + const Scope &scope, parser::CharBlock source, + const std::string &description) + : context_{context}, scope_{scope}, source_{source}, description_{ + description} {} + PointerAssignmentChecker( + evaluate::FoldingContext &context, const Scope &scope, const Symbol &lhs) + : context_{context}, scope_{scope}, source_{lhs.name()}, description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs} { set_lhsType(TypeAndShape::Characterize(lhs, context)); set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS)); @@ -53,6 +57,7 @@ PointerAssignmentChecker &set_isContiguous(bool); PointerAssignmentChecker &set_isVolatile(bool); PointerAssignmentChecker &set_isBoundsRemapping(bool); + bool CheckLeftHandSide(const SomeExpr &); bool Check(const SomeExpr &); private: @@ -72,6 +77,7 @@ template parser::Message *Say(A &&...); evaluate::FoldingContext &context_; + const Scope &scope_; const parser::CharBlock source_; const std::string description_; const Symbol *lhs_{nullptr}; @@ -117,6 +123,19 @@ return procedure_.has_value(); } +bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) { + if (auto whyNot{WhyNotDefinable(context_.messages().at(), scope_, + DefinabilityFlags{DefinabilityFlag::PointerDefinition}, lhs)}) { + if (auto *msg{context_.messages().Say( + "The left-hand side of a pointer assignment is not definable"_err_en_US)}) { + msg->Attach(std::move(*whyNot)); + } + return false; + } else { + return true; + } +} + template bool PointerAssignmentChecker::Check(const T &) { // Catch-all case for really bad target expression Say("Target associated with %s must be a designator or a call to a" @@ -384,43 +403,34 @@ return isBoundsRemapping; } -bool CheckPointerAssignment( - evaluate::FoldingContext &context, const evaluate::Assignment &assignment) { - return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, +bool CheckPointerAssignment(evaluate::FoldingContext &context, + const evaluate::Assignment &assignment, const Scope &scope) { + return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope, CheckPointerBounds(context, assignment)); } bool CheckPointerAssignment(evaluate::FoldingContext &context, - const SomeExpr &lhs, const SomeExpr &rhs, bool isBoundsRemapping) { + const SomeExpr &lhs, const SomeExpr &rhs, const Scope &scope, + bool isBoundsRemapping) { const Symbol *pointer{GetLastSymbol(lhs)}; if (!pointer) { return false; // error was reported } - if (!IsPointer(pointer->GetUltimate())) { - evaluate::SayWithDeclaration(context.messages(), *pointer, - "'%s' is not a pointer"_err_en_US, pointer->name()); - return false; - } - if (pointer->has() && evaluate::ExtractCoarrayRef(lhs)) { - context.messages().Say( // C1027 - "Procedure pointer may not be a coindexed object"_err_en_US); - return false; - } - return PointerAssignmentChecker{context, *pointer} - .set_isBoundsRemapping(isBoundsRemapping) - .Check(rhs); + PointerAssignmentChecker checker{context, scope, *pointer}; + checker.set_isBoundsRemapping(isBoundsRemapping); + return checker.CheckLeftHandSide(lhs) & checker.Check(rhs); } -bool CheckPointerAssignment( - evaluate::FoldingContext &context, const Symbol &lhs, const SomeExpr &rhs) { +bool CheckStructConstructorPointerComponent(evaluate::FoldingContext &context, + const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) { CHECK(IsPointer(lhs)); - return PointerAssignmentChecker{context, lhs}.Check(rhs); + return PointerAssignmentChecker{context, scope, lhs}.Check(rhs); } bool CheckPointerAssignment(evaluate::FoldingContext &context, parser::CharBlock source, const std::string &description, - const DummyDataObject &lhs, const SomeExpr &rhs) { - return PointerAssignmentChecker{context, source, description} + const DummyDataObject &lhs, const SomeExpr &rhs, const Scope &scope) { + return PointerAssignmentChecker{context, scope, source, description} .set_lhsType(common::Clone(lhs.type)) .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous)) .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile)) @@ -428,9 +438,9 @@ } bool CheckInitialTarget(evaluate::FoldingContext &context, - const SomeExpr &pointer, const SomeExpr &init) { + const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) { return evaluate::IsInitialDataTarget(init, &context.messages()) && - CheckPointerAssignment(context, pointer, init); + CheckPointerAssignment(context, pointer, init, scope); } } // namespace Fortran::semantics Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -7,6 +7,7 @@ #include "resolve-names.h" #include "assignment.h" +#include "definable.h" #include "mod-file.h" #include "pointer-assignment.h" #include "program-tree.h" @@ -5683,11 +5684,12 @@ "Assumed size array '%s' not allowed in a locality-spec"_err_en_US); return false; } - if (std::optional msg{WhyNotModifiable(symbol, currScope())}) { + if (std::optional whyNot{WhyNotDefinable( + name.source, currScope(), DefinabilityFlags{}, symbol)}) { SayWithReason(name, symbol, "'%s' may not appear in a locality-spec because it is not " "definable"_err_en_US, - std::move(*msg)); + std::move(*whyNot)); return false; } return PassesSharedLocalityChecks(name, symbol); Index: flang/lib/Semantics/tools.cpp =================================================================== --- flang/lib/Semantics/tools.cpp +++ flang/lib/Semantics/tools.cpp @@ -221,10 +221,9 @@ } bool IsUseAssociated(const Symbol &symbol, const Scope &scope) { - const Scope &owner{ - GetProgramUnitOrBlockConstructContaining(symbol.GetUltimate().owner())}; + const Scope &owner{GetTopLevelUnitContaining(symbol.GetUltimate().owner())}; return owner.kind() == Scope::Kind::Module && - owner != GetProgramUnitOrBlockConstructContaining(scope); + owner != GetTopLevelUnitContaining(scope); } bool DoesScopeContain( @@ -362,7 +361,7 @@ // C1594 specifies several ways by which an object might be globally visible. const Symbol *FindExternallyVisibleObject( - const Symbol &object, const Scope &scope) { + const Symbol &object, const Scope &scope, bool isPointerDefinition) { // TODO: Storage association with any object for which this predicate holds, // once EQUIVALENCE is supported. const Symbol &ultimate{GetAssociationRoot(object)}; @@ -370,10 +369,12 @@ if (IsIntentIn(ultimate)) { return &ultimate; } - if (IsPointer(ultimate) && IsPureProcedure(ultimate.owner()) && - IsFunction(ultimate.owner())) { + if (!isPointerDefinition && IsPointer(ultimate) && + IsPureProcedure(ultimate.owner()) && IsFunction(ultimate.owner())) { return &ultimate; } + } else if (ultimate.owner().IsDerivedType()) { + return nullptr; } else if (&GetProgramUnitContaining(ultimate) != &GetProgramUnitContaining(scope)) { return &object; @@ -776,13 +777,6 @@ bool IsModuleProcedure(const Symbol &symbol) { return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module; } -const Symbol *IsExternalInPureContext( - const Symbol &symbol, const Scope &scope) { - if (const auto *pureProc{FindPureProcedureContaining(scope)}) { - return FindExternallyVisibleObject(symbol.GetUltimate(), *pureProc); - } - return nullptr; -} PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent( const DerivedTypeSpec &derived) { @@ -812,114 +806,6 @@ return false; } -bool InProtectedContext(const Symbol &symbol, const Scope ¤tScope) { - return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope); -} - -// C1101 and C1158 -// Modifiability checks on the leftmost symbol ("base object") -// of a data-ref -static std::optional WhyNotModifiableFirst( - parser::CharBlock at, const Symbol &symbol, const Scope &scope) { - if (const auto *assoc{symbol.detailsIf()}) { - if (assoc->rank().has_value()) { - return std::nullopt; // SELECT RANK always modifiable variable - } else if (IsVariable(assoc->expr())) { - if (evaluate::HasVectorSubscript(assoc->expr().value())) { - return parser::Message{ - at, "Construct association has a vector subscript"_en_US}; - } else { - return WhyNotModifiable(at, *assoc->expr(), scope); - } - } else { - return parser::Message{at, - "'%s' is construct associated with an expression"_en_US, - symbol.name()}; - } - } else if (IsExternalInPureContext(symbol, scope)) { - return parser::Message{at, - "'%s' is externally visible and referenced in a pure" - " procedure"_en_US, - symbol.name()}; - } else if (!IsVariableName(symbol)) { - return parser::Message{at, "'%s' is not a variable"_en_US, symbol.name()}; - } else { - return std::nullopt; - } -} - -// Modifiability checks on the rightmost symbol of a data-ref -static std::optional WhyNotModifiableLast( - parser::CharBlock at, const Symbol &symbol, const Scope &scope) { - if (IsOrContainsEventOrLockComponent(symbol)) { - return parser::Message{at, - "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US, - symbol.name()}; - } else { - return std::nullopt; - } -} - -// Modifiability checks on the leftmost (base) symbol of a data-ref -// that apply only when there are no pointer components or a base -// that is a pointer. -static std::optional WhyNotModifiableIfNoPtr( - parser::CharBlock at, const Symbol &symbol, const Scope &scope) { - if (InProtectedContext(symbol, scope)) { - return parser::Message{ - at, "'%s' is protected in this scope"_en_US, symbol.name()}; - } else if (IsIntentIn(symbol)) { - return parser::Message{ - at, "'%s' is an INTENT(IN) dummy argument"_en_US, symbol.name()}; - } else { - return std::nullopt; - } -} - -// Apply all modifiability checks to a single symbol -std::optional WhyNotModifiable( - const Symbol &original, const Scope &scope) { - const Symbol &symbol{GetAssociationRoot(original)}; - if (auto first{WhyNotModifiableFirst(symbol.name(), symbol, scope)}) { - return first; - } else if (auto last{WhyNotModifiableLast(symbol.name(), symbol, scope)}) { - return last; - } else if (!IsPointer(symbol)) { - return WhyNotModifiableIfNoPtr(symbol.name(), symbol, scope); - } else { - return std::nullopt; - } -} - -// Modifiability checks for a data-ref -std::optional WhyNotModifiable(parser::CharBlock at, - const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) { - if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) { - if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) { - return parser::Message{at, "Variable has a vector subscript"_en_US}; - } - const Symbol &first{GetAssociationRoot(dataRef->GetFirstSymbol())}; - if (auto maybeWhyFirst{WhyNotModifiableFirst(at, first, scope)}) { - return maybeWhyFirst; - } - const Symbol &last{dataRef->GetLastSymbol()}; - if (auto maybeWhyLast{WhyNotModifiableLast(at, last, scope)}) { - return maybeWhyLast; - } - if (!GetLastPointerSymbol(*dataRef)) { - if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(at, first, scope)}) { - return maybeWhyFirst; - } - } - } else if (!evaluate::IsVariable(expr)) { - return parser::Message{ - at, "'%s' is not a variable"_en_US, expr.AsFortran()}; - } else { - // reference to function returning POINTER - } - return std::nullopt; -} - class ImageControlStmtHelper { using ImageControlStmts = std::variant x y%a => x - !ERROR: 'b' is not a pointer + !ERROR: The left-hand side of a pointer assignment is not definable + !BECAUSE: 'b' is not a pointer y%b => x end Index: flang/test/Semantics/assign03.f90 =================================================================== --- flang/test/Semantics/assign03.f90 +++ flang/test/Semantics/assign03.f90 @@ -17,7 +17,8 @@ type(t), allocatable :: a(:) type(t), allocatable :: b[:] a(1)%p => s - !ERROR: Procedure pointer may not be a coindexed object + !ERROR: The left-hand side of a pointer assignment is not definable + !BECAUSE: Procedure pointer 'p' may not be a coindexed object b[1]%p => s end ! C1028 Index: flang/test/Semantics/assign04.f90 =================================================================== --- flang/test/Semantics/assign04.f90 +++ flang/test/Semantics/assign04.f90 @@ -22,11 +22,14 @@ !ERROR: Assignment to constant 'x' is not allowed x = 2.0 i = 2 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'a' is not a variable a(i) = 3.0 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'a' is not a variable a(i:i+1) = [4, 5] - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'c' is not a variable c(i:2) = "cd" end @@ -40,7 +43,8 @@ type(t), parameter :: y = t([1,2], 3) integer :: i = 1 x%a(i) = 1 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'y' is not a variable y%a(i) = 2 x%b = 4 !ERROR: Assignment to constant 'y%b' is not allowed @@ -57,11 +61,14 @@ type(t), intent(in) :: x character(10), intent(in) :: c type(t) :: y - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'x' is an INTENT(IN) dummy argument x = y - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'x' is an INTENT(IN) dummy argument x%a(1) = 2 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'c' is an INTENT(IN) dummy argument c(2:3) = "ab" end end @@ -80,11 +87,13 @@ use m5 implicit none x = 1.0 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'y' is protected in this scope y = 2.0 !ERROR: No explicit type declared for 'z' z = 3.0 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'b' is protected in this scope b%a = 1.0 end Index: flang/test/Semantics/atomic03.f90 =================================================================== --- flang/test/Semantics/atomic03.f90 +++ flang/test/Semantics/atomic03.f90 @@ -178,7 +178,8 @@ !ERROR: 'stat' argument to 'atomic_cas' may not be a coindexed object call atomic_cas(int_scalar_coarray, old_int, compare_int, new_int, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_cas(int_scalar_coarray, old_int, compare_int, new_int, 1) ! missing mandatory arguments Index: flang/test/Semantics/atomic04.f90 =================================================================== --- flang/test/Semantics/atomic04.f90 +++ flang/test/Semantics/atomic04.f90 @@ -103,7 +103,8 @@ !ERROR: 'stat' argument to 'atomic_define' may not be a coindexed object call atomic_define(scalar_coarray, val, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_define(scalar_coarray, val, 1) !ERROR: missing mandatory 'atom=' argument Index: flang/test/Semantics/atomic05.f90 =================================================================== --- flang/test/Semantics/atomic05.f90 +++ flang/test/Semantics/atomic05.f90 @@ -79,7 +79,8 @@ !ERROR: 'stat' argument to 'atomic_fetch_add' may not be a coindexed object call atomic_fetch_add(scalar_coarray, val, old_val, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_fetch_add(scalar_coarray, val, old_val, 1) !ERROR: missing mandatory 'atom=' argument Index: flang/test/Semantics/atomic06.f90 =================================================================== --- flang/test/Semantics/atomic06.f90 +++ flang/test/Semantics/atomic06.f90 @@ -79,7 +79,8 @@ !ERROR: 'stat' argument to 'atomic_fetch_and' may not be a coindexed object call atomic_fetch_and(scalar_coarray, val, old_val, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_fetch_and(scalar_coarray, val, old_val, 1) !ERROR: missing mandatory 'atom=' argument Index: flang/test/Semantics/atomic07.f90 =================================================================== --- flang/test/Semantics/atomic07.f90 +++ flang/test/Semantics/atomic07.f90 @@ -75,7 +75,8 @@ !ERROR: 'stat' argument to 'atomic_fetch_or' may not be a coindexed object call atomic_fetch_or(scalar_coarray[1], val_coarray[1], old_val_coarray[1], coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_fetch_or(scalar_coarray, val, old_val, 1) !ERROR: missing mandatory 'atom=' argument Index: flang/test/Semantics/atomic08.f90 =================================================================== --- flang/test/Semantics/atomic08.f90 +++ flang/test/Semantics/atomic08.f90 @@ -68,7 +68,8 @@ call atomic_fetch_xor(scalar_coarray, val, old_val, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_fetch_xor(scalar_coarray, val, old_val, 1) !ERROR: missing mandatory 'atom=' argument Index: flang/test/Semantics/atomic10.f90 =================================================================== --- flang/test/Semantics/atomic10.f90 +++ flang/test/Semantics/atomic10.f90 @@ -103,7 +103,8 @@ !ERROR: 'stat' argument to 'atomic_ref' may not be a coindexed object call atomic_ref(val, scalar_coarray, coindexed_status[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '1_4' is not a variable or pointer call atomic_ref(val, scalar_coarray, 1) !ERROR: missing mandatory 'value=' argument Index: flang/test/Semantics/call03.f90 =================================================================== --- flang/test/Semantics/call03.f90 +++ flang/test/Semantics/call03.f90 @@ -252,27 +252,37 @@ real, intent(in) :: in real :: x x = 0. - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: 'in' is an INTENT(IN) dummy argument call intentout(in) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: '3.141590118408203125_4' is not a variable or pointer call intentout(3.14159) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: 'in+1._4' is not a variable or pointer call intentout(in + 1.) call intentout(x) ! ok - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: '(x)' is not a variable or pointer call intentout((x)) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'count=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'count=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call system_clock(count=2) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: 'in' is an INTENT(IN) dummy argument call intentinout(in) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: '3.141590118408203125_4' is not a variable or pointer call intentinout(3.14159) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: 'in+1._4' is not a variable or pointer call intentinout(in + 1.) call intentinout(x) ! ok - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: '(x)' is not a variable or pointer call intentinout((x)) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'exitstat=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'exitstat=' is not definable + !BECAUSE: '0_4' is not a variable or pointer call execute_command_line(command="echo hello", exitstat=0) end subroutine @@ -280,9 +290,11 @@ real :: a(1) integer :: j(1) j(1) = 1 - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: Variable 'a(int(j,kind=8))' has a vector subscript call intentout_arr(a(j)) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: Variable 'a(int(j,kind=8))' has a vector subscript call intentinout_arr(a(j)) call asynchronous_arr(a(j)) ! ok call volatile_arr(a(j)) ! ok Index: flang/test/Semantics/call06.f90 =================================================================== --- flang/test/Semantics/call06.f90 +++ flang/test/Semantics/call06.f90 @@ -48,9 +48,11 @@ call s04(cov[1]) ! ok !ERROR: ALLOCATABLE dummy argument 'x=' must have INTENT(IN) to be associated with a coindexed actual argument call s01(cov[1]) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: 'x' is an INTENT(IN) dummy argument call s05(x) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: 'x' is an INTENT(IN) dummy argument call s06(x) end subroutine end module Index: flang/test/Semantics/call10.f90 =================================================================== --- flang/test/Semantics/call10.f90 +++ flang/test/Semantics/call10.f90 @@ -160,7 +160,8 @@ !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram type(polyAlloc) :: auto type(polyAlloc), intent(in out) :: to - !ERROR: Deallocation of polymorphic non-coarray component '%a' is not permitted in a pure subprogram + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'to' has polymorphic non-coarray component '%a' in a pure subprogram to = auto end subroutine pure subroutine s12 Index: flang/test/Semantics/call12.f90 =================================================================== --- flang/test/Semantics/call12.f90 +++ flang/test/Semantics/call12.f90 @@ -38,21 +38,29 @@ integer :: n common /block/ y external :: extfunc - !ERROR: Pure subprogram 'test' may not define 'x' because it is host-associated + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'x' may not be defined in pure subprogram 'test' because it is host-associated x%a = 0. - !ERROR: Pure subprogram 'test' may not define 'y' because it is in a COMMON block + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'y' may not be defined in pure subprogram 'test' because it is in a COMMON block y%a = 0. ! C1594(1) - !ERROR: Pure subprogram 'test' may not define 'useassociated' because it is USE-associated + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'useassociated' may not be defined in pure subprogram 'test' because it is USE-associated useassociated = 0. ! C1594(1) - !ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'ptr' is externally visible via 'ptr' and not definable in a pure subprogram ptr%a = 0. ! C1594(1) - !ERROR: Pure subprogram 'test' may not define 'in' because it is an INTENT(IN) dummy argument + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'in' is an INTENT(IN) dummy argument in%a = 0. ! C1594(1) - !ERROR: A pure subprogram may not define a coindexed object + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: A pure subprogram may not define the coindexed object 'hcp%co[1_8]' hcp%co[1] = 0. ! C1594(1) - !ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function + !ERROR: The left-hand side of a pointer assignment is not definable + !BECAUSE: 'ptr' may not be defined in pure subprogram 'test' because it is a POINTER dummy argument of a pure function ptr => z ! C1594(2) - !ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function + !ERROR: 'ptr' may not appear in NULLIFY + !BECAUSE: 'ptr' may not be defined in pure subprogram 'test' because it is a POINTER dummy argument of a pure function nullify(ptr) ! C1594(2), 19.6.8 !ERROR: A pure subprogram may not use 'ptr' as the target of pointer assignment because it is a POINTER dummy argument of a pure function ptr2 => ptr ! C1594(3) @@ -77,7 +85,8 @@ contains pure subroutine internal type(hasPtr) :: localhp - !ERROR: Pure subprogram 'internal' may not define 'z' because it is host-associated + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'z' may not be defined in pure subprogram 'internal' because it is host-associated z%a = 0. !ERROR: Externally visible object 'z' may not be associated with pointer component 'p' in a pure procedure localhp = hasPtr(z%a) Index: flang/test/Semantics/collectives01.f90 =================================================================== --- flang/test/Semantics/collectives01.f90 +++ flang/test/Semantics/collectives01.f90 @@ -85,7 +85,8 @@ call co_sum(bool) ! argument 'a' is intent(inout) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_sum(a=1+1) !ERROR: 'a' argument to 'co_sum' may not be a coindexed object @@ -100,7 +101,8 @@ call co_sum(c, result_image=integer_array) ! argument 'stat' shall be intent(out) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_sum(a=i, result_image=1, stat=1+1, errmsg=message) !ERROR: 'stat' argument to 'co_sum' may not be a coindexed object @@ -118,7 +120,8 @@ call co_sum(i, stat=integer_array) ! 'errmsg' argument shall be intent(inout) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable + !BECAUSE: '"c"' is not a variable or pointer call co_sum(a=i, result_image=1, stat=status, errmsg='c') !ERROR: 'errmsg' argument to 'co_sum' may not be a coindexed object Index: flang/test/Semantics/collectives02.f90 =================================================================== --- flang/test/Semantics/collectives02.f90 +++ flang/test/Semantics/collectives02.f90 @@ -83,7 +83,8 @@ !ERROR: Actual argument for 'a=' has bad type 'COMPLEX(4)' call co_min(complex_type) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_min(a=1+1) !ERROR: 'a' argument to 'co_min' may not be a coindexed object @@ -105,7 +106,8 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call co_min(i, stat=integer_array) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable + !BECAUSE: '"c"' is not a variable or pointer call co_min(a=i, result_image=1, stat=status, errmsg='c') !ERROR: 'errmsg' argument to 'co_min' may not be a coindexed object Index: flang/test/Semantics/collectives03.f90 =================================================================== --- flang/test/Semantics/collectives03.f90 +++ flang/test/Semantics/collectives03.f90 @@ -83,7 +83,8 @@ !ERROR: Actual argument for 'a=' has bad type 'COMPLEX(4)' call co_max(complex_type) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_max(a=1+1) !ERROR: 'a' argument to 'co_max' may not be a coindexed object @@ -105,7 +106,8 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call co_max(i, stat=integer_array) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable + !BECAUSE: '"c"' is not a variable or pointer call co_max(a=i, result_image=1, stat=status, errmsg='c') !ERROR: 'errmsg' argument to 'co_max' may not be a coindexed object Index: flang/test/Semantics/collectives04.f90 =================================================================== --- flang/test/Semantics/collectives04.f90 +++ flang/test/Semantics/collectives04.f90 @@ -79,7 +79,8 @@ !ERROR: missing mandatory 'source_image=' argument call co_broadcast(a=c, stat=status, errmsg=message) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_broadcast(a=1+1, source_image=1) !ERROR: 'a' argument to 'co_broadcast' may not be a coindexed object @@ -93,7 +94,8 @@ !ERROR: 'source_image=' argument has unacceptable rank 1 call co_broadcast(c, source_image=integer_array) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable + !BECAUSE: '2_4' is not a variable or pointer call co_broadcast(a=i, source_image=1, stat=1+1, errmsg=message) !ERROR: 'stat' argument to 'co_broadcast' may not be a coindexed object @@ -106,7 +108,8 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call co_broadcast(i, stat=integer_array, source_image=1) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable + !BECAUSE: '"c"' is not a variable or pointer call co_broadcast(a=i, source_image=1, stat=status, errmsg='c') !ERROR: 'errmsg' argument to 'co_broadcast' may not be a coindexed object Index: flang/test/Semantics/deallocate05.f90 =================================================================== --- flang/test/Semantics/deallocate05.f90 +++ flang/test/Semantics/deallocate05.f90 @@ -57,7 +57,8 @@ !ERROR: STAT may not be duplicated in a DEALLOCATE statement Deallocate(x, stat=s, stat=s) -!ERROR: STAT variable 'const_s' must be definable +!ERROR: STAT variable 'const_s' is not definable +!BECAUSE: '13_4' is not a variable or pointer Deallocate(x, stat=const_s) !ERROR: ERRMSG may not be duplicated in a DEALLOCATE statement Deallocate(x, errmsg=ee, errmsg=ee) Index: flang/test/Semantics/io01.f90 =================================================================== --- flang/test/Semantics/io01.f90 +++ flang/test/Semantics/io01.f90 @@ -75,7 +75,8 @@ !ERROR: If NEWUNIT appears, FILE or STATUS must also appear open(newunit=n, newunit=nn, iostat=stat4) - !ERROR: NEWUNIT variable 'const_new_unit' must be definable + !ERROR: NEWUNIT variable 'const_new_unit' is not definable + !BECAUSE: '66_4' is not a variable or pointer open(newunit=const_new_unit, status=cc) !ERROR: Duplicate UNIT specifier Index: flang/test/Semantics/io02.f90 =================================================================== --- flang/test/Semantics/io02.f90 +++ flang/test/Semantics/io02.f90 @@ -32,7 +32,8 @@ !Ok: trailing spaces ignored close(status='keep ', unit=17) - !ERROR: IOSTAT variable 'const_stat' must be definable + !ERROR: IOSTAT variable 'const_stat' is not definable + !BECAUSE: '6666_4' is not a variable or pointer close(14, iostat=const_stat) 9 continue Index: flang/test/Semantics/io03.f90 =================================================================== --- flang/test/Semantics/io03.f90 +++ flang/test/Semantics/io03.f90 @@ -7,7 +7,7 @@ character(20) advance character(20) :: cvar; character, parameter :: const_internal_file = "(I6)" - character, parameter :: const_cvar = "Ceci n'est pas une pipe." + character, parameter :: const_cvar*(*) = "Ceci n'est pas une pipe." integer*1 stat1 integer*2 stat2, id2 integer*8 stat8 @@ -61,16 +61,20 @@ !ERROR: Internal file must not have a vector subscript read(internal_fileA(vv), *) jj - !ERROR: Input variable 'const_int' must be definable + !ERROR: Input variable 'const_int' is not definable + !BECAUSE: '15_4' is not a variable or pointer read(11, *) const_int - !ERROR: SIZE variable 'const_size' must be definable + !ERROR: SIZE variable 'const_size' is not definable + !BECAUSE: '13_4' is not a variable or pointer read(11, pos=ipos, size=const_size, end=9) - !ERROR: Input variable 'const_cvar' must be definable + !ERROR: Input variable 'const_cvar' is not definable + !BECAUSE: '"Ceci n'est pas une pipe."' is not a variable or pointer read(11, *) const_cvar - !ERROR: Input variable 'const_cvar' must be definable + !ERROR: Input variable 'const_cvar(3:13)' is not definable + !BECAUSE: '"ci n'est pa"' is not a variable or pointer read(11, *) const_cvar(3:13) !ERROR: Duplicate IOSTAT specifier @@ -172,7 +176,8 @@ read(*, *) aa(n:n+2,2) read(*, *) qq(2:5)%y - !ERROR: Input variable 'n' must be definable + !ERROR: Input variable 'n' is not definable + !BECAUSE: 'n' is an INTENT(IN) dummy argument read(*, *) n !ERROR: Whole assumed-size array 'aa' may not appear here without subscripts Index: flang/test/Semantics/io04.f90 =================================================================== --- flang/test/Semantics/io04.f90 +++ flang/test/Semantics/io04.f90 @@ -2,7 +2,7 @@ character(kind=1,len=50) internal_file character(kind=1,len=100) msg character(20) sign - character, parameter :: const_internal_file = "(I6)" + character, parameter :: const_internal_file*(*) = "(I6)" integer*1 stat1, id1 integer*2 stat2 integer*4 stat4 @@ -69,7 +69,8 @@ !ERROR: If NML appears, a data list must not appear write(10, nnn, rec=40, fmt=1) 'Ok' - !ERROR: Internal file variable 'const_internal_file' must be definable + !ERROR: Internal file variable 'const_internal_file' is not definable + !BECAUSE: '"(I6)"' is not a variable or pointer write(const_internal_file, fmt=*) !ERROR: If UNIT=* appears, POS must not appear @@ -127,7 +128,8 @@ !ERROR: ID kind (1) is smaller than default INTEGER kind (4) write(id=id1, unit=10, asynchronous='Yes') 'Ok' - !ERROR: ID variable 'const_id' must be definable + !ERROR: ID variable 'const_id' is not definable + !BECAUSE: '66666_4' is not a variable or pointer write(10, *, asynchronous='yes', id=const_id, iostat=stat2) 'Ok' write(*, '(X)') Index: flang/test/Semantics/io05.f90 =================================================================== --- flang/test/Semantics/io05.f90 +++ flang/test/Semantics/io05.f90 @@ -60,7 +60,8 @@ !ERROR: If ID appears, PENDING must also appear inquire(file='abc', id=id) - !ERROR: ROUND variable 'const_round' must be definable + !ERROR: ROUND variable 'const_round' is not definable + !BECAUSE: '"c"' is not a variable or pointer inquire(file='abc', round=const_round) 9 continue Index: flang/test/Semantics/io06.f90 =================================================================== --- flang/test/Semantics/io06.f90 +++ flang/test/Semantics/io06.f90 @@ -29,7 +29,8 @@ !ERROR: Duplicate IOSTAT specifier endfile(iostat=stat2, err=9, unit=10, iostat=stat8, iomsg=msg1) - !ERROR: IOMSG variable 'const_msg' must be definable + !ERROR: IOMSG variable 'const_msg' is not definable + !BECAUSE: '"d"' is not a variable or pointer flush(iomsg=const_msg, unit=10, iostat=stat8, err=9) !ERROR: REWIND statement must have a UNIT number specifier Index: flang/test/Semantics/modifiable01.f90 =================================================================== --- flang/test/Semantics/modifiable01.f90 +++ flang/test/Semantics/modifiable01.f90 @@ -33,38 +33,38 @@ type(ptype), intent(in) :: dummy type(t2) :: t2var associate (a => 3+4) - !CHECK: error: Input variable 'a' must be definable - !CHECK: 'a' is construct associated with an expression + !CHECK: error: Input variable 'a' is not definable + !CHECK: because: 'a' is construct associated with an expression read(internal,*) a end associate associate (a => arr([1])) ! vector subscript - !CHECK: error: Input variable 'a' must be definable - !CHECK: Construct association has a vector subscript + !CHECK: error: Input variable 'a' is not definable + !CHECK: because: Construct association 'a' has a vector subscript read(internal,*) a end associate associate (a => arr(2:1:-1)) read(internal,*) a ! ok end associate - !CHECK: error: Input variable 'j3' must be definable - !CHECK: '666_4' is not a variable + !CHECK: error: Input variable 'j3' is not definable + !CHECK: because: '666_4' is not a variable read(internal,*) j3 - !CHECK: error: Left-hand side of assignment is not modifiable - !CHECK: 't2var' is an entity with either an EVENT_TYPE or LOCK_TYPE + !CHECK: error: Left-hand side of assignment is not definable + !CHECK: because: 't2var' is an entity with either an EVENT_TYPE or LOCK_TYPE t2var = t2static t2var%x2 = 0. ! ok - !CHECK: error: Left-hand side of assignment is not modifiable - !CHECK: 'prot' is protected in this scope + !CHECK: error: Left-hand side of assignment is not definable + !CHECK: because: 'prot' is protected in this scope prot = 0. protptr%ptr = 0. ! ok - !CHECK: error: Left-hand side of assignment is not modifiable - !CHECK: 'dummy' is an INTENT(IN) dummy argument + !CHECK: error: Left-hand side of assignment is not definable + !CHECK: because: 'dummy' is an INTENT(IN) dummy argument dummy%x = 0. dummy%ptr = 0. ! ok end subroutine pure subroutine test2(ptr) integer, pointer, intent(in) :: ptr - !CHECK: error: Input variable 'ptr' must be definable - !CHECK: 'ptr' is externally visible and referenced in a pure procedure + !CHECK: error: Input variable 'ptr' is not definable + !CHECK: because: 'ptr' is externally visible via 'ptr' and not definable in a pure subprogram read(internal,*) ptr end subroutine end module Index: flang/test/Semantics/nullify02.f90 =================================================================== --- flang/test/Semantics/nullify02.f90 +++ flang/test/Semantics/nullify02.f90 @@ -16,16 +16,20 @@ Procedure(Real) :: prp Allocate(x(3)) -!ERROR: component in NULLIFY statement must have the POINTER attribute +!ERROR: 'p' may not appear in NULLIFY +!BECAUSE: 'p' is not a pointer Nullify(x(2)%p) -!ERROR: name in NULLIFY statement must have the POINTER attribute +!ERROR: 'pi' may not appear in NULLIFY +!BECAUSE: 'pi' is not a pointer Nullify(pi) -!ERROR: name in NULLIFY statement must be a variable or procedure pointer +!ERROR: 'prp' may not appear in NULLIFY +!BECAUSE: 'prp' is not a pointer Nullify(prp) -!ERROR: name in NULLIFY statement must be a variable or procedure pointer +!ERROR: 'maxvalue' may not appear in NULLIFY +!BECAUSE: 'maxvalue' is not a pointer Nullify(maxvalue) End Program @@ -45,7 +49,8 @@ integer, pointer :: ptrFun real :: realVar nullify(ptrFun) - !ERROR: name in NULLIFY statement must have the POINTER attribute + !ERROR: 'realvar' may not appear in NULLIFY + !BECAUSE: 'realvar' is not a pointer nullify(realVar) end function end module Index: flang/test/Semantics/random-seed.f90 =================================================================== --- flang/test/Semantics/random-seed.f90 +++ flang/test/Semantics/random-seed.f90 @@ -10,7 +10,8 @@ call random_seed() call random_seed(size_arg) call random_seed(size=size_arg) - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'size=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'size=' is not definable + !BECAUSE: '343_4' is not a variable or pointer call random_seed(size_arg_const) ! error, size arg must be definable !ERROR: 'size=' argument has unacceptable rank 1 call random_seed([1, 2, 3, 4]) ! Error, must be a scalar @@ -21,7 +22,8 @@ call random_seed(get=get_arg) !ERROR: 'get=' argument has unacceptable rank 0 call random_seed(get=get_arg_scalar) ! Error, GET arg must be of rank 1 - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'get=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'get=' is not definable + !BECAUSE: '[INTEGER(4)::8_4,7_4,6_4]' is not a variable or pointer call random_seed(get=get_arg_const) ! Error, GET arg must be definable !ERROR: RANDOM_SEED must have either 1 or no arguments call random_seed(size_arg, get_arg) ! Error, only 0 or 1 argument Index: flang/test/Semantics/resolve35.f90 =================================================================== --- flang/test/Semantics/resolve35.f90 +++ flang/test/Semantics/resolve35.f90 @@ -111,12 +111,16 @@ x = cos(0.) do concurrent(i=1:2) & !ERROR: 'bad1' may not appear in a locality-spec because it is not definable + !BECAUSE: 'bad1' is not a variable local(bad1) & !ERROR: 'bad2' may not appear in a locality-spec because it is not definable + !BECAUSE: 'bad2' is not a variable local(bad2) & !ERROR: 'bad3' may not appear in a locality-spec because it is not definable + !BECAUSE: 'bad3' is not a variable local(bad3) & !ERROR: 'cos' may not appear in a locality-spec because it is not definable + !BECAUSE: 'cos' is not a variable local(cos) end do do concurrent(i=1:2) & Index: flang/test/Semantics/resolve57.f90 =================================================================== --- flang/test/Semantics/resolve57.f90 +++ flang/test/Semantics/resolve57.f90 @@ -40,6 +40,7 @@ ! C857 This is not OK because of the "protected" attribute !ERROR: 'prot' may not appear in a locality-spec because it is not definable +!BECAUSE: 'prot' is protected in this scope do concurrent (i=1:5) local(prot) end do @@ -59,6 +60,7 @@ ! C1101 This is not OK because 'a' is not associated with a variable !ERROR: 'a' may not appear in a locality-spec because it is not definable +!BECAUSE: 'a' is construct associated with an expression do concurrent (i=1:5) local(a) end do end associate @@ -95,6 +97,7 @@ type is ( point ) ! C1158 This is not OK because 'a' is not associated with a variable !ERROR: 'a' may not appear in a locality-spec because it is not definable +!BECAUSE: 'a' is construct associated with an expression do concurrent (i=1:5) local(a) end do end select @@ -116,6 +119,7 @@ ! C1594 This is not OK because we're in a PURE subroutine !ERROR: 'var' may not appear in a locality-spec because it is not definable +!BECAUSE: 'var' may not be defined in pure subprogram 's7' because it is USE-associated do concurrent (i=1:5) local(var) end do end subroutine s7 @@ -124,6 +128,7 @@ integer, parameter :: iconst = 343 !ERROR: 'iconst' may not appear in a locality-spec because it is not definable +!BECAUSE: 'iconst' is not a variable do concurrent (i=1:5) local(iconst) end do end subroutine s8 Index: flang/test/Semantics/resolve62.f90 =================================================================== --- flang/test/Semantics/resolve62.f90 +++ flang/test/Semantics/resolve62.f90 @@ -69,11 +69,13 @@ end subroutine s4b use m4 - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: 'x' is protected in this scope call s(x) end pure subroutine s4c use m4 - !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' must be definable + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable + !BECAUSE: 'y' may not be defined in pure subprogram 's4c' because it is USE-associated call s(y) end Index: flang/test/Semantics/resolve76.f90 =================================================================== --- flang/test/Semantics/resolve76.f90 +++ flang/test/Semantics/resolve76.f90 @@ -16,7 +16,8 @@ submodule(m1) sm1 contains module procedure sub1 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'a' is an INTENT(IN) dummy argument a = 1.0 b = 2.0 !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types REAL(4) and LOGICAL(4) Index: flang/test/Semantics/selecttype03.f90 =================================================================== --- flang/test/Semantics/selecttype03.f90 +++ flang/test/Semantics/selecttype03.f90 @@ -37,10 +37,12 @@ select type ( y => (fun(1)) ) type is (t1) - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'y' is construct associated with an expression y%i = 1 !VDC type is (t2) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable + !BECAUSE: 'y' is construct associated with an expression call sub_with_in_and_inout_param(y,y) !VDC end select @@ -58,18 +60,22 @@ !C)Associate with with vector subscript select type (b => array1(V,2)) type is (t1) - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: Construct association 'b' has a vector subscript b%i = 1 !VDC type is (t2) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable + !BECAUSE: Variable 'b' has a vector subscript call sub_with_in_and_inout_param_vector(b,b) !VDC end select select type(b => foo(1) ) type is (t1) - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: 'b' is construct associated with an expression b%i = 1 !VDC type is (t2) - !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' is not definable + !BECAUSE: 'b' is construct associated with an expression call sub_with_in_and_inout_param_vector(b,b) !VDC end select