[flang-commits] [flang] cfd474e - [flang] Enforce C1552, no binding labels allowed for internal procedures
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Tue Jun 28 11:00:24 PDT 2022
Author: Peter Klausler
Date: 2022-06-28T11:00:12-07:00
New Revision: cfd474e0d036877ee6c83d236df71aa8fe0729bf
URL: https://github.com/llvm/llvm-project/commit/cfd474e0d036877ee6c83d236df71aa8fe0729bf
DIFF: https://github.com/llvm/llvm-project/commit/cfd474e0d036877ee6c83d236df71aa8fe0729bf.diff
LOG: [flang] Enforce C1552, no binding labels allowed for internal procedures
If BIND(C) appears on an internal procedure, it must have a null binding
label, i.e. BIND(C,NAME="").
Also address conflicts with D127725 which was merged during development.
Differential Revision: https://reviews.llvm.org/D128676
Added:
flang/test/Semantics/bind-c05.f90
Modified:
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/bind-c01.f90
flang/test/Semantics/bind-c04.f90
flang/test/Semantics/declarations03.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 809d68a7efe28..96f6a4d8ce36e 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1869,10 +1869,8 @@ void CheckHelper::CheckGenericOps(const Scope &scope) {
static const std::string *DefinesBindCName(const Symbol &symbol) {
const auto *subp{symbol.detailsIf<SubprogramDetails>()};
- if ((subp && !subp->isInterface() &&
- ClassifyProcedure(symbol) != ProcedureDefinitionClass::Internal) ||
- symbol.has<ObjectEntityDetails>() || symbol.has<CommonBlockDetails>() ||
- symbol.has<ProcEntityDetails>()) {
+ if ((subp && !subp->isInterface()) || symbol.has<ObjectEntityDetails>() ||
+ symbol.has<CommonBlockDetails>()) {
// Symbol defines data or entry point
return symbol.GetBindName();
} else {
@@ -1893,14 +1891,15 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
auto pair{bindC_.emplace(*name, symbol)};
if (!pair.second) {
const Symbol &other{*pair.first->second};
- // Two common blocks with the same name can have the same BIND(C) name.
- if ((!symbol.has<CommonBlockDetails>() ||
- symbol.name() != other.name()) &&
- DefinesBindCName(other) && !context_.HasError(other)) {
+ if (symbol.has<CommonBlockDetails>() && other.has<CommonBlockDetails>() &&
+ symbol.name() == other.name()) {
+ // Two common blocks can have the same BIND(C) name so long as
+ // they're not in the same scope.
+ } else if (!context_.HasError(other)) {
if (auto *msg{messages_.Say(symbol.name(),
- "Two symbols have the same BIND(C) name '%s'"_err_en_US,
+ "Two entities have the same BIND(C) name '%s'"_err_en_US,
*name)}) {
- msg->Attach(other.name(), "Conflicting symbol"_en_US);
+ msg->Attach(other.name(), "Conflicting declaration"_en_US);
}
context_.SetError(symbol);
context_.SetError(other);
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 875d86d9870b1..4da79c3c71713 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1662,12 +1662,18 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
}
std::optional<std::string> label{
evaluate::GetScalarConstantValue<evaluate::Ascii>(bindName_)};
- // 18.9.2(2): discard leading and trailing blanks, ignore if all blank
+ if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
+ if (label) { // C1552: no NAME= allowed even if null
+ Say(symbol.name(),
+ "An internal procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
+ }
+ return;
+ }
+ // 18.9.2(2): discard leading and trailing blanks
if (label) {
auto first{label->find_first_not_of(" ")};
if (first == std::string::npos) {
// Empty NAME= means no binding at all (18.10.2p2)
- Say(currStmtSource().value(), "Blank binding label ignored"_warn_en_US);
return;
}
auto last{label->find_last_not_of(" ")};
@@ -4172,10 +4178,10 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
SetType(name, *type);
}
charInfo_.length.reset();
- SetBindNameOn(symbol);
if (symbol.attrs().test(Attr::EXTERNAL)) {
ConvertToProcEntity(symbol);
}
+ SetBindNameOn(symbol);
return symbol;
}
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 67016693716b3..1a46e87ff4720 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1091,7 +1091,9 @@ const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) {
ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
const Symbol &ultimate{symbol.GetUltimate()};
- if (ultimate.attrs().test(Attr::INTRINSIC)) {
+ if (!IsProcedure(ultimate)) {
+ return ProcedureDefinitionClass::None;
+ } else if (ultimate.attrs().test(Attr::INTRINSIC)) {
return ProcedureDefinitionClass::Intrinsic;
} else if (ultimate.attrs().test(Attr::EXTERNAL)) {
return ProcedureDefinitionClass::External;
diff --git a/flang/test/Semantics/bind-c01.f90 b/flang/test/Semantics/bind-c01.f90
index 65940540dfab3..6e3824d6698a1 100644
--- a/flang/test/Semantics/bind-c01.f90
+++ b/flang/test/Semantics/bind-c01.f90
@@ -3,14 +3,14 @@
module m1
integer, bind(c, name="x1") :: x1
- !ERROR: Two symbols have the same BIND(C) name 'x1'
+ !ERROR: Two entities have the same BIND(C) name 'x1'
integer, bind(c, name=" x1 ") :: x2
contains
subroutine x3() bind(c, name="x3")
end subroutine
end module
-!ERROR: Two symbols have the same BIND(C) name 'x3'
+!ERROR: Two entities have the same BIND(C) name 'x3'
subroutine x4() bind(c, name=" x3 ")
end subroutine
diff --git a/flang/test/Semantics/bind-c04.f90 b/flang/test/Semantics/bind-c04.f90
index 2be6b54f0ee0f..b9b766bd97f05 100644
--- a/flang/test/Semantics/bind-c04.f90
+++ b/flang/test/Semantics/bind-c04.f90
@@ -11,7 +11,7 @@ subroutine proc() bind(c)
end
end interface
- !ERROR: Two symbols have the same BIND(C) name 'aaa'
+ !Acceptable (as an extension)
procedure(proc), bind(c, name="aaa") :: pc1, pc2
!ERROR: BIND(C) procedure with NAME= specified can neither have POINTER attribute nor be a dummy procedure
diff --git a/flang/test/Semantics/bind-c05.f90 b/flang/test/Semantics/bind-c05.f90
new file mode 100644
index 0000000000000..2924d54a99ab4
--- /dev/null
+++ b/flang/test/Semantics/bind-c05.f90
@@ -0,0 +1,13 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for C1552
+program main
+ contains
+ subroutine internal1() bind(c) ! ok
+ end subroutine
+ !ERROR: An internal procedure may not have a BIND(C,NAME=) binding label
+ subroutine internal2() bind(c,name="internal2")
+ end subroutine
+ !ERROR: An internal procedure may not have a BIND(C,NAME=) binding label
+ subroutine internal3() bind(c,name="")
+ end subroutine
+end
diff --git a/flang/test/Semantics/declarations03.f90 b/flang/test/Semantics/declarations03.f90
index cf6d44374a1ba..11de6dc870009 100644
--- a/flang/test/Semantics/declarations03.f90
+++ b/flang/test/Semantics/declarations03.f90
@@ -5,17 +5,17 @@ module m
integer :: x, y, z, w, i, j, k
- !ERROR: Two symbols have the same BIND(C) name 'aa'
+ !ERROR: Two entities have the same BIND(C) name 'aa'
common /blk1/ x, /blk2/ y
bind(c, name="aa") :: /blk1/, /blk2/
integer :: t
- !ERROR: Two symbols have the same BIND(C) name 'bb'
+ !ERROR: Two entities have the same BIND(C) name 'bb'
common /blk3/ z
bind(c, name="bb") :: /blk3/, t
integer :: t2
- !ERROR: Two symbols have the same BIND(C) name 'cc'
+ !ERROR: Two entities have the same BIND(C) name 'cc'
common /blk4/ w
bind(c, name="cc") :: t2, /blk4/
@@ -24,7 +24,7 @@ module m
bind(c, name="dd") :: /blk5/
bind(c, name="ee") :: /blk5/
- !ERROR: Two symbols have the same BIND(C) name 'ff'
+ !ERROR: Two entities have the same BIND(C) name 'ff'
common /blk6/ j, /blk7/ k
bind(c, name="ff") :: /blk6/
bind(c, name="ff") :: /blk7/
@@ -34,7 +34,7 @@ module m
bind(c, name="gg") :: s1
bind(c, name="hh") :: s1
- !ERROR: Two symbols have the same BIND(C) name 'ii'
+ !ERROR: Two entities have the same BIND(C) name 'ii'
integer :: s2, s3
bind(c, name="ii") :: s2
bind(c, name="ii") :: s3
@@ -66,6 +66,6 @@ module a
end module
module b
- !ERROR: Two symbols have the same BIND(C) name 'int'
+ !ERROR: Two entities have the same BIND(C) name 'int'
integer, bind(c, name="int") :: i
end module
More information about the flang-commits
mailing list