[flang-commits] [flang] [flang] Silence errors on C_LOC/C_FUNLOC in specification expressions (PR #96108)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jun 21 13:45:17 PDT 2024
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/96108
>From f60a5834a92bd5943117738fb6a533d6123fd9bd Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 19 Jun 2024 12:46:30 -0700
Subject: [PATCH] [flang] Silence errors on C_LOC/C_FUNLOC in specification
expressions
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.
---
flang/lib/Evaluate/check-expression.cpp | 3 +-
flang/lib/Evaluate/tools.cpp | 2 +
flang/lib/Semantics/check-declarations.cpp | 20 ++-
flang/lib/Semantics/resolve-names.cpp | 144 ++++++++++++---------
flang/module/__fortran_builtins.f90 | 5 +-
flang/test/Semantics/c_loc01.f90 | 13 ++
flang/test/Semantics/call05.f90 | 6 +-
7 files changed, 115 insertions(+), 78 deletions(-)
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index a4b152c60a72f..5d904cfc3a069 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -649,7 +649,8 @@ class CheckSpecificationExprHelper
return std::holds_alternative<characteristics::DummyProcedure>(
dummy.u);
})};
- if (iter != procChars->dummyArguments.end()) {
+ if (iter != procChars->dummyArguments.end() &&
+ ultimate.name().ToString() != "__builtin_c_funloc") {
return "reference to function '"s + ultimate.name().ToString() +
"' with dummy procedure argument '" + iter->name + '\'';
}
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index b2a50ab9b6b83..a5f4faa0cef8f 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -82,6 +82,8 @@ auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
const Symbol &ultimate{symbol.GetUltimate()};
return !IsNamedConstant(ultimate) &&
(ultimate.has<semantics::ObjectEntityDetails>() ||
+ (ultimate.has<semantics::EntityDetails>() &&
+ ultimate.attrs().test(semantics::Attr::TARGET)) ||
ultimate.has<semantics::AssocEntityDetails>());
}
auto IsVariableHelper::operator()(const Component &x) const -> Result {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 4bb625bfbc2ca..0813562421a29 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -354,7 +354,10 @@ void CheckHelper::Check(const Symbol &symbol) {
messages_.Say(
"A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
}
- if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
+ if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
+ // The intrinsic procedure C_FUNLOC() gets a pass on this check.
+ } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
+ IsDummy(symbol)) {
messages_.Say(
"A dummy procedure of a pure subprogram must be pure"_err_en_US);
}
@@ -463,16 +466,11 @@ void CheckHelper::Check(const Symbol &symbol) {
symbol.name());
}
}
- if (IsProcedure(symbol) && !symbol.HasExplicitInterface()) {
- if (IsAllocatable(symbol)) {
- messages_.Say(
- "Procedure '%s' may not be ALLOCATABLE without an explicit interface"_err_en_US,
- symbol.name());
- } else if (symbol.Rank() > 0) {
- messages_.Say(
- "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
- symbol.name());
- }
+ if (IsProcedure(symbol) && !symbol.HasExplicitInterface() &&
+ symbol.Rank() > 0) {
+ messages_.Say(
+ "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
+ symbol.name());
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index d4fe668b92ec9..88822974e0134 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -661,8 +661,8 @@ class ScopeHandler : public ImplicitRulesVisitor {
void MakeExternal(Symbol &);
// C815 duplicated attribute checking; returns false on error
- bool CheckDuplicatedAttr(SourceName, const Symbol &, Attr);
- bool CheckDuplicatedAttrs(SourceName, const Symbol &, Attrs);
+ bool CheckDuplicatedAttr(SourceName, Symbol &, Attr);
+ bool CheckDuplicatedAttrs(SourceName, Symbol &, Attrs);
void SetExplicitAttr(Symbol &symbol, Attr attr) const {
symbol.attrs().set(attr);
@@ -1087,6 +1087,58 @@ class DeclarationVisitor : public ArraySpecVisitor,
void NoteScalarSpecificationArgument(const Symbol &symbol) {
mustBeScalar_.emplace(symbol);
}
+ // Declare an object or procedure entity.
+ // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
+ template <typename T>
+ Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
+ Symbol &symbol{MakeSymbol(name, attrs)};
+ if (context().HasError(symbol) || symbol.has<T>()) {
+ return symbol; // OK or error already reported
+ } else if (symbol.has<UnknownDetails>()) {
+ symbol.set_details(T{});
+ return symbol;
+ } else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
+ symbol.set_details(T{std::move(*details)});
+ return symbol;
+ } else if (std::is_same_v<EntityDetails, T> &&
+ (symbol.has<ObjectEntityDetails>() ||
+ symbol.has<ProcEntityDetails>())) {
+ return symbol; // OK
+ } else if (auto *details{symbol.detailsIf<UseDetails>()}) {
+ Say(name.source,
+ "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
+ name.source, GetUsedModule(*details).name());
+ } else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) {
+ if (details->kind() == SubprogramKind::Module) {
+ Say2(name,
+ "Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
+ symbol, "Module procedure definition"_en_US);
+ } else if (details->kind() == SubprogramKind::Internal) {
+ Say2(name,
+ "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
+ symbol, "Internal procedure definition"_en_US);
+ } else {
+ DIE("unexpected kind");
+ }
+ } else if (std::is_same_v<ObjectEntityDetails, T> &&
+ symbol.has<ProcEntityDetails>()) {
+ SayWithDecl(
+ name, symbol, "'%s' is already declared as a procedure"_err_en_US);
+ } else if (std::is_same_v<ProcEntityDetails, T> &&
+ symbol.has<ObjectEntityDetails>()) {
+ if (FindCommonBlockContaining(symbol)) {
+ SayWithDecl(name, symbol,
+ "'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
+ } else {
+ SayWithDecl(
+ name, symbol, "'%s' is already declared as an object"_err_en_US);
+ }
+ } else if (!CheckPossibleBadForwardRef(symbol)) {
+ SayAlreadyDeclared(name, symbol);
+ }
+ context().SetError(symbol);
+ return symbol;
+ }
private:
// The attribute corresponding to the statement containing an ObjectDecl
@@ -1151,59 +1203,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool PassesLocalityChecks(
const parser::Name &name, Symbol &symbol, Symbol::Flag flag);
bool CheckForHostAssociatedImplicit(const parser::Name &);
-
- // Declare an object or procedure entity.
- // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
- template <typename T>
- Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
- Symbol &symbol{MakeSymbol(name, attrs)};
- if (context().HasError(symbol) || symbol.has<T>()) {
- return symbol; // OK or error already reported
- } else if (symbol.has<UnknownDetails>()) {
- symbol.set_details(T{});
- return symbol;
- } else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
- symbol.set_details(T{std::move(*details)});
- return symbol;
- } else if (std::is_same_v<EntityDetails, T> &&
- (symbol.has<ObjectEntityDetails>() ||
- symbol.has<ProcEntityDetails>())) {
- return symbol; // OK
- } else if (auto *details{symbol.detailsIf<UseDetails>()}) {
- Say(name.source,
- "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
- name.source, GetUsedModule(*details).name());
- } else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) {
- if (details->kind() == SubprogramKind::Module) {
- Say2(name,
- "Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
- symbol, "Module procedure definition"_en_US);
- } else if (details->kind() == SubprogramKind::Internal) {
- Say2(name,
- "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
- symbol, "Internal procedure definition"_en_US);
- } else {
- DIE("unexpected kind");
- }
- } else if (std::is_same_v<ObjectEntityDetails, T> &&
- symbol.has<ProcEntityDetails>()) {
- SayWithDecl(
- name, symbol, "'%s' is already declared as a procedure"_err_en_US);
- } else if (std::is_same_v<ProcEntityDetails, T> &&
- symbol.has<ObjectEntityDetails>()) {
- if (FindCommonBlockContaining(symbol)) {
- SayWithDecl(name, symbol,
- "'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
- } else {
- SayWithDecl(
- name, symbol, "'%s' is already declared as an object"_err_en_US);
- }
- } else if (!CheckPossibleBadForwardRef(symbol)) {
- SayAlreadyDeclared(name, symbol);
- }
- context().SetError(symbol);
- return symbol;
- }
bool HasCycle(const Symbol &, const Symbol *interface);
bool MustBeScalar(const Symbol &symbol) const {
return mustBeScalar_.find(symbol) != mustBeScalar_.end();
@@ -1624,6 +1623,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
void PreSpecificationConstruct(const parser::SpecificationConstruct &);
void CreateCommonBlockSymbols(const parser::CommonStmt &);
+ void CreateObjectSymbols(const std::list<parser::ObjectDecl> &, Attr);
void CreateGeneric(const parser::GenericSpec &);
void FinishSpecificationPart(const std::list<parser::DeclarationConstruct> &);
void AnalyzeStmtFunctionStmt(const parser::StmtFunctionStmt &);
@@ -2806,12 +2806,13 @@ void ScopeHandler::MakeExternal(Symbol &symbol) {
}
bool ScopeHandler::CheckDuplicatedAttr(
- SourceName name, const Symbol &symbol, Attr attr) {
+ SourceName name, Symbol &symbol, Attr attr) {
if (attr == Attr::SAVE) {
// checked elsewhere
} else if (symbol.attrs().test(attr)) { // C815
if (symbol.implicitAttrs().test(attr)) {
// Implied attribute is now confirmed explicitly
+ symbol.implicitAttrs().reset(attr);
} else {
Say(name, "%s attribute was already specified on '%s'"_err_en_US,
EnumToString(attr), name);
@@ -2822,7 +2823,7 @@ bool ScopeHandler::CheckDuplicatedAttr(
}
bool ScopeHandler::CheckDuplicatedAttrs(
- SourceName name, const Symbol &symbol, Attrs attrs) {
+ SourceName name, Symbol &symbol, Attrs attrs) {
bool ok{true};
attrs.IterateOverMembers(
[&](Attr x) { ok &= CheckDuplicatedAttr(name, symbol, x); });
@@ -5032,6 +5033,10 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
charInfo_.length.reset();
if (symbol.attrs().test(Attr::EXTERNAL)) {
ConvertToProcEntity(symbol);
+ } else if (symbol.attrs().HasAny(Attrs{Attr::ALLOCATABLE,
+ Attr::ASYNCHRONOUS, Attr::CONTIGUOUS, Attr::PARAMETER,
+ Attr::SAVE, Attr::TARGET, Attr::VALUE, Attr::VOLATILE})) {
+ ConvertToObjectEntity(symbol);
}
if (attrs.test(Attr::BIND_C)) {
SetBindNameOn(symbol);
@@ -8551,11 +8556,19 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
}
},
[&](const parser::Statement<parser::OtherSpecificationStmt> &y) {
- if (const auto *commonStmt{parser::Unwrap<parser::CommonStmt>(y)}) {
- CreateCommonBlockSymbols(*commonStmt);
- }
+ common::visit(
+ common::visitors{
+ [&](const common::Indirection<parser::CommonStmt> &z) {
+ CreateCommonBlockSymbols(z.value());
+ },
+ [&](const common::Indirection<parser::TargetStmt> &z) {
+ CreateObjectSymbols(z.value().v, Attr::TARGET);
+ },
+ [](const auto &) {},
+ },
+ y.statement.u);
},
- [&](const auto &) {},
+ [](const auto &) {},
},
spec.u);
}
@@ -8575,6 +8588,15 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols(
}
}
+void ResolveNamesVisitor::CreateObjectSymbols(
+ const std::list<parser::ObjectDecl> &decls, Attr attr) {
+ for (const parser::ObjectDecl &decl : decls) {
+ SetImplicitAttr(DeclareEntity<ObjectEntityDetails>(
+ std::get<parser::ObjectName>(decl.t), Attrs{}),
+ attr);
+ }
+}
+
void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
auto info{GenericSpecInfo{x}};
SourceName symbolName{info.symbolName()};
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index b33d843710127..44b0f17339cd9 100644
--- a/flang/module/__fortran_builtins.f90
+++ b/flang/module/__fortran_builtins.f90
@@ -182,7 +182,10 @@
__builtin_c_ptr_ne = x%__address /= y%__address
end function
- function __builtin_c_funloc(x)
+ ! Semantics has some special-case code that allows c_funloc()
+ ! to appear in a specification expression and exempts it
+ ! from the requirement that "x" be a pure dummy procedure.
+ pure function __builtin_c_funloc(x)
type(__builtin_c_funptr) :: __builtin_c_funloc
external :: x
__builtin_c_funloc = __builtin_c_funptr(loc(x))
diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90
index 7c9e294172993..83b88d2ebd4b0 100644
--- a/flang/test/Semantics/c_loc01.f90
+++ b/flang/test/Semantics/c_loc01.f90
@@ -4,7 +4,10 @@ module m
type haslen(L)
integer, len :: L
end type
+ integer, target :: targ
contains
+ subroutine subr
+ end
subroutine test(assumedType, poly, nclen)
type(*), target :: assumedType
class(*), target :: poly
@@ -17,6 +20,8 @@ subroutine test(assumedType, poly, nclen)
type(hasLen(1)), target :: clen
type(hasLen(*)), target :: nclen
character(2), target :: ch
+ real :: arr1(purefun1(c_loc(targ))) ! ok
+ real :: arr2(purefun2(c_funloc(subr))) ! ok
!ERROR: C_LOC() argument must be a data pointer or target
cp = c_loc(notATarget)
!ERROR: C_LOC() argument must be a data pointer or target
@@ -44,4 +49,12 @@ subroutine test(assumedType, poly, nclen)
!ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_funptr) and TYPE(c_ptr)
cfp = cp
end
+ pure integer function purefun1(p)
+ type(c_ptr), intent(in) :: p
+ purefun1 = 1
+ end
+ pure integer function purefun2(p)
+ type(c_funptr), intent(in) :: p
+ purefun2 = 1
+ end
end module
diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90
index 71f2197067f76..8a4386e28e2bc 100644
--- a/flang/test/Semantics/call05.f90
+++ b/flang/test/Semantics/call05.f90
@@ -123,9 +123,7 @@ subroutine test
module m2
- !ERROR: Procedure 't3' may not be ALLOCATABLE without an explicit interface
character(len=10), allocatable :: t1, t2, t3, t4
- !ERROR: Procedure 't6' may not be ALLOCATABLE without an explicit interface
character(len=:), allocatable :: t5, t6, t7, t8(:)
character(len=10), pointer :: p1
@@ -189,7 +187,7 @@ subroutine test()
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
call sma(t2(:))
- !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ !ERROR: 't3' is not a callable procedure
call sma(t3(1))
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
@@ -208,7 +206,7 @@ subroutine test()
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
call sma(t5(:))
- !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ !ERROR: 't6' is not a callable procedure
call sma(t6(1))
!ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
More information about the flang-commits
mailing list