diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -336,6 +336,9 @@ } } +// GetLastPointerSymbol(A%PTR1%B%PTR2%C) -> PTR2 +const Symbol *GetLastPointerSymbol(const evaluate::DataRef &); + // Creation of conversion expressions can be done to either a known // specific intrinsic type with ConvertToType(x) or by converting // one arbitrary expression to the type of another with ConvertTo(to, from). diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -896,6 +896,31 @@ return msg; } +// GetLastPointerSymbol() +static const Symbol *GetLastPointerSymbol(const Symbol &symbol) { + return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr; +} +static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) { + return GetLastPointerSymbol(*symbol); +} +static const Symbol *GetLastPointerSymbol(const Component &x) { + const Symbol &c{x.GetLastSymbol()}; + return IsPointer(c) ? &c : GetLastPointerSymbol(x.base()); +} +static const Symbol *GetLastPointerSymbol(const NamedEntity &x) { + const auto *c{x.UnwrapComponent()}; + return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol()); +} +static const Symbol *GetLastPointerSymbol(const ArrayRef &x) { + return GetLastPointerSymbol(x.base()); +} +static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) { + return nullptr; +} +const Symbol *GetLastPointerSymbol(const DataRef &x) { + return std::visit([](const auto &y) { return GetLastPointerSymbol(y); }, x.u); +} + } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp --- a/flang/lib/Semantics/check-io.cpp +++ b/flang/lib/Semantics/check-io.cpp @@ -928,9 +928,12 @@ const A &var, const std::string &s) const { const Symbol *sym{ GetFirstName(*parser::Unwrap(var)).symbol}; - if (WhyNotModifiable(*sym, context_.FindScope(*context_.location()))) { - context_.Say(parser::FindSourceLocation(var), - "%s variable '%s' must be definable"_err_en_US, s, sym->name()); + if (auto whyNot{ + WhyNotModifiable(*sym, context_.FindScope(*context_.location()))}) { + auto at{parser::FindSourceLocation(var)}; + context_ + .Say(at, "%s variable '%s' must be definable"_err_en_US, s, sym->name()) + .Attach(at, std::move(*whyNot), sym->name()); } } diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -776,27 +776,62 @@ } // C1101 and C1158 -std::optional WhyNotModifiable( - const Symbol &original, const Scope &scope) { - const Symbol &symbol{GetAssociationRoot(original)}; +// Modifiability checks on the leftmost symbol ("base object") +// of a data-ref +std::optional WhyNotModifiableFirst( + const Symbol &symbol, const Scope &scope) { if (symbol.has()) { return "'%s' is construct associated with an expression"_en_US; - } else if (InProtectedContext(symbol, scope)) { - return "'%s' is protected in this scope"_en_US; } else if (IsExternalInPureContext(symbol, scope)) { return "'%s' is externally visible and referenced in a pure" " procedure"_en_US; - } else if (IsOrContainsEventOrLockComponent(symbol)) { + } else if (!IsVariableName(symbol)) { + return "'%s' is not a variable"_en_US; + } else { + return std::nullopt; + } +} + +// Modifiability checks on the rightmost symbol of a data-ref +std::optional WhyNotModifiableLast( + const Symbol &symbol, const Scope &scope) { + if (IsOrContainsEventOrLockComponent(symbol)) { return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US; + } 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. +std::optional WhyNotModifiableIfNoPtr( + const Symbol &symbol, const Scope &scope) { + if (InProtectedContext(symbol, scope)) { + return "'%s' is protected in this scope"_en_US; } else if (IsIntentIn(symbol)) { return "'%s' is an INTENT(IN) dummy argument"_en_US; - } else if (!IsVariableName(symbol)) { - return "'%s' is not a variable"_en_US; } 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, scope)}) { + return first; + } else if (auto last{WhyNotModifiableLast(symbol, scope)}) { + return last; + } else if (!IsPointer(symbol)) { + return WhyNotModifiableIfNoPtr(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 (!evaluate::IsVariable(expr)) { @@ -805,10 +840,23 @@ if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) { return parser::Message{at, "Variable has a vector subscript"_en_US}; } - const Symbol &symbol{dataRef->GetFirstSymbol()}; - if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) { - return parser::Message{symbol.name(), - parser::MessageFormattedText{std::move(*maybeWhy), symbol.name()}}; + const Symbol &first{GetAssociationRoot(dataRef->GetFirstSymbol())}; + if (auto maybeWhyFirst{WhyNotModifiableFirst(first, scope)}) { + return parser::Message{first.name(), + parser::MessageFormattedText{ + std::move(*maybeWhyFirst), first.name()}}; + } + const Symbol &last{dataRef->GetLastSymbol()}; + if (auto maybeWhyLast{WhyNotModifiableLast(last, scope)}) { + return parser::Message{last.name(), + parser::MessageFormattedText{std::move(*maybeWhyLast), last.name()}}; + } + if (!GetLastPointerSymbol(*dataRef)) { + if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(first, scope)}) { + return parser::Message{first.name(), + parser::MessageFormattedText{ + std::move(*maybeWhyFirst), first.name()}}; + } } } else { // reference to function returning POINTER diff --git a/flang/test/Semantics/modifiable01.f90 b/flang/test/Semantics/modifiable01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/modifiable01.f90 @@ -0,0 +1,70 @@ +! RUN: not %f18 -fparse-only %s 2>&1 | FileCheck %s +! Test WhyNotModifiable() explanations + +module prot + real, protected :: prot + type :: ptype + real, pointer :: ptr + real :: x + end type + type(ptype), protected :: protptr + contains + subroutine ok + prot = 0. ! ok + end subroutine +end module + +module m + use iso_fortran_env + use prot + type :: t1 + type(lock_type) :: lock + end type + type :: t2 + type(t1) :: x1 + real :: x2 + end type + type(t2) :: t2static + character(*), parameter :: internal = '0' + contains + subroutine test1(dummy) + real :: arr(2) + integer, parameter :: j3 = 666 + 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 + read(internal,*) a + end associate + associate (a => arr([1])) ! vector subscript + !CHECK: error: Input variable 'a' must be definable + !CHECK: 'a' is construct associated with an expression + 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: 'j3' 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 + t2var = t2static + t2var%x2 = 0. ! ok + !CHECK: error: Left-hand side of assignment is not modifiable + !CHECK: '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 + 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 + read(internal,*) ptr + end subroutine +end module