[flang-commits] [flang] eb14135 - [flang] Correct interaction between generics and intrinsics
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Apr 14 13:56:15 PDT 2022
Author: Peter Klausler
Date: 2022-04-14T13:56:04-07:00
New Revision: eb14135e35bf2463a5c52394f311d47c18d72dee
URL: https://github.com/llvm/llvm-project/commit/eb14135e35bf2463a5c52394f311d47c18d72dee
DIFF: https://github.com/llvm/llvm-project/commit/eb14135e35bf2463a5c52394f311d47c18d72dee.diff
LOG: [flang] Correct interaction between generics and intrinsics
Fortran allows a generic interface to have he same name as an
intrinsic procedure. If the intrinsic is explicitly marked with
the INTRINSIC attribute, restrictions apply (C848) - the generic
must contain only functions or subroutines, depending on the
intrinsic. Explicit or not, the generic overrides the intrinsic,
but the intrinsic behavior must still be available for calls
whose actual arguments do not match any of the specific procedures.
Semantics was not checking constraint C848, and it didn't allow
an explicit INTRINSIC attribute on a name of a generic interface.
Differential Revision: https://reviews.llvm.org/D123713
Added:
flang/test/Semantics/resolve109.f90
Modified:
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/resolve-names.cpp
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 924cd5e55caba..988557a7cdca5 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -115,6 +115,7 @@ class CheckHelper {
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 @@ void CheckHelper::CheckGeneric(
[&](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 @@ void CheckHelper::CheckDioDtvArg(
}
}
+// 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<SubprogramDetails>()}) {
+ 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
index f28cf9800a41c..93d60579ada7e 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2175,54 +2175,54 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
return std::nullopt; // also handles null symbol
}
const Symbol &ultimate{DEREF(symbol).GetUltimate()};
- if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
- if (std::optional<SpecificCall> 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<semantics::GenericDetails>()) {
- ExpressionAnalyzer::AdjustActuals noAdjustment;
- auto pair{ResolveGeneric(
- *symbol, arguments, noAdjustment, mightBeStructureConstructor)};
- symbol = pair.first;
- dueToNullActual = pair.second;
- }
- if (symbol) {
- if (symbol->GetUltimate().has<semantics::DerivedTypeDetails>()) {
- 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<semantics::GenericDetails>()};
+ 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> 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> 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<semantics::DerivedTypeDetails>()) {
+ 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
index 128a49e2a2086..81f8d6e08aa7f 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3919,7 +3919,9 @@ bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
HandleAttributeStmt(Attr::INTRINSIC, x.v);
for (const auto &name : x.v) {
auto &symbol{DEREF(FindSymbol(name))};
- if (!ConvertToProcEntity(symbol)) {
+ if (symbol.has<GenericDetails>()) {
+ // 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
index 0000000000000..8edbba5f8805f
--- /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
More information about the flang-commits
mailing list