diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -343,6 +343,13 @@ This Fortran 2008 feature might as well be viewed like an extension; no other compiler that we've tested can handle it yet. +* According to 11.1.3.3p1, if a selector of an `ASSOCIATE` or + related construct is defined by a variable, it has the `TARGET` + attribute if the variable was a `POINTER` or `TARGET`. + We read this to include the case of the variable being a + pointer-valued function reference. + No other Fortran compiler seems to handle this correctly for + `ASSOCIATE`, though NAG gets it right for `SELECT TYPE`. ## Behavior in cases where the standard is ambiguous or indefinite diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -893,8 +893,13 @@ } } -// Convenience: If GetLastSymbol() succeeds on the argument, return its -// set of attributes, otherwise the empty set. +// If a function reference constitutes an entire expression, return a pointer +// to its PrcedureRef. +const ProcedureRef *GetProcedureRef(const Expr &); + +// For everyday variables: if GetLastSymbol() succeeds on the argument, return +// its set of attributes, otherwise the empty set. Also works on variables that +// are pointer results of functions. template semantics::Attrs GetAttrs(const A &x) { if (const Symbol * symbol{GetLastSymbol(x)}) { return symbol->attrs(); @@ -903,6 +908,37 @@ } } +template <> +inline semantics::Attrs GetAttrs>(const Expr &x) { + if (IsVariable(x)) { + if (const auto *procRef{GetProcedureRef(x)}) { + if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) { + if (const auto *details{ + interface->detailsIf()}) { + if (details->isFunction() && + details->result().attrs().test(semantics::Attr::POINTER)) { + // N.B.: POINTER becomes TARGET in SetAttrsFromAssociation() + return details->result().attrs(); + } + } + } + } + } + if (const Symbol * symbol{GetLastSymbol(x)}) { + return symbol->attrs(); + } else { + return {}; + } +} + +template semantics::Attrs GetAttrs(const std::optional &x) { + if (x) { + return GetAttrs(*x); + } else { + return {}; + } +} + // GetBaseObject() template std::optional GetBaseObject(const A &) { return std::nullopt; @@ -924,14 +960,8 @@ } } -// Predicate: IsAllocatableOrPointer() -template bool IsAllocatableOrPointer(const A &x) { - return GetAttrs(x).HasAny( - semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE}); -} - // Like IsAllocatableOrPointer, but accepts pointer function results as being -// pointers. +// pointers too. bool IsAllocatableOrPointerObject(const Expr &, FoldingContext &); bool IsAllocatableDesignator(const Expr &); @@ -946,8 +976,6 @@ bool IsNullPointer(const Expr &); bool IsObjectPointer(const Expr &, FoldingContext &); -const ProcedureRef *GetProcedureRef(const Expr &); - // Can Expr be passed as absent to an optional dummy argument. // See 15.5.2.12 point 1 for more details. bool MayBePassedAsAbsentOptional(const Expr &, FoldingContext &); diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -861,10 +861,12 @@ // GetSymbolVector() auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result { if (const auto *details{x.detailsIf()}) { - return (*this)(details->expr()); - } else { - return {x.GetUltimate()}; + if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) { + // associate(x => variable that is not a pointer returned by a function) + return (*this)(details->expr()); + } } + return {x.GetUltimate()}; } auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result { Result result{(*this)(x.base())}; @@ -1475,14 +1477,14 @@ const Symbol &ultimate{ResolveAssociations(symbol)}; const auto *object{ultimate.detailsIf()}; return object && object->CanBeAssumedShape() && - !evaluate::IsAllocatableOrPointer(ultimate); + !semantics::IsAllocatableOrPointer(ultimate); } bool IsDeferredShape(const Symbol &symbol) { const Symbol &ultimate{ResolveAssociations(symbol)}; const auto *object{ultimate.detailsIf()}; return object && object->CanBeDeferredShape() && - evaluate::IsAllocatableOrPointer(ultimate); + semantics::IsAllocatableOrPointer(ultimate); } bool IsFunctionResult(const Symbol &original) { diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp --- a/flang/lib/Lower/HostAssociations.cpp +++ b/flang/lib/Lower/HostAssociations.cpp @@ -447,7 +447,7 @@ if (Fortran::semantics::IsProcedure(sym)) return CapturedProcedure::visit(visitor, converter, sym, ba); ba.analyze(sym); - if (Fortran::evaluate::IsAllocatableOrPointer(sym)) + if (Fortran::semantics::IsAllocatableOrPointer(sym)) return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba); if (ba.isArray()) return CapturedArrays::visit(visitor, converter, sym, ba); diff --git a/flang/test/Semantics/associate01.f90 b/flang/test/Semantics/associate01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/associate01.f90 @@ -0,0 +1,45 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Tests of selectors whose defining expressions are pointer-valued functions; +! they must be valid targets, but not pointers. +! (F'2018 11.1.3.3 p1) "The associating entity does not have the ALLOCATABLE or +! POINTER attributes; it has the TARGET attribute if and only if the selector +! is a variable and has either the TARGET or POINTER attribute." +module m1 + type t + contains + procedure, nopass :: iptr + end type + contains + function iptr(n) + integer, intent(in), target :: n + integer, pointer :: iptr + iptr => n + end function + subroutine test + type(t) tv + integer, target :: itarget + integer, pointer :: ip + associate (sel => iptr(itarget)) + ip => sel + !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER + if (.not. associated(sel)) stop + end associate + associate (sel => tv%iptr(itarget)) + ip => sel + !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER + if (.not. associated(sel)) stop + end associate + associate (sel => (iptr(itarget))) + !ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes + ip => sel + !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER + if (.not. associated(sel)) stop + end associate + associate (sel => 0 + iptr(itarget)) + !ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes + ip => sel + !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER + if (.not. associated(sel)) stop + end associate + end subroutine +end module