[flang] Relax error into a warning (#107489)

The standard requires that a generic interface with the same name as a
derived type contain only functions. We generally allow a generic
interface to contain both functions and subroutines, since there's never
any ambiguity at the point of call; these is helpful when the specific
procedures of two generics are combined during USE association. Emit a
warning instead of a hard error when a generic interface with the same
name as a derived type contains a subroutine to improve portability of
code from compilers that don't check for this condition.
This commit is contained in:
Peter Klausler 2024-09-10 14:10:40 -07:00 committed by GitHub
parent ce392471c0
commit 5a229dbca1
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
3 changed files with 27 additions and 30 deletions

View File

@ -507,10 +507,7 @@ end
f18 supports them with a portability warning.
* f18 does not enforce a blanket prohibition against generic
interfaces containing a mixture of functions and subroutines.
Apart from some contexts in which the standard requires all of
a particular generic interface to have only all functions or
all subroutines as its specific procedures, we allow both to
appear, unlike several other Fortran compilers.
We allow both to appear, unlike several other Fortran compilers.
This is especially desirable when two generics of the same
name are combined due to USE association and the mixture may
be inadvertent.

View File

@ -3639,36 +3639,36 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
}
return;
}
const Symbol &firstSpecific{specifics.front()};
bool isFunction{firstSpecific.test(Symbol::Flag::Function)};
bool isBoth{false};
const Symbol *function{nullptr};
const Symbol *subroutine{nullptr};
for (const Symbol &specific : specifics) {
if (isFunction != specific.test(Symbol::Flag::Function)) { // C1514
if (context().ShouldWarn(
if (!function && specific.test(Symbol::Flag::Function)) {
function = &specific;
} else if (!subroutine && specific.test(Symbol::Flag::Subroutine)) {
subroutine = &specific;
if (details.derivedType() &&
context().ShouldWarn(
common::LanguageFeature::SubroutineAndFunctionSpecifics)) {
SayDerivedType(generic.name(),
"Generic interface '%s' should only contain functions due to derived type with same name"_warn_en_US,
*details.derivedType()->GetUltimate().scope());
}
}
if (function && subroutine) {
if (context().ShouldWarn(common::LanguageFeature::
SubroutineAndFunctionSpecifics)) { // C1514
auto &msg{Say(generic.name(),
"Generic interface '%s' has both a function and a subroutine"_warn_en_US)};
if (isFunction) {
msg.Attach(firstSpecific.name(), "Function declaration"_en_US);
msg.Attach(specific.name(), "Subroutine declaration"_en_US);
} else {
msg.Attach(firstSpecific.name(), "Subroutine declaration"_en_US);
msg.Attach(specific.name(), "Function declaration"_en_US);
}
msg.Attach(function->name(), "Function declaration"_en_US);
msg.Attach(subroutine->name(), "Subroutine declaration"_en_US);
}
isFunction = false;
isBoth = true;
break;
}
}
if (!isFunction && details.derivedType()) {
SayDerivedType(generic.name(),
"Generic interface '%s' may only contain functions due to derived type"
" with same name"_err_en_US,
*details.derivedType()->GetUltimate().scope());
}
if (!isBoth) {
generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
if (function && !subroutine) {
generic.set(Symbol::Flag::Function);
} else if (subroutine && !function) {
generic.set(Symbol::Flag::Subroutine);
}
}

View File

@ -1,6 +1,6 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
subroutine test1
!ERROR: Generic interface 'foo' has both a function and a subroutine
!WARNING: Generic interface 'foo' has both a function and a subroutine
interface foo
subroutine s1(x)
end subroutine
@ -12,7 +12,7 @@ subroutine test1
end subroutine
subroutine test2
!ERROR: Generic interface 'foo' has both a function and a subroutine
!WARNING: Generic interface 'foo' has both a function and a subroutine
interface foo
function t2f1(x)
end function
@ -24,7 +24,7 @@ subroutine test2
end subroutine
module test3
!ERROR: Generic interface 'foo' has both a function and a subroutine
!WARNING: Generic interface 'foo' has both a function and a subroutine
interface foo
module procedure s
module procedure f
@ -39,7 +39,7 @@ end module
subroutine test4
type foo
end type
!ERROR: Generic interface 'foo' may only contain functions due to derived type with same name
!WARNING: Generic interface 'foo' should only contain functions due to derived type with same name
interface foo
subroutine s()
end subroutine