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 @@ -892,6 +892,7 @@ bool IsProcedure(const Expr &); bool IsFunction(const Expr &); bool IsProcedurePointerTarget(const Expr &); +bool IsBareNullPointer(const Expr *); // NULL() w/o MOLD= bool IsNullPointer(const Expr &); bool IsObjectPointer(const Expr &, FoldingContext &); diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -340,9 +340,10 @@ using AdjustActuals = std::optional>; bool ResolveForward(const Symbol &); - const Symbol *ResolveGeneric(const Symbol &, const ActualArguments &, - const AdjustActuals &, bool mightBeStructureConstructor = false); - void EmitGenericResolutionError(const Symbol &); + std::pair + ResolveGeneric(const Symbol &, const ActualArguments &, const AdjustActuals &, + bool mightBeStructureConstructor = false); + void EmitGenericResolutionError(const Symbol &, bool dueToNullActuals); const Symbol &AccessSpecific( const Symbol &originalGeneric, const Symbol &specific); std::optional GetCalleeAndArguments(const parser::Name &, 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 @@ -756,6 +756,10 @@ } } +bool IsBareNullPointer(const Expr *expr) { + return expr && std::holds_alternative(expr->u); +} + // IsNullPointer() struct IsNullPointerHelper { template bool operator()(const A &) const { return false; } diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -2316,14 +2316,11 @@ parser::Message *msg; if (scope.sourceRange().Contains(name)) { msg = &context_.Say(name, - "Generic '%s' may not have specific procedures '%s' and" - " '%s' as their interfaces are not distinguishable"_err_en_US, + "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US, MakeOpName(name), name1, name2); } else { msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(), - "USE-associated generic '%s' may not have specific procedures '%s' " - "and" - " '%s' as their interfaces are not distinguishable"_err_en_US, + "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US, MakeOpName(name), name1, name2); } AttachDeclaration(*msg, scope, proc1); 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 @@ -130,7 +130,7 @@ bool IsIntrinsicConcat() const; bool CheckConformance(); - bool CheckForNullPointer(const char *where = "as an operand"); + bool CheckForNullPointer(const char *where = "as an operand here"); // Find and return a user-defined operator or report an error. // The provided message is used if there is no such operator. @@ -165,7 +165,6 @@ void SayNoMatch(const std::string &, bool isAssignment = false); std::string TypeAsFortran(std::size_t); bool AnyUntypedOrMissingOperand(); - bool CheckForUntypedNullPointer(); ExpressionAnalyzer &context_; ActualArguments actuals_; @@ -1727,8 +1726,7 @@ symbol->name()), *symbol); } - } else if (IsAllocatable(*symbol) && - std::holds_alternative(value->u)) { + } else if (IsAllocatable(*symbol) && IsBareNullPointer(&*value)) { // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE } else if (auto symType{DynamicType::From(symbol)}) { if (valueType) { @@ -1877,9 +1875,10 @@ } return true; }}; - sym = ResolveGeneric(*sym, arguments, adjustment); + auto pair{ResolveGeneric(*sym, arguments, adjustment)}; + sym = pair.first; if (!sym) { - EmitGenericResolutionError(*sc.component.symbol); + EmitGenericResolutionError(*sc.component.symbol, pair.second); return std::nullopt; } } @@ -1914,21 +1913,25 @@ // Can actual be argument associated with dummy? static bool CheckCompatibleArgument(bool isElemental, const ActualArgument &actual, const characteristics::DummyArgument &dummy) { + const auto *expr{actual.UnwrapExpr()}; return std::visit( common::visitors{ [&](const characteristics::DummyDataObject &x) { - if (!isElemental && actual.Rank() != x.type.Rank() && + if (x.attrs.test(characteristics::DummyDataObject::Attr::Pointer) && + IsBareNullPointer(expr)) { + // NULL() without MOLD= is compatible with any dummy data pointer + // but cannot be allowed to lead to ambiguity. + return true; + } else if (!isElemental && actual.Rank() != x.type.Rank() && !x.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedRank)) { return false; } else if (auto actualType{actual.GetType()}) { return x.type.type().IsTkCompatibleWith(*actualType); - } else { - return false; } + return false; }, [&](const characteristics::DummyProcedure &) { - const auto *expr{actual.UnwrapExpr()}; return expr && IsProcedurePointerTarget(*expr); }, [&](const characteristics::AlternateReturn &) { @@ -1992,11 +1995,16 @@ // Resolve a call to a generic procedure with given actual arguments. // adjustActuals is called on procedure bindings to handle pass arg. -const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol, - const ActualArguments &actuals, const AdjustActuals &adjustActuals, - bool mightBeStructureConstructor) { +std::pair ExpressionAnalyzer::ResolveGeneric( + const Symbol &symbol, const ActualArguments &actuals, + const AdjustActuals &adjustActuals, bool mightBeStructureConstructor) { const Symbol *elemental{nullptr}; // matching elemental specific proc + const Symbol *nonElemental{nullptr}; // matching non-elemental specific const auto &details{symbol.GetUltimate().get()}; + bool anyBareNullActual{ + std::find_if(actuals.begin(), actuals.end(), [](auto iter) { + return IsBareNullPointer(iter->UnwrapExpr()); + }) != actuals.end()}; for (const Symbol &specific : details.specificProcs()) { if (!ResolveForward(specific)) { continue; @@ -2011,35 +2019,47 @@ } } if (semantics::CheckInterfaceForGeneric( - *procedure, localActuals, GetFoldingContext())) { - if (CheckCompatibleArguments(*procedure, localActuals)) { - if (!procedure->IsElemental()) { - // takes priority over elemental match - return &AccessSpecific(symbol, specific); + *procedure, localActuals, GetFoldingContext()) && + CheckCompatibleArguments(*procedure, localActuals)) { + if ((procedure->IsElemental() && elemental) || + (!procedure->IsElemental() && nonElemental)) { + // 16.9.144(6): a bare NULL() is not allowed as an actual + // argument to a generic procedure if the specific procedure + // cannot be unambiguously distinguished + return {nullptr, true /* due to NULL actuals */}; + } + if (!procedure->IsElemental()) { + // takes priority over elemental match + nonElemental = &specific; + if (!anyBareNullActual) { + break; // unambiguous case } + } else { elemental = &specific; } } } } - if (elemental) { - return &AccessSpecific(symbol, *elemental); + if (nonElemental) { + return {&AccessSpecific(symbol, *nonElemental), false}; + } else if (elemental) { + return {&AccessSpecific(symbol, *elemental), false}; } // Check parent derived type if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) { if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) { if (extended->GetUltimate().has()) { - if (const Symbol * - result{ResolveGeneric(*extended, actuals, adjustActuals, false)}) { - return result; + auto pair{ResolveGeneric(*extended, actuals, adjustActuals, false)}; + if (pair.first) { + return pair; } } } } if (mightBeStructureConstructor && details.derivedType()) { - return details.derivedType(); + return {details.derivedType(), false}; } - return nullptr; + return {nullptr, false}; } const Symbol &ExpressionAnalyzer::AccessSpecific( @@ -2075,14 +2095,14 @@ } } -void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol) { - if (semantics::IsGenericDefinedOp(symbol)) { - Say("No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US, - symbol.name()); - } else { - Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US, - symbol.name()); - } +void ExpressionAnalyzer::EmitGenericResolutionError( + const Symbol &symbol, bool dueToNullActuals) { + Say(dueToNullActuals + ? "One or more NULL() actual arguments to the generic procedure '%s' requires a MOLD= for disambiguation"_err_en_US + : semantics::IsGenericDefinedOp(symbol) + ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US + : "No specific procedure of generic '%s' matches the actual arguments"_err_en_US, + symbol.name()); } auto ExpressionAnalyzer::GetCalleeAndArguments( @@ -2121,10 +2141,13 @@ } } else { CheckForBadRecursion(name.source, ultimate); + bool dueToNullActual{false}; if (ultimate.has()) { ExpressionAnalyzer::AdjustActuals noAdjustment; - symbol = ResolveGeneric( - *symbol, arguments, noAdjustment, mightBeStructureConstructor); + auto pair{ResolveGeneric( + *symbol, arguments, noAdjustment, mightBeStructureConstructor)}; + symbol = pair.first; + dueToNullActual = pair.second; } if (symbol) { if (symbol->GetUltimate().has()) { @@ -2152,7 +2175,7 @@ ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, std::move(specificCall->arguments)}; } else { - EmitGenericResolutionError(*name.symbol); + EmitGenericResolutionError(*name.symbol, dueToNullActual); } } return std::nullopt; @@ -3249,9 +3272,6 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr, parser::MessageFixedText error, const Symbol **definedOpSymbolPtr, bool isUserOp) { - if (!CheckForUntypedNullPointer()) { - return std::nullopt; - } if (AnyUntypedOrMissingOperand()) { context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1)); return std::nullopt; @@ -3386,11 +3406,11 @@ const auto &scope{context_.context().FindScope(source_)}; if (const Symbol * symbol{scope.FindSymbol(oprName)}) { ExpressionAnalyzer::AdjustActuals noAdjustment; - if (const Symbol * - specific{context_.ResolveGeneric(*symbol, actuals_, noAdjustment)}) { - proc = specific; + auto pair{context_.ResolveGeneric(*symbol, actuals_, noAdjustment)}; + if (pair.first) { + proc = pair.first; } else { - context_.EmitGenericResolutionError(*symbol); + context_.EmitGenericResolutionError(*symbol, pair.second); } } int passedObjectIndex{-1}; @@ -3490,11 +3510,11 @@ [&](const Symbol &proc, ActualArguments &) { return passIndex == GetPassIndex(proc); }}; - const Symbol *result{context_.ResolveGeneric(*symbol, actuals_, adjustment)}; - if (!result) { - context_.EmitGenericResolutionError(*symbol); + auto pair{context_.ResolveGeneric(*symbol, actuals_, adjustment)}; + if (!pair.first) { + context_.EmitGenericResolutionError(*symbol, pair.second); } - return result; + return pair.first; } // If there is an implicit conversion between intrinsic types, make it explicit @@ -3597,29 +3617,13 @@ bool ArgumentAnalyzer::AnyUntypedOrMissingOperand() { for (const auto &actual : actuals_) { - if (!actual || !actual->GetType()) { + if (!actual || + (!actual->GetType() && !IsBareNullPointer(actual->UnwrapExpr()))) { return true; } } return false; } - -bool ArgumentAnalyzer::CheckForUntypedNullPointer() { - for (const std::optional &arg : actuals_) { - if (arg) { - if (const Expr *expr{arg->UnwrapExpr()}) { - if (std::holds_alternative(expr->u)) { - context_.Say(source_, - "A typeless NULL() pointer is not allowed as an operand"_err_en_US); - fatalErrors_ = true; - return false; - } - } - } - } - return true; -} - } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/test/Semantics/resolve63.f90 b/flang/test/Semantics/resolve63.f90 --- a/flang/test/Semantics/resolve63.f90 +++ b/flang/test/Semantics/resolve63.f90 @@ -172,17 +172,17 @@ y = -z'1' !ERROR: Operands of + must be numeric; have LOGICAL(4) and untyped y = x + z'1' - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: A NULL() pointer is not allowed as an operand here l = x /= null() !ERROR: A NULL() pointer is not allowed as a relational operand l = null(px) /= null(px) - !ERROR: A NULL() pointer is not allowed as an operand + !ERROR: A NULL() pointer is not allowed as an operand here l = x /= null(px) - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: A NULL() pointer is not allowed as an operand here l = px /= null() !ERROR: A NULL() pointer is not allowed as a relational operand l = px /= null(px) - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: A NULL() pointer is not allowed as an operand here l = null() /= null() end end @@ -304,17 +304,43 @@ j = null(mold=x1) - x1 j = x1 / x1 j = x1 / null(mold=x1) - !ERROR: A typeless NULL() pointer is not allowed as an operand j = null() - null(mold=x1) - !ERROR: A typeless NULL() pointer is not allowed as an operand j = null(mold=x1) - null() - !ERROR: A typeless NULL() pointer is not allowed as an operand j = null() - null() - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: No intrinsic or user-defined OPERATOR(/) matches operand types untyped and TYPE(t1) j = null() / null(mold=x1) - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: No intrinsic or user-defined OPERATOR(/) matches operand types TYPE(t1) and untyped j = null(mold=x1) / null() - !ERROR: A typeless NULL() pointer is not allowed as an operand + !ERROR: A NULL() pointer is not allowed as an operand here j = null() / null() end end + +! 16.9.144(6) +module m8 + interface generic + procedure s1, s2 + end interface + contains + subroutine s1(ip1, rp1) + integer, pointer, intent(in) :: ip1 + real, pointer, intent(in) :: rp1 + end subroutine + subroutine s2(rp2, ip2) + real, pointer, intent(in) :: rp2 + integer, pointer, intent(in) :: ip2 + end subroutine + subroutine test + integer, pointer :: ip + real, pointer :: rp + call generic(ip, rp) ! ok + call generic(ip, null()) ! ok + call generic(rp, null()) ! ok + call generic(null(), rp) ! ok + call generic(null(), ip) ! ok + call generic(null(mold=ip), null()) ! ok + call generic(null(), null(mold=ip)) ! ok + !ERROR: One or more NULL() actual arguments to the generic procedure 'generic' requires a MOLD= for disambiguation + call generic(null(), null()) + end subroutine +end