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 @@ -806,7 +806,7 @@ // Procedure and pointer detection predicates bool IsProcedure(const Expr &); bool IsFunction(const Expr &); -bool IsProcedurePointer(const Expr &); +bool IsProcedurePointerTarget(const Expr &); bool IsNullPointer(const Expr &); bool IsObjectPointer(const Expr &, FoldingContext &); @@ -963,6 +963,7 @@ int CountLenParameters(const DerivedTypeSpec &); int CountNonConstantLenParameters(const DerivedTypeSpec &); const Symbol &GetUsedModule(const UseDetails &); +const Symbol *FindFunctionResult(const Symbol &); } // namespace Fortran::semantics diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1255,7 +1255,7 @@ } } else { // NULL(), procedure, or procedure pointer - CHECK(IsProcedurePointer(expr)); + CHECK(IsProcedurePointerTarget(expr)); if (d.typePattern.kindCode == KindCode::addressable || d.rank == Rank::reduceOperation) { continue; @@ -1851,7 +1851,7 @@ if (IsAllocatableOrPointer(*mold)) { characteristics::DummyArguments args; std::optional fResult; - if (IsProcedurePointer(*mold)) { + if (IsProcedurePointerTarget(*mold)) { // MOLD= procedure pointer const Symbol *last{GetLastSymbol(*mold)}; CHECK(last); 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 @@ -52,10 +52,12 @@ // IsVariable() auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result { - return !symbol.attrs().test(semantics::Attr::PARAMETER); + const Symbol &root{GetAssociationRoot(symbol)}; + return !IsNamedConstant(root) && root.has(); } auto IsVariableHelper::operator()(const Component &x) const -> Result { - return (*this)(x.base()); + const Symbol &comp{x.GetLastSymbol()}; + return (*this)(comp) && (IsPointer(comp) || (*this)(x.base())); } auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result { return (*this)(x.base()); @@ -65,8 +67,11 @@ } auto IsVariableHelper::operator()(const ProcedureDesignator &x) const -> Result { - const Symbol *symbol{x.GetSymbol()}; - return symbol && IsPointer(*symbol); + if (const Symbol * symbol{x.GetSymbol()}) { + const Symbol *result{FindFunctionResult(*symbol)}; + return result && IsPointer(*result) && !IsProcedurePointer(*result); + } + return false; } // Conversions of COMPLEX component expressions to REAL. @@ -686,12 +691,15 @@ return designator && designator->GetType().has_value(); } -bool IsProcedurePointer(const Expr &expr) { +bool IsProcedurePointerTarget(const Expr &expr) { return std::visit(common::visitors{ [](const NullPointer &) { return true; }, [](const ProcedureDesignator &) { return true; }, [](const ProcedureRef &) { return true; }, - [](const auto &) { return false; }, + [&](const auto &) { + const Symbol *last{GetLastSymbol(expr)}; + return last && IsProcedurePointer(*last); + }, }, expr.u); } @@ -715,14 +723,10 @@ bool IsObjectPointer(const Expr &expr, FoldingContext &context) { if (IsNullPointer(expr)) { return true; - } else if (IsProcedurePointer(expr)) { + } else if (IsProcedurePointerTarget(expr)) { return false; - } else if (const auto *procRef{UnwrapProcedureRef(expr)}) { - auto proc{ - characteristics::Procedure::Characterize(procRef->proc(), context)}; - return proc && proc->functionResult && - proc->functionResult->attrs.test( - characteristics::FunctionResult::Attr::Pointer); + } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) { + return IsVariable(*funcRef); } else if (const Symbol * symbol{GetLastSymbol(expr)}) { return IsPointer(symbol->GetUltimate()); } else { @@ -1089,7 +1093,7 @@ } bool IsProcedurePointer(const Symbol &original) { - const Symbol &symbol{original.GetUltimate()}; + const Symbol &symbol{GetAssociationRoot(original)}; return symbol.has() && IsPointer(symbol); } @@ -1172,4 +1176,31 @@ return DEREF(details.symbol().owner().symbol()); } +static const Symbol *FindFunctionResult( + const Symbol &original, SymbolSet &seen) { + const Symbol &root{GetAssociationRoot(original)}; + ; + if (!seen.insert(root).second) { + return nullptr; // don't loop + } + return std::visit( + common::visitors{[](const SubprogramDetails &subp) { + return subp.isFunction() ? &subp.result() : nullptr; + }, + [&](const ProcEntityDetails &proc) { + const Symbol *iface{proc.interface().symbol()}; + return iface ? FindFunctionResult(*iface, seen) : nullptr; + }, + [&](const ProcBindingDetails &binding) { + return FindFunctionResult(binding.symbol(), seen); + }, + [](const auto &) -> const Symbol * { return nullptr; }}, + root.details()); +} + +const Symbol *FindFunctionResult(const Symbol &symbol) { + SymbolSet seen; + return FindFunctionResult(symbol, seen); +} + } // namespace Fortran::semantics diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -578,27 +578,27 @@ "Actual argument associated with procedure %s is not a procedure"_err_en_US, dummyName); } - } else if (!(dummyIsPointer && IsNullPointer(*expr))) { + } else if (IsNullPointer(*expr)) { + if (!dummyIsPointer) { + messages.Say( + "Actual argument associated with procedure %s is a null pointer"_err_en_US, + dummyName); + } + } else { messages.Say( - "Actual argument associated with procedure %s is not a procedure"_err_en_US, + "Actual argument associated with procedure %s is typeless"_err_en_US, dummyName); } } - if (interface.HasExplicitInterface()) { - if (dummyIsPointer) { + if (interface.HasExplicitInterface() && dummyIsPointer && + proc.intent != common::Intent::In) { + const Symbol *last{GetLastSymbol(*expr)}; + if (!(last && IsProcedurePointer(*last))) { // 15.5.2.9(5) -- dummy procedure POINTER // Interface compatibility has already been checked above by comparison. - if (proc.intent != common::Intent::In && !IsVariable(*expr)) { - messages.Say( - "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US, - dummyName); - } - } else { // 15.5.2.9(4) -- dummy procedure is not POINTER - if (!argProcDesignator) { - messages.Say( - "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US, - dummyName); - } + messages.Say( + "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US, + dummyName); } } } else { 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 @@ -550,7 +550,8 @@ flags_.set(Flag::DataList); if (const auto *x{std::get_if(&item.u)}) { if (const auto *expr{GetExpr(*x)}) { - if (IsProcedurePointer(*expr)) { + const Symbol *last{GetLastSymbol(*expr)}; + if (last && IsProcedurePointer(*last)) { context_.Say(parser::FindSourceLocation(*x), "Output item must not be a procedure pointer"_err_en_US); // C1233 } @@ -925,15 +926,18 @@ template void IoChecker::CheckForDefinableVariable( - const A &var, const std::string &s) const { - const Symbol *sym{ - GetFirstName(*parser::Unwrap(var)).symbol}; - 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()); + const A &variable, const std::string &s) const { + 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))}) { + const Symbol *base{GetFirstSymbol(*expr)}; + context_ + .Say(at, "%s variable '%s' must be definable"_err_en_US, s, + (base ? base->name() : at).ToString()) + .Attach(std::move(*whyNot)); + } + } } } diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1859,7 +1859,7 @@ }, [&](const characteristics::DummyProcedure &) { const auto *expr{actual.UnwrapExpr()}; - return expr && IsProcedurePointer(*expr); + return expr && IsProcedurePointerTarget(*expr); }, [&](const characteristics::AlternateReturn &) { return actual.isAlternateReturn(); 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 @@ -841,9 +841,7 @@ // Modifiability checks for a data-ref std::optional WhyNotModifiable(parser::CharBlock at, const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) { - if (!evaluate::IsVariable(expr)) { - return parser::Message{at, "Expression is not a variable"_en_US}; - } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) { + if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) { if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) { return parser::Message{at, "Variable has a vector subscript"_en_US}; } @@ -865,6 +863,9 @@ std::move(*maybeWhyFirst), first.name()}}; } } + } else if (!evaluate::IsVariable(expr)) { + return parser::Message{ + at, "'%s' is not a variable"_en_US, expr.AsFortran()}; } else { // reference to function returning POINTER } diff --git a/flang/test/Semantics/call02.f90 b/flang/test/Semantics/call02.f90 --- a/flang/test/Semantics/call02.f90 +++ b/flang/test/Semantics/call02.f90 @@ -19,11 +19,9 @@ call subr(cos) ! not an error !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument call subr(elem) ! C1533 - !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure - !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer) + !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is a null pointer call subr(null()) - !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure - !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer) + !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is typeless call subr(B"1010") end subroutine diff --git a/flang/test/Semantics/call09.f90 b/flang/test/Semantics/call09.f90 --- a/flang/test/Semantics/call09.f90 +++ b/flang/test/Semantics/call09.f90 @@ -76,7 +76,7 @@ call s01(sin) ! ok !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure call s01(null(intPtr)) - !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure + !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless call s01(B"0101") !ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface call s01(extfunc) diff --git a/flang/test/Semantics/call18.f90 b/flang/test/Semantics/call18.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/call18.f90 @@ -0,0 +1,26 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! Ensure that references to functions that return pointers can serve as +! "variables" in actual arguments. All of these uses are conforming and +! no errors should be reported. +module m + integer, target :: x = 1 + contains + function get() result(p) + integer, pointer :: p + p => x + end function get + subroutine increment(n) + integer, intent(inout) :: n + n = n + 1 + end subroutine increment +end module m + +use m +integer, pointer :: q +get() = 2 +call increment(get()) +q => get() +read(*) get() +open(file='file',newunit=get()) +allocate(q,stat=get()) +end diff --git a/flang/test/Semantics/modifiable01.f90 b/flang/test/Semantics/modifiable01.f90 --- a/flang/test/Semantics/modifiable01.f90 +++ b/flang/test/Semantics/modifiable01.f90 @@ -46,7 +46,7 @@ read(internal,*) a ! ok end associate !CHECK: error: Input variable 'j3' must be definable - !CHECK: 'j3' is not a variable + !CHECK: '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