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 @@ -115,6 +115,7 @@ void CheckDioDummyIsScalar(const Symbol &, const Symbol &); void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr); void CheckDioDtvArg(const Symbol &, const Symbol *, GenericKind::DefinedIo); + void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &); void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr); void CheckDioAssumedLenCharacterArg( const Symbol &, const Symbol *, std::size_t, Attr); @@ -1148,6 +1149,11 @@ [&](const GenericKind::DefinedIo &io) { CheckDefinedIoProc(symbol, details, io); }, + [&](const GenericKind::OtherKind &other) { + if (other == GenericKind::OtherKind::Name) { + CheckGenericVsIntrinsic(symbol, details); + } + }, [](const auto &) {}, }, details.kind().u); @@ -1941,6 +1947,40 @@ } } +// If an explicit INTRINSIC name is a function, so must all the specifics be, +// and similarly for subroutines +void CheckHelper::CheckGenericVsIntrinsic( + const Symbol &symbol, const GenericDetails &generic) { + if (symbol.attrs().test(Attr::INTRINSIC)) { + const evaluate::IntrinsicProcTable &table{ + context_.foldingContext().intrinsics()}; + bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())}; + if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) { + for (const SymbolRef &ref : generic.specificProcs()) { + const Symbol &ultimate{ref->GetUltimate()}; + bool specificFunc{ultimate.test(Symbol::Flag::Function)}; + bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)}; + if (!specificFunc && !specificSubr) { + if (const auto *proc{ultimate.detailsIf()}) { + if (proc->isFunction()) { + specificFunc = true; + } else { + specificSubr = true; + } + } + } + if ((specificFunc || specificSubr) && + isSubroutine != specificSubr) { // C848 + messages_.Say(symbol.name(), + "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US, + symbol.name(), isSubroutine ? "subroutine" : "function", + ref->name(), isSubroutine ? "function" : "subroutine"); + } + } + } + } +} + void CheckHelper::CheckDefaultIntegerArg( const Symbol &subp, const Symbol *arg, Attr intent) { // Argument looks like: INTEGER, INTENT(intent) :: arg 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 @@ -2175,54 +2175,54 @@ return std::nullopt; // also handles null symbol } const Symbol &ultimate{DEREF(symbol).GetUltimate()}; - if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) { - if (std::optional specificCall{context_.intrinsics().Probe( - CallCharacteristics{ultimate.name().ToString(), isSubroutine}, - arguments, GetFoldingContext())}) { - CheckBadExplicitType(*specificCall, *symbol); - return CalleeAndArguments{ - ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, - std::move(specificCall->arguments)}; - } - } else { - CheckForBadRecursion(name.source, ultimate); - bool dueToNullActual{false}; - if (ultimate.has()) { - ExpressionAnalyzer::AdjustActuals noAdjustment; - auto pair{ResolveGeneric( - *symbol, arguments, noAdjustment, mightBeStructureConstructor)}; - symbol = pair.first; - dueToNullActual = pair.second; - } - if (symbol) { - if (symbol->GetUltimate().has()) { - if (mightBeStructureConstructor) { - return CalleeAndArguments{ - semantics::SymbolRef{*symbol}, std::move(arguments)}; - } - } else if (IsProcedure(*symbol)) { + CheckForBadRecursion(name.source, ultimate); + bool dueToNullActual{false}; + bool isGenericInterface{ultimate.has()}; + const Symbol *resolution{nullptr}; + if (isGenericInterface) { + ExpressionAnalyzer::AdjustActuals noAdjustment; + auto pair{ResolveGeneric( + *symbol, arguments, noAdjustment, mightBeStructureConstructor)}; + resolution = pair.first; + dueToNullActual = pair.second; + } + if (!resolution) { + // Not generic, or no resolution; may be intrinsic + if (!symbol->attrs().test(semantics::Attr::EXTERNAL)) { + if (std::optional specificCall{context_.intrinsics().Probe( + CallCharacteristics{ultimate.name().ToString(), isSubroutine}, + arguments, GetFoldingContext())}) { + CheckBadExplicitType(*specificCall, *symbol); return CalleeAndArguments{ - ProcedureDesignator{*symbol}, std::move(arguments)}; + ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, + std::move(specificCall->arguments)}; + } else if (symbol->attrs().test(semantics::Attr::INTRINSIC)) { + return std::nullopt; } - if (!context_.HasError(*symbol)) { - AttachDeclaration( - Say(name.source, "'%s' is not a callable procedure"_err_en_US, - name.source), - *symbol); - } - } else if (std::optional specificCall{ - context_.intrinsics().Probe( - CallCharacteristics{ - ultimate.name().ToString(), isSubroutine}, - arguments, GetFoldingContext())}) { - // Generics can extend intrinsics - return CalleeAndArguments{ - ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, - std::move(specificCall->arguments)}; + } + if (isGenericInterface) { + EmitGenericResolutionError(*symbol, dueToNullActual); + return std::nullopt; } else { - EmitGenericResolutionError(*name.symbol, dueToNullActual); + // Neither a generic interface nor an intrinsic + resolution = symbol; } } + if (resolution->GetUltimate().has()) { + if (mightBeStructureConstructor) { + return CalleeAndArguments{ + semantics::SymbolRef{*resolution}, std::move(arguments)}; + } + } else if (IsProcedure(*resolution)) { + return CalleeAndArguments{ + ProcedureDesignator{*resolution}, std::move(arguments)}; + } + if (!context_.HasError(*resolution)) { + AttachDeclaration( + Say(name.source, "'%s' is not a callable procedure"_err_en_US, + name.source), + *resolution); + } return std::nullopt; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3919,7 +3919,9 @@ HandleAttributeStmt(Attr::INTRINSIC, x.v); for (const auto &name : x.v) { auto &symbol{DEREF(FindSymbol(name))}; - if (!ConvertToProcEntity(symbol)) { + if (symbol.has()) { + // Generic interface is extending intrinsic; ok + } else if (!ConvertToProcEntity(symbol)) { SayWithDecl( name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US); } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840 diff --git a/flang/test/Semantics/resolve109.f90 b/flang/test/Semantics/resolve109.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve109.f90 @@ -0,0 +1,58 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Interfaces are allowed to extend intrinsic procedures, with limitations +module m1 + intrinsic sin + interface sin + module procedure :: charcpy + end interface + interface cos ! no INTRINSIC statement + module procedure :: charcpy + end interface + intrinsic mvbits + interface mvbits + module procedure :: negate + end interface + interface move_alloc ! no INTRINSIC statement + module procedure :: negate + end interface + interface tan ! not explicitly INTRINSIC + module procedure :: negate ! a subroutine + end interface + interface acos + module procedure :: minus ! override + end interface + intrinsic atan + !ERROR: Generic interface 'atan' with explicit intrinsic function of the same name may not have specific procedure 'negate' that is a subroutine + interface atan + module procedure :: negate ! a subroutine + end interface + contains + character function charcpy(x) + character, intent(in) :: x + charcpy = x + end function + subroutine negate(x) + real, intent(in out) :: x + x = -x + end subroutine + real elemental function minus(x) + real, intent(in) :: x + minus = -x + end function + subroutine test + integer, allocatable :: j, k + real :: x + character :: str + x = sin(x) + str = sin(str) ! charcpy + x = cos(x) + str = cos(str) ! charcpy + call mvbits(j,0,1,k,0) + call mvbits(x) ! negate + call move_alloc(j, k) + call move_alloc(x) ! negate + !ERROR: Cannot call subroutine 'tan' like a function + x = tan(x) + x = acos(x) ! user's interface overrides intrinsic + end subroutine +end module