OSchip
/
llvm-project
mirror of https://github.com/THU-DSP-LAB/llvm-project.git
13
0
Fork 6
Code Issues Packages Projects Releases Wiki Activity

[flang] Refine pointer/target test for ASSOCIATED intrinsic 

The second argument to the ASSOCIATED intrinsic must be a valid pointer
or target. The test for this property only checked the last symbol
in a data-reference, but any symbol in the reference with the
POINTER or TARGET attribute will do.

Differential Revision: https://reviews.llvm.org/D119450
This commit is contained in:
Peter Klausler 2022-02-07 08:45:11 -08:00
parent 100ec80ab5
commit 82dbe82585
2 changed files with 30 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
flang/lib/Evaluate/intrinsics.cpp
View File

@ -2260,22 +2260,18 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
"procedure designator"_err_en_US, "procedure designator"_err_en_US,
pointerSymbol->name(), targetName), pointerSymbol->name(), targetName),
*pointerSymbol); *pointerSymbol);
} else { } else if (targetSymbol) {
// object pointer and target // object pointer and target
if (const Symbol * targetSymbol{GetLastSymbol(*targetExpr)}) { SymbolVector symbols{GetSymbolVector(*targetExpr)};
if (!(targetSymbol->attrs().test(semantics::Attr::POINTER) || CHECK(!symbols.empty());
targetSymbol->attrs().test( if (!GetLastTarget(symbols)) {
semantics::Attr::TARGET))) { parser::Message *msg{context.messages().Say(
AttachDeclaration( "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
context.messages().Say( targetExpr->AsFortran())};
"TARGET= argument '%s' must have either " for (SymbolRef ref : symbols) {
"the POINTER or the TARGET " msg = AttachDeclaration(msg, *ref);
"attribute"_err_en_US,
targetName),
*targetSymbol);
} }
} }
if (const auto pointerType{pointerArg->GetType()}) { if (const auto pointerType{pointerArg->GetType()}) {
if (const auto targetType{targetArg->GetType()}) { if (const auto targetType{targetArg->GetType()}) {
ok = pointerType->IsTkCompatibleWith(*targetType); ok = pointerType->IsTkCompatibleWith(*targetType);

21
flang/test/Semantics/associated.f90
View File

@ -12,6 +12,14 @@ subroutine assoc()
end function end function
end interface end interface
type :: t1
integer :: n
end type t1
type :: t2
type(t1) :: t1arr(2)
type(t1), pointer :: t1ptr(:)
end type t2
contains contains
integer function intFunc(x) integer function intFunc(x)
integer, intent(in) :: x integer, intent(in) :: x
@ -60,6 +68,10 @@ subroutine assoc()
procedure(subrInt), pointer :: subProcPointer procedure(subrInt), pointer :: subProcPointer
procedure(), pointer :: implicitProcPointer procedure(), pointer :: implicitProcPointer
logical :: lVar logical :: lVar
type(t1) :: t1x
type(t1), target :: t1xtarget
type(t2) :: t2x
type(t2), target :: t2xtarget
!ERROR: missing mandatory 'pointer=' argument !ERROR: missing mandatory 'pointer=' argument
lVar = associated() lVar = associated()
@ -91,6 +103,15 @@ subroutine assoc()
!ERROR: TARGET= argument 'intvar' must have either the POINTER or the TARGET attribute !ERROR: TARGET= argument 'intvar' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, intVar) lVar = associated(intPointerVar1, intVar)
!ERROR: TARGET= argument 't1x%n' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, t1x%n)
lVar = associated(intPointerVar1, t1xtarget%n) ! ok
!ERROR: TARGET= argument 't2x%t1arr(1_8)%n' must have either the POINTER or the TARGET attribute
lVar = associated(intPointerVar1, t2x%t1arr(1)%n)
lVar = associated(intPointerVar1, t2x%t1ptr(1)%n) ! ok
lVar = associated(intPointerVar1, t2xtarget%t1arr(1)%n) ! ok
lVar = associated(intPointerVar1, t2xtarget%t1ptr(1)%n) ! ok
! Procedure pointer tests ! Procedure pointer tests
intprocPointer1 => intProc !OK intprocPointer1 => intProc !OK
lVar = associated(intprocPointer1, intProc) !OK lVar = associated(intprocPointer1, intProc) !OK