Skip to content

Commit ba4a449

Browse files
klauslerklausler
committed
[flang] Whether a procedure's interface is explicit or not is not a distinguishing characteristic
We note whether a procedure's interface is explicit or implicit as an attribute of its characteristics, so that other semantics can be checked appropriately, but this internal attribute should not be used as a distinguishing characteristic in itself. Fixes #81876.
1 parent 00570c3 commit ba4a449

File tree

11 files changed

+116
-32
lines changed

11 files changed

+116
-32
lines changed

‎flang/include/flang/Evaluate/characteristics.h

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -381,8 +381,8 @@ struct Procedure {
381381
int FindPassIndex(std::optional<parser::CharBlock>) const;
382382
bool CanBeCalledViaImplicitInterface(std::string *whyNot = nullptr) const;
383383
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
384-
bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr,
385-
const SpecificIntrinsic * = nullptr,
384+
bool IsCompatibleWith(const Procedure &, bool ignoreImplicitVsExplicit,
385+
std::string *whyNot = nullptr, const SpecificIntrinsic * = nullptr,
386386
std::optional<std::string> *warning = nullptr) const;
387387

388388
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;

‎flang/include/flang/Evaluate/tools.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1094,7 +1094,7 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10941094
const std::optional<characteristics::Procedure> &lhsProcedure,
10951095
const characteristics::Procedure *rhsProcedure,
10961096
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1097-
std::optional<std::string> &warning);
1097+
std::optional<std::string> &warning, bool ignoreImplicitVsExplicit);
10981098

10991099
// Scalar constant expansion
11001100
class ScalarConstantExpander {

‎flang/lib/Evaluate/characteristics.cpp

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -533,7 +533,8 @@ bool DummyProcedure::IsCompatibleWith(
533533
}
534534
return false;
535535
}
536-
if (!procedure.value().IsCompatibleWith(actual.procedure.value(), whyNot)) {
536+
if (!procedure.value().IsCompatibleWith(actual.procedure.value(),
537+
/*ignoreImplicitVsExplicit=*/false, whyNot)) {
537538
if (whyNot) {
538539
*whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
539540
}
@@ -1206,7 +1207,8 @@ bool FunctionResult::IsCompatibleWith(
12061207
CHECK(ifaceProc != nullptr);
12071208
if (const auto *actualProc{
12081209
std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
1209-
if (ifaceProc->value().IsCompatibleWith(actualProc->value(), whyNot)) {
1210+
if (ifaceProc->value().IsCompatibleWith(actualProc->value(),
1211+
/*ignoreImplicitVsExplicit=*/false, whyNot)) {
12101212
return true;
12111213
}
12121214
if (whyNot) {
@@ -1251,7 +1253,8 @@ bool Procedure::operator==(const Procedure &that) const {
12511253
cudaSubprogramAttrs == that.cudaSubprogramAttrs;
12521254
}
12531255

1254-
bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
1256+
bool Procedure::IsCompatibleWith(const Procedure &actual,
1257+
bool ignoreImplicitVsExplicit, std::string *whyNot,
12551258
const SpecificIntrinsic *specificIntrinsic,
12561259
std::optional<std::string> *warning) const {
12571260
// 15.5.2.9(1): if dummy is not pure, actual need not be.
@@ -1265,6 +1268,9 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
12651268
}
12661269
Attrs differences{attrs ^ actualAttrs};
12671270
differences.reset(Attr::Subroutine); // dealt with specifically later
1271+
if (ignoreImplicitVsExplicit) {
1272+
differences.reset(Attr::ImplicitInterface);
1273+
}
12681274
if (!differences.empty()) {
12691275
if (whyNot) {
12701276
auto sep{": "s};

‎flang/lib/Evaluate/tools.cpp

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1083,7 +1083,7 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10831083
const std::optional<characteristics::Procedure> &lhsProcedure,
10841084
const characteristics::Procedure *rhsProcedure,
10851085
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1086-
std::optional<std::string> &warning) {
1086+
std::optional<std::string> &warning, bool ignoreImplicitVsExplicit) {
10871087
std::optional<parser::MessageFixedText> msg;
10881088
if (!lhsProcedure) {
10891089
msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -1097,8 +1097,9 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10971097
*rhsProcedure->functionResult, &whyNotCompatible)) {
10981098
msg =
10991099
"Function %s associated with incompatible function designator '%s': %s"_err_en_US;
1100-
} else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible,
1101-
specificIntrinsic, &warning)) {
1100+
} else if (lhsProcedure->IsCompatibleWith(*rhsProcedure,
1101+
ignoreImplicitVsExplicit, &whyNotCompatible, specificIntrinsic,
1102+
&warning)) {
11021103
// OK
11031104
} else if (isCall) {
11041105
msg = "Procedure %s associated with result of reference to function '%s'"

‎flang/lib/Semantics/check-call.cpp

Lines changed: 19 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -912,7 +912,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
912912
static void CheckProcedureArg(evaluate::ActualArgument &arg,
913913
const characteristics::Procedure &proc,
914914
const characteristics::DummyProcedure &dummy, const std::string &dummyName,
915-
SemanticsContext &context) {
915+
SemanticsContext &context, bool ignoreImplicitVsExplicit) {
916916
evaluate::FoldingContext &foldingContext{context.foldingContext()};
917917
parser::ContextualMessages &messages{foldingContext.messages()};
918918
auto restorer{
@@ -975,7 +975,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
975975
if (interface.HasExplicitInterface()) {
976976
std::string whyNot;
977977
std::optional<std::string> warning;
978-
if (!interface.IsCompatibleWith(argInterface, &whyNot,
978+
if (!interface.IsCompatibleWith(argInterface,
979+
ignoreImplicitVsExplicit, &whyNot,
979980
/*specificIntrinsic=*/nullptr, &warning)) {
980981
// 15.5.2.9(1): Explicit interfaces must match
981982
if (argInterface.HasExplicitInterface()) {
@@ -1081,7 +1082,8 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
10811082
const characteristics::DummyArgument &dummy,
10821083
const characteristics::Procedure &proc, SemanticsContext &context,
10831084
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
1084-
bool allowActualArgumentConversions, bool extentErrors) {
1085+
bool allowActualArgumentConversions, bool extentErrors,
1086+
bool ignoreImplicitVsExplicit) {
10851087
evaluate::FoldingContext &foldingContext{context.foldingContext()};
10861088
auto &messages{foldingContext.messages()};
10871089
std::string dummyName{"dummy argument"};
@@ -1185,7 +1187,8 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
11851187
},
11861188
[&](const characteristics::DummyProcedure &dummy) {
11871189
if (!checkActualArgForLabel(arg)) {
1188-
CheckProcedureArg(arg, proc, dummy, dummyName, context);
1190+
CheckProcedureArg(arg, proc, dummy, dummyName, context,
1191+
ignoreImplicitVsExplicit);
11891192
}
11901193
},
11911194
[&](const characteristics::AlternateReturn &) {
@@ -1371,7 +1374,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
13711374
: nullptr};
13721375
std::optional<parser::MessageFixedText> msg{
13731376
CheckProcCompatibility(isCall, pointerProc, &*targetProc,
1374-
specificIntrinsic, whyNot, warning)};
1377+
specificIntrinsic, whyNot, warning,
1378+
/*ignoreImplicitVsExplicit=*/false)};
13751379
if (!msg && warning &&
13761380
semanticsContext.ShouldWarn(
13771381
common::UsageWarning::ProcDummyArgShapes)) {
@@ -1740,7 +1744,8 @@ static parser::Messages CheckExplicitInterface(
17401744
const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
17411745
SemanticsContext &context, const Scope *scope,
17421746
const evaluate::SpecificIntrinsic *intrinsic,
1743-
bool allowActualArgumentConversions, bool extentErrors) {
1747+
bool allowActualArgumentConversions, bool extentErrors,
1748+
bool ignoreImplicitVsExplicit) {
17441749
evaluate::FoldingContext &foldingContext{context.foldingContext()};
17451750
parser::ContextualMessages &messages{foldingContext.messages()};
17461751
parser::Messages buffer;
@@ -1754,7 +1759,8 @@ static parser::Messages CheckExplicitInterface(
17541759
const auto &dummy{proc.dummyArguments.at(index++)};
17551760
if (actual) {
17561761
CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
1757-
allowActualArgumentConversions, extentErrors);
1762+
allowActualArgumentConversions, extentErrors,
1763+
ignoreImplicitVsExplicit);
17581764
} else if (!dummy.IsOptional()) {
17591765
if (dummy.name.empty()) {
17601766
messages.Say(
@@ -1783,7 +1789,8 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
17831789
bool allowActualArgumentConversions) {
17841790
return proc.HasExplicitInterface() &&
17851791
!CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
1786-
allowActualArgumentConversions, false /*extentErrors*/)
1792+
allowActualArgumentConversions, /*extentErrors=*/false,
1793+
/*ignoreImplicitVsExplicit=*/false)
17871794
.AnyFatalError();
17881795
}
17891796

@@ -1876,6 +1883,7 @@ bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,
18761883
bool CheckArguments(const characteristics::Procedure &proc,
18771884
evaluate::ActualArguments &actuals, SemanticsContext &context,
18781885
const Scope &scope, bool treatingExternalAsImplicit,
1886+
bool ignoreImplicitVsExplicit,
18791887
const evaluate::SpecificIntrinsic *intrinsic) {
18801888
bool explicitInterface{proc.HasExplicitInterface()};
18811889
evaluate::FoldingContext foldingContext{context.foldingContext()};
@@ -1898,8 +1906,9 @@ bool CheckArguments(const characteristics::Procedure &proc,
18981906
}
18991907
}
19001908
if (explicitInterface) {
1901-
auto buffer{CheckExplicitInterface(
1902-
proc, actuals, context, &scope, intrinsic, true, true)};
1909+
auto buffer{CheckExplicitInterface(proc, actuals, context, &scope,
1910+
intrinsic, /*allowArgumentConversions=*/true, /*extentErrors=*/true,
1911+
ignoreImplicitVsExplicit)};
19031912
if (!buffer.empty()) {
19041913
if (treatingExternalAsImplicit) {
19051914
if (auto *msg{messages.Say(

‎flang/lib/Semantics/check-call.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ class SemanticsContext;
3535
// messages were created, true if all is well.
3636
bool CheckArguments(const evaluate::characteristics::Procedure &,
3737
evaluate::ActualArguments &, SemanticsContext &, const Scope &,
38-
bool treatingExternalAsImplicit,
38+
bool treatingExternalAsImplicit, bool ignoreImplicitVsExplicit,
3939
const evaluate::SpecificIntrinsic *intrinsic);
4040

4141
bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,

‎flang/lib/Semantics/check-declarations.cpp

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1481,7 +1481,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
14811481
if (auto globalChars{Characterize(*global)}) {
14821482
if (chars->HasExplicitInterface()) {
14831483
std::string whyNot;
1484-
if (!chars->IsCompatibleWith(*globalChars, &whyNot)) {
1484+
if (!chars->IsCompatibleWith(*globalChars,
1485+
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
14851486
msg = WarnIfNotInModuleFile(
14861487
"The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
14871488
global->name(), whyNot);
@@ -1507,7 +1508,8 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
15071508
if (auto chars{Characterize(symbol)}) {
15081509
if (auto previousChars{Characterize(previous)}) {
15091510
std::string whyNot;
1510-
if (!chars->IsCompatibleWith(*previousChars, &whyNot)) {
1511+
if (!chars->IsCompatibleWith(*previousChars,
1512+
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
15111513
if (auto *msg{WarnIfNotInModuleFile(
15121514
"The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
15131515
symbol.name(), whyNot)}) {

‎flang/lib/Semantics/expression.cpp

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -3129,7 +3129,8 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
31293129
if (auto iter{implicitInterfaces_.find(name)};
31303130
iter != implicitInterfaces_.end()) {
31313131
std::string whyNot;
3132-
if (!chars->IsCompatibleWith(iter->second.second, &whyNot)) {
3132+
if (!chars->IsCompatibleWith(iter->second.second,
3133+
/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
31333134
if (auto *msg{Say(callSite,
31343135
"Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US,
31353136
name, whyNot)}) {
@@ -3169,7 +3170,7 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
31693170
}
31703171
ok &= semantics::CheckArguments(*chars, arguments, context_,
31713172
context_.FindScope(callSite), treatExternalAsImplicit,
3172-
specificIntrinsic);
3173+
/*ignoreImplicitVsExplicit=*/false, specificIntrinsic);
31733174
}
31743175
if (procSymbol && !IsPureProcedure(*procSymbol)) {
31753176
if (const semantics::Scope *
@@ -3188,7 +3189,8 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
31883189
if (auto globalChars{characteristics::Procedure::Characterize(
31893190
*global, context_.foldingContext())}) {
31903191
semantics::CheckArguments(*globalChars, arguments, context_,
3191-
context_.FindScope(callSite), true,
3192+
context_.FindScope(callSite), /*treatExternalAsImplicit=*/true,
3193+
/*ignoreImplicitVsExplicit=*/false,
31923194
nullptr /*not specific intrinsic*/);
31933195
}
31943196
}

‎flang/lib/Semantics/pointer-assignment.cpp

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -362,7 +362,8 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
362362
std::optional<std::string> warning;
363363
CharacterizeProcedure();
364364
if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
365-
isCall, procedure_, rhsProcedure, specific, whyNot, warning)}) {
365+
isCall, procedure_, rhsProcedure, specific, whyNot, warning,
366+
/*ignoreImplicitVsExplicit=*/isCall)}) {
366367
Say(std::move(*msg), description_, rhsName, whyNot);
367368
return false;
368369
}

‎flang/lib/Semantics/resolve-names.cpp

Lines changed: 15 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -8362,16 +8362,25 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) {
83628362
const auto &bounds{std::get<parser::PointerAssignmentStmt::Bounds>(x.t)};
83638363
const auto &expr{std::get<parser::Expr>(x.t)};
83648364
ResolveDataRef(dataRef);
8365+
Symbol *ptrSymbol{parser::GetLastName(dataRef).symbol};
83658366
Walk(bounds);
83668367
// Resolve unrestricted specific intrinsic procedures as in "p => cos".
83678368
if (const parser::Name * name{parser::Unwrap<parser::Name>(expr)}) {
83688369
if (NameIsKnownOrIntrinsic(*name)) {
8369-
// If the name is known because it is an object entity from a host
8370-
// procedure, create a host associated symbol.
8371-
if (Symbol * symbol{name->symbol}; symbol &&
8372-
symbol->GetUltimate().has<ObjectEntityDetails>() &&
8373-
IsUplevelReference(*symbol)) {
8374-
MakeHostAssocSymbol(*name, *symbol);
8370+
if (Symbol * symbol{name->symbol}) {
8371+
if (IsProcedurePointer(ptrSymbol) &&
8372+
!ptrSymbol->test(Symbol::Flag::Function) &&
8373+
!ptrSymbol->test(Symbol::Flag::Subroutine)) {
8374+
if (symbol->test(Symbol::Flag::Function)) {
8375+
ApplyImplicitRules(*ptrSymbol);
8376+
}
8377+
}
8378+
// If the name is known because it is an object entity from a host
8379+
// procedure, create a host associated symbol.
8380+
if (symbol->GetUltimate().has<ObjectEntityDetails>() &&
8381+
IsUplevelReference(*symbol)) {
8382+
MakeHostAssocSymbol(*name, *symbol);
8383+
}
83758384
}
83768385
return false;
83778386
}

‎flang/test/Semantics/implicit14.f90

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
! RUN: %python %S/test_errors.py %s %flang_fc1
2+
module m
3+
type dt
4+
procedure(explicit), pointer, nopass :: p
5+
end type
6+
contains
7+
integer function one()
8+
one = 1
9+
end
10+
function onePtr()
11+
procedure(one), pointer :: onePtr
12+
onePtr => one
13+
end
14+
function explicit
15+
character(:), allocatable :: explicit
16+
explicit = "abc"
17+
end
18+
end
19+
20+
program test
21+
use m
22+
procedure(), pointer :: p0
23+
procedure(one), pointer :: p1
24+
procedure(integer), pointer :: p2
25+
procedure(explicit), pointer :: p3
26+
external implicit
27+
type(dt) x
28+
p0 => one ! ok
29+
p0 => onePtr() ! ok
30+
p0 => implicit ! ok
31+
!ERROR: Procedure pointer 'p0' with implicit interface may not be associated with procedure designator 'explicit' with explicit interface that cannot be called via an implicit interface
32+
p0 => explicit
33+
p1 => one ! ok
34+
p1 => onePtr() ! ok
35+
p1 => implicit ! ok
36+
!ERROR: Function pointer 'p1' associated with incompatible function designator 'explicit': function results have incompatible attributes
37+
p1 => explicit
38+
p2 => one ! ok
39+
p2 => onePtr() ! ok
40+
p2 => implicit ! ok
41+
!ERROR: Function pointer 'p2' associated with incompatible function designator 'explicit': function results have incompatible attributes
42+
p2 => explicit
43+
!ERROR: Function pointer 'p3' associated with incompatible function designator 'one': function results have incompatible attributes
44+
p3 => one
45+
!ERROR: Procedure pointer 'p3' associated with result of reference to function 'oneptr' that is an incompatible procedure pointer: function results have incompatible attributes
46+
p3 => onePtr()
47+
p3 => explicit ! ok
48+
!ERROR: Procedure pointer 'p3' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface
49+
p3 => implicit
50+
!ERROR: Procedure pointer 'p' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface
51+
x = dt(implicit)
52+
!ERROR: Procedure pointer 'p' with explicit interface that cannot be called via an implicit interface cannot be associated with procedure designator with an implicit interface
53+
x%p => implicit
54+
end

0 commit comments

Comments
 (0)