diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -1869,10 +1869,8 @@ static const std::string *DefinesBindCName(const Symbol &symbol) { const auto *subp{symbol.detailsIf()}; - if ((subp && !subp->isInterface() && - ClassifyProcedure(symbol) != ProcedureDefinitionClass::Internal) || - symbol.has() || symbol.has() || - symbol.has()) { + if ((subp && !subp->isInterface()) || symbol.has() || + symbol.has()) { // Symbol defines data or entry point return symbol.GetBindName(); } else { @@ -1893,14 +1891,15 @@ 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() || - symbol.name() != other.name()) && - DefinesBindCName(other) && !context_.HasError(other)) { + if (symbol.has() && other.has() && + 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 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1662,12 +1662,18 @@ } std::optional label{ evaluate::GetScalarConstantValue(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 @@ 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 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -1091,7 +1091,9 @@ 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 --- 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 --- a/flang/test/Semantics/bind-c04.f90 +++ b/flang/test/Semantics/bind-c04.f90 @@ -11,7 +11,7 @@ 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 --- /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 --- a/flang/test/Semantics/declarations03.f90 +++ b/flang/test/Semantics/declarations03.f90 @@ -5,17 +5,17 @@ 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 @@ 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 @@ 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 @@ 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