diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h index a58163f5460c2..e73a507e9b3f5 100644 --- a/flang/include/flang/Semantics/scope.h +++ b/flang/include/flang/Semantics/scope.h @@ -138,6 +138,8 @@ class Scope { const_iterator cend() const { return symbols_.cend(); } // Return symbols in declaration order (the iterators above are in name order) + // When a generic procedure interface shadows a derived type or specific + // procedure, only the generic's symbol appears in the output. SymbolVector GetSymbols() const; MutableSymbolVector GetSymbols(); diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp index d9a9576e9d676..b5a58ddca0ecd 100644 --- a/flang/lib/Semantics/compute-offsets.cpp +++ b/flang/lib/Semantics/compute-offsets.cpp @@ -114,6 +114,13 @@ void ComputeOffsetsHelper::Compute(Scope &scope) { dependents_.find(symbol) == dependents_.end() && equivalenceBlock_.find(symbol) == equivalenceBlock_.end()) { DoSymbol(*symbol); + if (auto *generic{symbol->detailsIf()}) { + if (Symbol * specific{generic->specific()}; + specific && !FindCommonBlockContaining(*specific)) { + // might be a shadowed procedure pointer + DoSymbol(*specific); + } + } } } // Ensure that the size is a multiple of the alignment diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 3684839c187e6..5e4174a557af6 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -210,7 +210,8 @@ class ArgumentAnalyzer { // or procedure pointer reference in a ProcedureDesignator. MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) { const Symbol &last{ref.GetLastSymbol()}; - const Symbol &symbol{BypassGeneric(last).GetUltimate()}; + const Symbol &specific{BypassGeneric(last)}; + const Symbol &symbol{specific.GetUltimate()}; if (semantics::IsProcedure(symbol)) { if (symbol.attrs().test(semantics::Attr::ABSTRACT)) { Say("Abstract procedure interface '%s' may not be used as a designator"_err_en_US, @@ -226,6 +227,10 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) { } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) { if (symbol.has()) { Say("'%s' is not a specific procedure"_err_en_US, last.name()); + } else if (IsProcedurePointer(specific)) { + // For procedure pointers, retain associations so that data accesses + // from client modules will work. + return Expr{ProcedureDesignator{specific}}; } else { return Expr{ProcedureDesignator{symbol}}; } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 2e86e0afc9bd0..a2bdeb3990155 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -618,6 +618,20 @@ class ScopeHandler : public ImplicitRulesVisitor { return *derivedType; } } + } else if constexpr (std::is_same_v) { + if (auto *d{symbol->detailsIf()}) { + if (!d->derivedType()) { + // procedure pointer with same name as a generic + auto *specific{d->specific()}; + if (!specific) { + specific = &currScope().MakeSymbol(name, attrs, std::move(details)); + d->set_specific(*specific); + } else { + SayAlreadyDeclared(name, *specific); + } + return *specific; + } + } } if (symbol->CanReplaceDetails(details)) { // update the existing symbol @@ -3035,14 +3049,26 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, return; } const Symbol &useUltimate{useSymbol.GetUltimate()}; + const auto *useGeneric{useUltimate.detailsIf()}; if (localSymbol->has()) { - localSymbol->set_details(UseDetails{localName, useSymbol}); - localSymbol->attrs() = - useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE, Attr::SAVE}; - localSymbol->implicitAttrs() = - localSymbol->attrs() & Attrs{Attr::ASYNCHRONOUS, Attr::VOLATILE}; - localSymbol->flags() = useSymbol.flags(); - return; + if (useGeneric && useGeneric->specific() && + IsProcedurePointer(*useGeneric->specific())) { + // We are use-associating a generic that shadows a procedure pointer. + // Local references that might be made to that procedure pointer should + // use a UseDetails symbol for proper data addressing. So create an + // empty local generic now into which the use-associated generic may + // be copied. + localSymbol->set_details(GenericDetails{}); + localSymbol->get().set_kind(useGeneric->kind()); + } else { // just create UseDetails + localSymbol->set_details(UseDetails{localName, useSymbol}); + localSymbol->attrs() = + useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE, Attr::SAVE}; + localSymbol->implicitAttrs() = + localSymbol->attrs() & Attrs{Attr::ASYNCHRONOUS, Attr::VOLATILE}; + localSymbol->flags() = useSymbol.flags(); + return; + } } Symbol &localUltimate{localSymbol->GetUltimate()}; @@ -3066,10 +3092,7 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, // - anything other than a derived type, non-generic procedure, or // generic procedure being combined with something other than an // prior USE association of itself - auto *localGeneric{localUltimate.detailsIf()}; - const auto *useGeneric{useUltimate.detailsIf()}; - Symbol *localDerivedType{nullptr}; if (localUltimate.has()) { localDerivedType = &localUltimate; @@ -3261,6 +3284,15 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, // At this point, there must be at least one generic interface. CHECK(localGeneric || (useGeneric && (localDerivedType || localProcedure))); + // Ensure that a use-associated specific procedure that is a procedure + // pointer is properly represented as a USE association of an entity. + if (IsProcedurePointer(useProcedure)) { + Symbol &combined{currScope().MakeSymbol(localSymbol->name(), + useProcedure->attrs(), UseDetails{localName, *useProcedure})}; + combined.flags() |= useProcedure->flags(); + combinedProcedure = &combined; + } + if (localGeneric) { // Create a local copy of a previously use-associated generic so that // it can be locally extended without corrupting the original. @@ -5079,7 +5111,22 @@ bool DeclarationVisitor::HasCycle( Symbol &DeclarationVisitor::DeclareProcEntity( const parser::Name &name, Attrs attrs, const Symbol *interface) { - Symbol &symbol{DeclareEntity(name, attrs)}; + Symbol *proc{nullptr}; + if (auto *extant{FindInScope(name)}) { + if (auto *d{extant->detailsIf()}; d && !d->derivedType()) { + // procedure pointer with same name as a generic + if (auto *specific{d->specific()}) { + SayAlreadyDeclared(name, *specific); + } else { + // Create the ProcEntityDetails symbol in the scope as the "specific()" + // symbol behind an existing GenericDetails symbol of the same name. + proc = &Resolve(name, + currScope().MakeSymbol(name.source, attrs, ProcEntityDetails{})); + d->set_specific(*proc); + } + } + } + Symbol &symbol{proc ? *proc : DeclareEntity(name, attrs)}; if (auto *details{symbol.detailsIf()}) { if (context().HasError(symbol)) { } else if (HasCycle(symbol, interface)) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index b593bf89b18bc..14d6564664f2c 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -210,8 +210,9 @@ const Symbol *GenericDetails::CheckSpecific() const { } Symbol *GenericDetails::CheckSpecific() { if (specific_ && !specific_->has()) { + const Symbol &ultimate{specific_->GetUltimate()}; for (const Symbol &proc : specificProcs_) { - if (&proc == specific_) { + if (&proc.GetUltimate() == &ultimate) { return nullptr; } } diff --git a/flang/test/Semantics/generic10.f90 b/flang/test/Semantics/generic10.f90 new file mode 100644 index 0000000000000..203d0bb855208 --- /dev/null +++ b/flang/test/Semantics/generic10.f90 @@ -0,0 +1,17 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +module m + procedure(func), pointer :: foo + interface foo + procedure :: foo + end interface + contains + function func(x) + func = x + end +end + +program main + use m +!CHECK: foo => func + foo => func +end