diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 03d4310466485..6c6588025a392 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -641,6 +641,10 @@ module m end ``` +* When an intrinsic procedure appears in the specification part of a module + only in function references, but not an explicit `INTRINSIC` statement, + its name is not brought into other scopes by a `USE` statement. + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index e1cd34ddf65b6..f5f7b99aba255 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -2904,7 +2904,7 @@ void ModuleVisitor::Post(const parser::UseStmt &x) { } for (const auto &[name, symbol] : *useModuleScope_) { if (symbol->attrs().test(Attr::PUBLIC) && !IsUseRenamed(symbol->name()) && - (!symbol->attrs().test(Attr::INTRINSIC) || + (!symbol->implicitAttrs().test(Attr::INTRINSIC) || symbol->has()) && !symbol->has() && useNames.count(name) == 0) { SourceName location{x.moduleName.source}; @@ -2998,7 +2998,7 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, details->add_occurrence(location, *useModuleScope_); return; } - + const Symbol &useUltimate{useSymbol.GetUltimate()}; if (localSymbol.has()) { localSymbol.set_details(UseDetails{localName, useSymbol}); localSymbol.attrs() = @@ -3010,7 +3010,6 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, } Symbol &localUltimate{localSymbol.GetUltimate()}; - const Symbol &useUltimate{useSymbol.GetUltimate()}; if (&localUltimate == &useUltimate) { // use-associating the same symbol again -- ok return; @@ -3044,13 +3043,19 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, checkAmbiguousDerivedType(&useUltimate, localGeneric->derivedType()); } else if (&useUltimate == &BypassGeneric(localUltimate).GetUltimate()) { return; // nothing to do; used subprogram is local's specific + } else if (useUltimate.attrs().test(Attr::INTRINSIC) && + useUltimate.name() == localSymbol.name()) { + return; // local generic can extend intrinsic } } else if (useGeneric) { if (localUltimate.has()) { combine = checkAmbiguousDerivedType(&localUltimate, useGeneric->derivedType()); - } else if (&localUltimate == &BypassGeneric(useUltimate).GetUltimate()) { - // Local is the specific of the used generic; replace it. + } else if (&localUltimate == &BypassGeneric(useUltimate).GetUltimate() || + (localSymbol.attrs().test(Attr::INTRINSIC) && + localUltimate.name() == useUltimate.name())) { + // Local is the specific of the used generic or an intrinsic with the + // same name; replace it. EraseSymbol(localSymbol); Symbol &newSymbol{MakeSymbol(localName, useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE}, @@ -3058,23 +3063,22 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, newSymbol.flags() = useSymbol.flags(); return; } + } else if (localUltimate.name() != useUltimate.name()) { + // not the same procedure + } else if (localUltimate.attrs().test(Attr::INTRINSIC) && + useUltimate.attrs().test(Attr::INTRINSIC)) { + return; } else { auto localClass{ClassifyProcedure(localUltimate)}; auto useClass{ClassifyProcedure(useUltimate)}; - if (localClass == useClass && - (localClass == ProcedureDefinitionClass::Intrinsic || - localClass == ProcedureDefinitionClass::External) && - localUltimate.name() == useUltimate.name()) { + if (localClass == ProcedureDefinitionClass::External && + useClass == ProcedureDefinitionClass::External) { auto localChars{evaluate::characteristics::Procedure::Characterize( localUltimate, GetFoldingContext())}; auto useChars{evaluate::characteristics::Procedure::Characterize( useUltimate, GetFoldingContext())}; - if (localChars && useChars) { - if (*localChars == *useChars) { - // Same intrinsic or external procedure defined identically in two - // modules - return; - } + if (localChars && useChars && *localChars == *useChars) { + return; // same procedure defined identically in two modules } } } @@ -4794,9 +4798,15 @@ Symbol &DeclarationVisitor::HandleAttributeStmt( } } } else if (symbol && symbol->has()) { - Say(currStmtSource().value(), - "Cannot change %s attribute on use-associated '%s'"_err_en_US, - EnumToString(attr), name.source); + if (symbol->GetUltimate().attrs().test(attr)) { + Say(currStmtSource().value(), + "Use-associated '%s' already has '%s' attribute"_warn_en_US, + name.source, EnumToString(attr)); + } else { + Say(currStmtSource().value(), + "Cannot change %s attribute on use-associated '%s'"_err_en_US, + EnumToString(attr), name.source); + } return *symbol; } if (!symbol) { @@ -6244,8 +6254,8 @@ bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction( // recreated for it later on demand, but capturing its result type here // will make GetType() return a correct result without having to // probe the intrinsics table again. - Symbol &symbol{ - MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})}; + Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})}; + SetImplicitAttr(symbol, Attr::INTRINSIC); CHECK(interface->functionResult.has_value()); evaluate::DynamicType dyType{ DEREF(interface->functionResult->GetTypeAndShape()).type()}; @@ -7708,8 +7718,8 @@ void ResolveNamesVisitor::HandleProcedureName( auto *symbol{FindSymbol(NonDerivedTypeScope(), name)}; if (!symbol) { if (IsIntrinsic(name.source, flag)) { - symbol = - &MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC}); + symbol = &MakeSymbol(InclusiveScope(), name.source, Attrs{}); + SetImplicitAttr(*symbol, Attr::INTRINSIC); } else if (const auto ppcBuiltinScope = currScope().context().GetPPCBuiltinsScope()) { // Check if it is a builtin from the predefined module @@ -8047,6 +8057,11 @@ void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) { } else if (ultimate.has() || ultimate.has()) { genericDetails.set_specific(*existing); + } else if (ultimate.has()) { + if (existing->name() != symbolName || + !ultimate.attrs().test(Attr::INTRINSIC)) { + genericDetails.set_specific(*existing); + } } else if (ultimate.has()) { genericDetails.set_derivedType(*existing); } else if (&existing->owner() == &currScope()) { diff --git a/flang/module/iso_fortran_env.f90 b/flang/module/iso_fortran_env.f90 index f1d540bc8e451..61d8a07e61133 100644 --- a/flang/module/iso_fortran_env.f90 +++ b/flang/module/iso_fortran_env.f90 @@ -23,6 +23,7 @@ module iso_fortran_env compiler_version => __builtin_compiler_version implicit none + private count ! TODO: Use PACK([x],test) in place of the array constructor idiom ! [(x, integer::j=1,COUNT([test]))] below once PACK() can be folded. diff --git a/flang/test/Semantics/contiguous01.f90 b/flang/test/Semantics/contiguous01.f90 index 1d3600aef6c55..0f086624a20ae 100644 --- a/flang/test/Semantics/contiguous01.f90 +++ b/flang/test/Semantics/contiguous01.f90 @@ -5,7 +5,7 @@ module m0 end module m use m0 - !ERROR: Cannot change CONTIGUOUS attribute on use-associated 'p1' + !WARNING: Use-associated 'p1' already has 'CONTIGUOUS' attribute contiguous p1 !ERROR: Cannot change CONTIGUOUS attribute on use-associated 'p2' contiguous p2 diff --git a/flang/test/Semantics/intrinsics02.f90 b/flang/test/Semantics/intrinsics02.f90 new file mode 100644 index 0000000000000..0b1f7c13a1564 --- /dev/null +++ b/flang/test/Semantics/intrinsics02.f90 @@ -0,0 +1,38 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module explicit + intrinsic cos +end +subroutine testExplicit + use explicit + !ERROR: 'cos' is use-associated from module 'explicit' and cannot be re-declared + real :: cos = 2. +end +subroutine extendsUsedIntrinsic + use explicit + interface cos + pure real function mycos(x) + real, intent(in) :: x + end + end interface +end +subroutine sameIntrinsic1 + use explicit + !WARNING: Use-associated 'cos' already has 'INTRINSIC' attribute + intrinsic cos + real :: one = cos(0.) +end +module renamer + use explicit, renamedCos => cos +end +subroutine sameIntrinsic2 + use explicit + use renamer, cos => renamedCos + real :: one = cos(0.) +end +module implicit + real :: one = cos(0.) +end +subroutine testImplicit + use implicit + real :: cos = 2. +end