Skip to content

Commit 3602efa

Browse files
klauslerklausler
authored
[flang] Silence errors on C_LOC/C_FUNLOC in specification expressions (#96108)
Transformational functions from the intrinsic module ISO_C_BINDING are allowed in specification expressions, so tweak some general checks that would otherwise trigger error messages about inadmissible targets, dummy procedures in specification expressions, and pure procedures with impure dummy procedures.
1 parent b312cbf commit 3602efa

File tree

7 files changed

+115
-78
lines changed

7 files changed

+115
-78
lines changed

‎flang/lib/Evaluate/check-expression.cpp

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -650,7 +650,8 @@ class CheckSpecificationExprHelper
650650
return std::holds_alternative<characteristics::DummyProcedure>(
651651
dummy.u);
652652
})};
653-
if (iter != procChars->dummyArguments.end()) {
653+
if (iter != procChars->dummyArguments.end() &&
654+
ultimate.name().ToString() != "__builtin_c_funloc") {
654655
return "reference to function '"s + ultimate.name().ToString() +
655656
"' with dummy procedure argument '" + iter->name + '\'';
656657
}

‎flang/lib/Evaluate/tools.cpp

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,8 @@ auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
8282
const Symbol &ultimate{symbol.GetUltimate()};
8383
return !IsNamedConstant(ultimate) &&
8484
(ultimate.has<semantics::ObjectEntityDetails>() ||
85+
(ultimate.has<semantics::EntityDetails>() &&
86+
ultimate.attrs().test(semantics::Attr::TARGET)) ||
8587
ultimate.has<semantics::AssocEntityDetails>());
8688
}
8789
auto IsVariableHelper::operator()(const Component &x) const -> Result {

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

Lines changed: 9 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -354,7 +354,10 @@ void CheckHelper::Check(const Symbol &symbol) {
354354
messages_.Say(
355355
"A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
356356
}
357-
if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
357+
if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
358+
// The intrinsic procedure C_FUNLOC() gets a pass on this check.
359+
} else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
360+
IsDummy(symbol)) {
358361
messages_.Say(
359362
"A dummy procedure of a pure subprogram must be pure"_err_en_US);
360363
}
@@ -463,16 +466,11 @@ void CheckHelper::Check(const Symbol &symbol) {
463466
symbol.name());
464467
}
465468
}
466-
if (IsProcedure(symbol) && !symbol.HasExplicitInterface()) {
467-
if (IsAllocatable(symbol)) {
468-
messages_.Say(
469-
"Procedure '%s' may not be ALLOCATABLE without an explicit interface"_err_en_US,
470-
symbol.name());
471-
} else if (symbol.Rank() > 0) {
472-
messages_.Say(
473-
"Procedure '%s' may not be an array without an explicit interface"_err_en_US,
474-
symbol.name());
475-
}
469+
if (IsProcedure(symbol) && !symbol.HasExplicitInterface() &&
470+
symbol.Rank() > 0) {
471+
messages_.Say(
472+
"Procedure '%s' may not be an array without an explicit interface"_err_en_US,
473+
symbol.name());
476474
}
477475
}
478476

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

Lines changed: 83 additions & 61 deletions
Original file line numberDiff line numberDiff line change
@@ -661,8 +661,8 @@ class ScopeHandler : public ImplicitRulesVisitor {
661661
void MakeExternal(Symbol &);
662662

663663
// C815 duplicated attribute checking; returns false on error
664-
bool CheckDuplicatedAttr(SourceName, const Symbol &, Attr);
665-
bool CheckDuplicatedAttrs(SourceName, const Symbol &, Attrs);
664+
bool CheckDuplicatedAttr(SourceName, Symbol &, Attr);
665+
bool CheckDuplicatedAttrs(SourceName, Symbol &, Attrs);
666666

667667
void SetExplicitAttr(Symbol &symbol, Attr attr) const {
668668
symbol.attrs().set(attr);
@@ -1087,6 +1087,58 @@ class DeclarationVisitor : public ArraySpecVisitor,
10871087
void NoteScalarSpecificationArgument(const Symbol &symbol) {
10881088
mustBeScalar_.emplace(symbol);
10891089
}
1090+
// Declare an object or procedure entity.
1091+
// T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
1092+
template <typename T>
1093+
Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
1094+
Symbol &symbol{MakeSymbol(name, attrs)};
1095+
if (context().HasError(symbol) || symbol.has<T>()) {
1096+
return symbol; // OK or error already reported
1097+
} else if (symbol.has<UnknownDetails>()) {
1098+
symbol.set_details(T{});
1099+
return symbol;
1100+
} else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
1101+
symbol.set_details(T{std::move(*details)});
1102+
return symbol;
1103+
} else if (std::is_same_v<EntityDetails, T> &&
1104+
(symbol.has<ObjectEntityDetails>() ||
1105+
symbol.has<ProcEntityDetails>())) {
1106+
return symbol; // OK
1107+
} else if (auto *details{symbol.detailsIf<UseDetails>()}) {
1108+
Say(name.source,
1109+
"'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
1110+
name.source, GetUsedModule(*details).name());
1111+
} else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) {
1112+
if (details->kind() == SubprogramKind::Module) {
1113+
Say2(name,
1114+
"Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
1115+
symbol, "Module procedure definition"_en_US);
1116+
} else if (details->kind() == SubprogramKind::Internal) {
1117+
Say2(name,
1118+
"Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
1119+
symbol, "Internal procedure definition"_en_US);
1120+
} else {
1121+
DIE("unexpected kind");
1122+
}
1123+
} else if (std::is_same_v<ObjectEntityDetails, T> &&
1124+
symbol.has<ProcEntityDetails>()) {
1125+
SayWithDecl(
1126+
name, symbol, "'%s' is already declared as a procedure"_err_en_US);
1127+
} else if (std::is_same_v<ProcEntityDetails, T> &&
1128+
symbol.has<ObjectEntityDetails>()) {
1129+
if (FindCommonBlockContaining(symbol)) {
1130+
SayWithDecl(name, symbol,
1131+
"'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
1132+
} else {
1133+
SayWithDecl(
1134+
name, symbol, "'%s' is already declared as an object"_err_en_US);
1135+
}
1136+
} else if (!CheckPossibleBadForwardRef(symbol)) {
1137+
SayAlreadyDeclared(name, symbol);
1138+
}
1139+
context().SetError(symbol);
1140+
return symbol;
1141+
}
10901142

10911143
private:
10921144
// The attribute corresponding to the statement containing an ObjectDecl
@@ -1151,59 +1203,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
11511203
bool PassesLocalityChecks(
11521204
const parser::Name &name, Symbol &symbol, Symbol::Flag flag);
11531205
bool CheckForHostAssociatedImplicit(const parser::Name &);
1154-
1155-
// Declare an object or procedure entity.
1156-
// T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
1157-
template <typename T>
1158-
Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
1159-
Symbol &symbol{MakeSymbol(name, attrs)};
1160-
if (context().HasError(symbol) || symbol.has<T>()) {
1161-
return symbol; // OK or error already reported
1162-
} else if (symbol.has<UnknownDetails>()) {
1163-
symbol.set_details(T{});
1164-
return symbol;
1165-
} else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
1166-
symbol.set_details(T{std::move(*details)});
1167-
return symbol;
1168-
} else if (std::is_same_v<EntityDetails, T> &&
1169-
(symbol.has<ObjectEntityDetails>() ||
1170-
symbol.has<ProcEntityDetails>())) {
1171-
return symbol; // OK
1172-
} else if (auto *details{symbol.detailsIf<UseDetails>()}) {
1173-
Say(name.source,
1174-
"'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
1175-
name.source, GetUsedModule(*details).name());
1176-
} else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) {
1177-
if (details->kind() == SubprogramKind::Module) {
1178-
Say2(name,
1179-
"Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
1180-
symbol, "Module procedure definition"_en_US);
1181-
} else if (details->kind() == SubprogramKind::Internal) {
1182-
Say2(name,
1183-
"Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
1184-
symbol, "Internal procedure definition"_en_US);
1185-
} else {
1186-
DIE("unexpected kind");
1187-
}
1188-
} else if (std::is_same_v<ObjectEntityDetails, T> &&
1189-
symbol.has<ProcEntityDetails>()) {
1190-
SayWithDecl(
1191-
name, symbol, "'%s' is already declared as a procedure"_err_en_US);
1192-
} else if (std::is_same_v<ProcEntityDetails, T> &&
1193-
symbol.has<ObjectEntityDetails>()) {
1194-
if (FindCommonBlockContaining(symbol)) {
1195-
SayWithDecl(name, symbol,
1196-
"'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
1197-
} else {
1198-
SayWithDecl(
1199-
name, symbol, "'%s' is already declared as an object"_err_en_US);
1200-
}
1201-
} else if (!CheckPossibleBadForwardRef(symbol)) {
1202-
SayAlreadyDeclared(name, symbol);
1203-
}
1204-
context().SetError(symbol);
1205-
return symbol;
1206-
}
12071206
bool HasCycle(const Symbol &, const Symbol *interface);
12081207
bool MustBeScalar(const Symbol &symbol) const {
12091208
return mustBeScalar_.find(symbol) != mustBeScalar_.end();
@@ -1624,6 +1623,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
16241623

16251624
void PreSpecificationConstruct(const parser::SpecificationConstruct &);
16261625
void CreateCommonBlockSymbols(const parser::CommonStmt &);
1626+
void CreateObjectSymbols(const std::list<parser::ObjectDecl> &, Attr);
16271627
void CreateGeneric(const parser::GenericSpec &);
16281628
void FinishSpecificationPart(const std::list<parser::DeclarationConstruct> &);
16291629
void AnalyzeStmtFunctionStmt(const parser::StmtFunctionStmt &);
@@ -2806,12 +2806,13 @@ void ScopeHandler::MakeExternal(Symbol &symbol) {
28062806
}
28072807

28082808
bool ScopeHandler::CheckDuplicatedAttr(
2809-
SourceName name, const Symbol &symbol, Attr attr) {
2809+
SourceName name, Symbol &symbol, Attr attr) {
28102810
if (attr == Attr::SAVE) {
28112811
// checked elsewhere
28122812
} else if (symbol.attrs().test(attr)) { // C815
28132813
if (symbol.implicitAttrs().test(attr)) {
28142814
// Implied attribute is now confirmed explicitly
2815+
symbol.implicitAttrs().reset(attr);
28152816
} else {
28162817
Say(name, "%s attribute was already specified on '%s'"_err_en_US,
28172818
EnumToString(attr), name);
@@ -2822,7 +2823,7 @@ bool ScopeHandler::CheckDuplicatedAttr(
28222823
}
28232824

28242825
bool ScopeHandler::CheckDuplicatedAttrs(
2825-
SourceName name, const Symbol &symbol, Attrs attrs) {
2826+
SourceName name, Symbol &symbol, Attrs attrs) {
28262827
bool ok{true};
28272828
attrs.IterateOverMembers(
28282829
[&](Attr x) { ok &= CheckDuplicatedAttr(name, symbol, x); });
@@ -5032,6 +5033,10 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
50325033
charInfo_.length.reset();
50335034
if (symbol.attrs().test(Attr::EXTERNAL)) {
50345035
ConvertToProcEntity(symbol);
5036+
} else if (symbol.attrs().HasAny(Attrs{Attr::ALLOCATABLE,
5037+
Attr::ASYNCHRONOUS, Attr::CONTIGUOUS, Attr::PARAMETER,
5038+
Attr::SAVE, Attr::TARGET, Attr::VALUE, Attr::VOLATILE})) {
5039+
ConvertToObjectEntity(symbol);
50355040
}
50365041
if (attrs.test(Attr::BIND_C)) {
50375042
SetBindNameOn(symbol);
@@ -8551,11 +8556,19 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
85518556
}
85528557
},
85538558
[&](const parser::Statement<parser::OtherSpecificationStmt> &y) {
8554-
if (const auto *commonStmt{parser::Unwrap<parser::CommonStmt>(y)}) {
8555-
CreateCommonBlockSymbols(*commonStmt);
8556-
}
8559+
common::visit(
8560+
common::visitors{
8561+
[&](const common::Indirection<parser::CommonStmt> &z) {
8562+
CreateCommonBlockSymbols(z.value());
8563+
},
8564+
[&](const common::Indirection<parser::TargetStmt> &z) {
8565+
CreateObjectSymbols(z.value().v, Attr::TARGET);
8566+
},
8567+
[](const auto &) {},
8568+
},
8569+
y.statement.u);
85578570
},
8558-
[&](const auto &) {},
8571+
[](const auto &) {},
85598572
},
85608573
spec.u);
85618574
}
@@ -8575,6 +8588,15 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols(
85758588
}
85768589
}
85778590

8591+
void ResolveNamesVisitor::CreateObjectSymbols(
8592+
const std::list<parser::ObjectDecl> &decls, Attr attr) {
8593+
for (const parser::ObjectDecl &decl : decls) {
8594+
SetImplicitAttr(DeclareEntity<ObjectEntityDetails>(
8595+
std::get<parser::ObjectName>(decl.t), Attrs{}),
8596+
attr);
8597+
}
8598+
}
8599+
85788600
void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
85798601
auto info{GenericSpecInfo{x}};
85808602
SourceName symbolName{info.symbolName()};

‎flang/module/__fortran_builtins.f90

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -182,7 +182,10 @@
182182
__builtin_c_ptr_ne = x%__address /= y%__address
183183
end function
184184

185-
function __builtin_c_funloc(x)
185+
! Semantics has some special-case code that allows c_funloc()
186+
! to appear in a specification expression and exempts it
187+
! from the requirement that "x" be a pure dummy procedure.
188+
pure function __builtin_c_funloc(x)
186189
type(__builtin_c_funptr) :: __builtin_c_funloc
187190
external :: x
188191
__builtin_c_funloc = __builtin_c_funptr(loc(x))

‎flang/test/Semantics/c_loc01.f90

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,10 @@ module m
44
type haslen(L)
55
integer, len :: L
66
end type
7+
integer, target :: targ
78
contains
9+
subroutine subr
10+
end
811
subroutine test(assumedType, poly, nclen)
912
type(*), target :: assumedType
1013
class(*), target :: poly
@@ -17,6 +20,8 @@ subroutine test(assumedType, poly, nclen)
1720
type(hasLen(1)), target :: clen
1821
type(hasLen(*)), target :: nclen
1922
character(2), target :: ch
23+
real :: arr1(purefun1(c_loc(targ))) ! ok
24+
real :: arr2(purefun2(c_funloc(subr))) ! ok
2025
!ERROR: C_LOC() argument must be a data pointer or target
2126
cp = c_loc(notATarget)
2227
!ERROR: C_LOC() argument must be a data pointer or target
@@ -44,4 +49,12 @@ subroutine test(assumedType, poly, nclen)
4449
!ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_funptr) and TYPE(c_ptr)
4550
cfp = cp
4651
end
52+
pure integer function purefun1(p)
53+
type(c_ptr), intent(in) :: p
54+
purefun1 = 1
55+
end
56+
pure integer function purefun2(p)
57+
type(c_funptr), intent(in) :: p
58+
purefun2 = 1
59+
end
4760
end module

‎flang/test/Semantics/call05.f90

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -123,9 +123,7 @@ subroutine test
123123

124124
module m2
125125

126-
!ERROR: Procedure 't3' may not be ALLOCATABLE without an explicit interface
127126
character(len=10), allocatable :: t1, t2, t3, t4
128-
!ERROR: Procedure 't6' may not be ALLOCATABLE without an explicit interface
129127
character(len=:), allocatable :: t5, t6, t7, t8(:)
130128

131129
character(len=10), pointer :: p1
@@ -189,7 +187,7 @@ subroutine test()
189187
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
190188
call sma(t2(:))
191189

192-
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
190+
!ERROR: 't3' is not a callable procedure
193191
call sma(t3(1))
194192

195193
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
@@ -208,7 +206,7 @@ subroutine test()
208206
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
209207
call sma(t5(:))
210208

211-
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
209+
!ERROR: 't6' is not a callable procedure
212210
call sma(t6(1))
213211

214212
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument

0 commit comments

Comments
 (0)