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 @@ -113,6 +113,7 @@ return msg; } bool IsResultOkToDiffer(const FunctionResult &); + void CheckGlobalName(const Symbol &); void CheckBindC(const Symbol &); void CheckBindCFunctionResult(const Symbol &); // Check functions for defined I/O procedures @@ -154,11 +155,11 @@ // Cache of calls to Procedure::Characterize(Symbol) std::map, SymbolAddressCompare> characterizeCache_; - // Collection of symbols with BIND(C) names - std::map bindC_; // Collection of module procedure symbols with non-BIND(C) // global names, qualified by their module. std::map, SymbolRef> moduleProcs_; + // Collection of symbols with global names, BIND(C) or otherwise + std::map globalNames_; // Derived types that have defined input/output procedures std::vector seenDefinedIoTypes_; }; @@ -253,6 +254,7 @@ CheckVolatile(symbol, derived); } CheckBindC(symbol); + CheckGlobalName(symbol); if (isDone) { return; // following checks do not apply } @@ -316,7 +318,9 @@ if (type) { // Section 7.2, paragraph 7 bool canHaveAssumedParameter{IsNamedConstant(symbol) || (IsAssumedLengthCharacter(symbol) && // C722 - IsExternal(symbol)) || + (IsExternal(symbol) || + ClassifyProcedure(symbol) == + ProcedureDefinitionClass::Dummy)) || symbol.test(Symbol::Flag::ParentComp)}; if (!IsStmtFunctionDummy(symbol)) { // C726 if (const auto *object{symbol.detailsIf()}) { @@ -351,7 +355,7 @@ } } } - if (IsAssumedLengthCharacter(symbol) && IsExternal(symbol)) { // C723 + if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723 if (symbol.attrs().test(Attr::RECURSIVE)) { messages_.Say( "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US); @@ -360,21 +364,24 @@ messages_.Say( "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US); } - if (IsElementalProcedure(symbol)) { - messages_.Say( - "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US); - } else if (IsPureProcedure(symbol)) { - messages_.Say( - "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US); + if (!IsStmtFunction(symbol)) { + if (IsElementalProcedure(symbol)) { + messages_.Say( + "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US); + } else if (IsPureProcedure(symbol)) { + messages_.Say( + "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US); + } } if (const Symbol *result{FindFunctionResult(symbol)}) { if (IsPointer(*result)) { messages_.Say( "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US); } - } else if (IsPointer(symbol)) { + } else if (IsProcedurePointer(symbol) && IsDummy(symbol)) { messages_.Say( - "A procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US); + "A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US); + // The non-dummy case is a hard error that's caught elsewhere. } } if (symbol.attrs().test(Attr::VALUE)) { @@ -420,7 +427,10 @@ } } -void CheckHelper::CheckCommonBlock(const Symbol &symbol) { CheckBindC(symbol); } +void CheckHelper::CheckCommonBlock(const Symbol &symbol) { + CheckGlobalName(symbol); + CheckBindC(symbol); +} void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553 if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) { @@ -1060,7 +1070,7 @@ } void CheckHelper::CheckLocalVsGlobal(const Symbol &symbol) { - if (IsProcedure(symbol) && IsExternal(symbol)) { + if (IsExternal(symbol)) { if (const Symbol *global{FindGlobal(symbol)}; global && global != &symbol) { std::string interfaceName{symbol.name().ToString()}; if (const auto *bind{symbol.GetBindName()}) { @@ -1095,8 +1105,13 @@ } } } - evaluate::AttachDeclaration(msg, *global); - evaluate::AttachDeclaration(msg, symbol); + if (msg) { + if (msg->IsFatal()) { + context_.SetError(symbol); + } + evaluate::AttachDeclaration(msg, *global); + evaluate::AttachDeclaration(msg, symbol); + } } } } @@ -2080,14 +2095,75 @@ helper.Check(scope); } -static const std::string *DefinesBindCName(const Symbol &symbol) { +static bool IsSubprogramDefinition(const Symbol &symbol) { const auto *subp{symbol.detailsIf()}; - if ((subp && !subp->isInterface()) || symbol.has() || - symbol.has()) { - // Symbol defines data or entry point - return symbol.GetBindName(); + return subp && !subp->isInterface() && symbol.scope() && + symbol.scope()->kind() == Scope::Kind::Subprogram; +} + +static bool IsBlockData(const Symbol &symbol) { + return symbol.scope() && symbol.scope()->kind() == Scope::Kind::BlockData; +} + +static bool IsExternalProcedureDefinition(const Symbol &symbol) { + return IsBlockData(symbol) || + (IsSubprogramDefinition(symbol) && + (IsExternal(symbol) || symbol.GetBindName())); +} + +static std::optional DefinesGlobalName(const Symbol &symbol) { + if (const auto *module{symbol.detailsIf()}) { + if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) { + return symbol.name().ToString(); + } + } else if (IsBlockData(symbol)) { + return symbol.name().ToString(); } else { - return nullptr; + const std::string *bindC{symbol.GetBindName()}; + if (symbol.has() || + IsExternalProcedureDefinition(symbol)) { + return bindC ? *bindC : symbol.name().ToString(); + } else if (bindC && + (symbol.has() || IsModuleProcedure(symbol))) { + return *bindC; + } + } + return std::nullopt; +} + +// 19.2 p2 +void CheckHelper::CheckGlobalName(const Symbol &symbol) { + if (auto global{DefinesGlobalName(symbol)}) { + auto pair{globalNames_.emplace(std::move(*global), symbol)}; + if (!pair.second) { + const Symbol &other{*pair.first->second}; + if (context_.HasError(symbol) || context_.HasError(other)) { + // don't pile on + } else if (symbol.has() && + other.has() && symbol.name() == other.name()) { + // Two common blocks can have the same global name so long as + // they're not in the same scope. + } else if ((IsProcedure(symbol) || IsBlockData(symbol)) && + (IsProcedure(other) || IsBlockData(other)) && + (!IsExternalProcedureDefinition(symbol) || + !IsExternalProcedureDefinition(other))) { + // both are procedures/BLOCK DATA, not both definitions + } else if (symbol.has()) { + messages_.Say(symbol.name(), + "Module '%s' conflicts with a global name"_port_en_US, + pair.first->first); + } else if (other.has()) { + messages_.Say(symbol.name(), + "Global name '%s' conflicts with a module"_port_en_US, + pair.first->first); + } else if (auto *msg{messages_.Say(symbol.name(), + "Two entities have the same global name '%s'"_err_en_US, + pair.first->first)}) { + msg->Attach(other.name(), "Conflicting declaration"_en_US); + context_.SetError(symbol); + context_.SetError(other); + } + } } } @@ -2102,25 +2178,6 @@ "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US); context_.SetError(symbol); } - if (const std::string *name{DefinesBindCName(symbol)}) { - auto pair{bindC_.emplace(*name, symbol)}; - if (!pair.second) { - const Symbol &other{*pair.first->second}; - 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 entities have the same BIND(C) name '%s'"_err_en_US, - *name)}) { - msg->Attach(other.name(), "Conflicting declaration"_en_US); - } - context_.SetError(symbol); - context_.SetError(other); - } - } - } if (const auto *proc{symbol.detailsIf()}) { if (!proc->procInterface() || !proc->procInterface()->attrs().test(Attr::BIND_C)) { 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 @@ -2541,7 +2541,7 @@ if (IsFunctionResult(symbol) && !(IsPointer(symbol) && symbol.attrs().test(Attr::EXTERNAL))) { // Don't turn function result into a procedure pointer unless both - // POUNTER and EXTERNAL + // POINTER and EXTERNAL return false; } funcResultStack_.CompleteTypeIfFunctionResult(symbol); @@ -3242,6 +3242,8 @@ case ProcedureDefinitionClass::Intrinsic: case ProcedureDefinitionClass::External: case ProcedureDefinitionClass::Internal: + case ProcedureDefinitionClass::Dummy: + case ProcedureDefinitionClass::Pointer: break; case ProcedureDefinitionClass::None: Say(*name, "'%s' is not a procedure"_err_en_US); 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 @@ -1042,14 +1042,12 @@ return ProcedureDefinitionClass::None; } else if (ultimate.attrs().test(Attr::INTRINSIC)) { return ProcedureDefinitionClass::Intrinsic; + } else if (IsDummy(ultimate)) { + return ProcedureDefinitionClass::Dummy; + } else if (IsProcedurePointer(symbol)) { + return ProcedureDefinitionClass::Pointer; } else if (ultimate.attrs().test(Attr::EXTERNAL)) { return ProcedureDefinitionClass::External; - } else if (const auto *procDetails{ultimate.detailsIf()}) { - if (procDetails->isDummy()) { - return ProcedureDefinitionClass::Dummy; - } else if (IsPointer(ultimate)) { - return ProcedureDefinitionClass::Pointer; - } } else if (const auto *nameDetails{ ultimate.detailsIf()}) { switch (nameDetails->kind()) { diff --git a/flang/test/Lower/pointer-initial-target-2.f90 b/flang/test/Lower/pointer-initial-target-2.f90 --- a/flang/test/Lower/pointer-initial-target-2.f90 +++ b/flang/test/Lower/pointer-initial-target-2.f90 @@ -36,7 +36,7 @@ end block data ! Test pointer in a common with initial target in the same common. -block data snake +block data bdsnake integer, target :: b = 42 integer, pointer :: p => b common /snake/ p, b 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 entities have the same BIND(C) name 'x1' + !ERROR: Two entities have the same global name 'x1' integer, bind(c, name=" x1 ") :: x2 contains subroutine x3() bind(c, name="x3") end subroutine end module -!ERROR: Two entities have the same BIND(C) name 'x3' +!ERROR: Two entities have the same global name 'x3' subroutine x4() bind(c, name=" x3 ") end subroutine diff --git a/flang/test/Semantics/bind-c02.f90 b/flang/test/Semantics/bind-c02.f90 --- a/flang/test/Semantics/bind-c02.f90 +++ b/flang/test/Semantics/bind-c02.f90 @@ -18,6 +18,7 @@ !ERROR: Only variable and named common block can be in BIND statement bind(c) :: sub + !PORTABILITY: Global name 'm' conflicts with a module !PORTABILITY: Name 'm' declared in a module should not have the same name as the module bind(c) :: m ! no error for implicit type variable diff --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90 --- a/flang/test/Semantics/call01.f90 +++ b/flang/test/Semantics/call01.f90 @@ -119,11 +119,11 @@ end function subroutine s01(f1, f2, fp1, fp2) - !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type + !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type character*(*) :: f1, f3, fp1 external :: f1, f3 pointer :: fp1 - !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type + !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type procedure(character*(*)), pointer :: fp2 interface character*(*) function f2() diff --git a/flang/test/Semantics/call31.f90 b/flang/test/Semantics/call31.f90 --- a/flang/test/Semantics/call31.f90 +++ b/flang/test/Semantics/call31.f90 @@ -4,9 +4,9 @@ module m contains subroutine subr(parg) - !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type + !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type procedure(character(*)), pointer :: parg - !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type + !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result procedure(character(*)), pointer :: plocal print *, parg() plocal => parg @@ -14,7 +14,7 @@ end subroutine subroutine subr_1(parg_1) - !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type + !PORTABILITY: A dummy procedure pointer should not have assumed-length CHARACTER(*) result type procedure(character(*)), pointer :: parg_1 print *, parg_1() end subroutine 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 entities have the same BIND(C) name 'aa' + !ERROR: Two entities have the same global name 'aa' common /blk1/ x, /blk2/ y bind(c, name="aa") :: /blk1/, /blk2/ integer :: t - !ERROR: Two entities have the same BIND(C) name 'bb' + !ERROR: Two entities have the same global name 'bb' common /blk3/ z bind(c, name="bb") :: /blk3/, t integer :: t2 - !ERROR: Two entities have the same BIND(C) name 'cc' + !ERROR: Two entities have the same global 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 entities have the same BIND(C) name 'ff' + !ERROR: Two entities have the same global 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 entities have the same BIND(C) name 'ii' + !ERROR: Two entities have the same global 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 entities have the same BIND(C) name 'int' + !ERROR: Two entities have the same global name 'int' integer, bind(c, name="int") :: i end module diff --git a/flang/test/Semantics/declarations04.f90 b/flang/test/Semantics/declarations04.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/declarations04.f90 @@ -0,0 +1,25 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! test global name conflicts + +subroutine ext1 +end + +subroutine ext2 + !ERROR: Two entities have the same global name 'ext1' + common /ext1/ x +end + +module ext4 + contains + !ERROR: Two entities have the same global name 'ext2' + subroutine foo() bind(c,name="ext2") + end + !ERROR: Two entities have the same global name 'ext3' + subroutine bar() bind(c,name="ext3") + end +end + +block data ext3 + !PORTABILITY: Global name 'ext4' conflicts with a module + common /ext4/ x +end