[flang-commits] [flang] 384b4e0 - [flang] Fix error in characteristics check at procedure pointer assignment
Emil Kieri via flang-commits
flang-commits at lists.llvm.org
Tue Nov 9 09:47:11 PST 2021
Author: Emil Kieri
Date: 2021-11-09T18:46:54+01:00
New Revision: 384b4e0d332ec6fc4f9fc279d12aadc162eaf3a0
URL: https://github.com/llvm/llvm-project/commit/384b4e0d332ec6fc4f9fc279d12aadc162eaf3a0
DIFF: https://github.com/llvm/llvm-project/commit/384b4e0d332ec6fc4f9fc279d12aadc162eaf3a0.diff
LOG: [flang] Fix error in characteristics check at procedure pointer assignment
If the procedure pointer has an explicit interface, its characteristics must
equal the characteristics of its target, except that the target may be pure or
elemental also when the pointer is not (cf. F2018 10.2.2.4(3)). In the semantics
check for assignment of procedure pointers, the attributes of the procedures
were not checked correctly due to a typo. This caused some illegal
pointer-target-combinations to pass without raising an error. Fix this, and
expand the test case to improve the coverage of procedure pointer assignment
checks.
Reviewed By: PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D113368
Added:
Modified:
flang/lib/Evaluate/tools.cpp
flang/test/Semantics/assign03.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 73afb88d53fe1..a3f177b1bb348 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -911,12 +911,12 @@ std::optional<std::string> FindImpureCall(
return FindImpureCallHelper{context}(proc);
}
-// Compare procedure characteristics for equality except that lhs may be
-// Pure or Elemental when rhs is not.
+// Compare procedure characteristics for equality except that rhs may be
+// Pure or Elemental when lhs is not.
static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
const characteristics::Procedure &rhs) {
using Attr = characteristics::Procedure::Attr;
- auto lhsAttrs{rhs.attrs};
+ auto lhsAttrs{lhs.attrs};
lhsAttrs.set(
Attr::Pure, lhs.attrs.test(Attr::Pure) || rhs.attrs.test(Attr::Pure));
lhsAttrs.set(Attr::Elemental,
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index 0c7260e8ff5b5..bc0ab035399b4 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -63,26 +63,112 @@ subroutine s_module(i)
! 10.2.2.4(3)
subroutine s5
- procedure(f_pure), pointer :: p_pure
- procedure(f_impure), pointer :: p_impure
+ procedure(f_impure1), pointer :: p_impure
+ procedure(f_pure1), pointer :: p_pure
!ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
- procedure(f_elemental), pointer :: p_elemental
- p_pure => f_pure
- p_impure => f_impure
- p_impure => f_pure
- !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure'
- p_pure => f_impure
+ procedure(f_elemental1), pointer :: p_elemental
+ procedure(s_impure1), pointer :: sp_impure
+ procedure(s_pure1), pointer :: sp_pure
+ !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
+ procedure(s_elemental1), pointer :: sp_elemental
+
+ p_impure => f_impure1 ! OK, same characteristics
+ p_impure => f_pure1 ! OK, target may be pure when pointer is not
+ p_impure => f_elemental1 ! OK, target may be pure elemental
+ p_impure => f_ImpureElemental1 ! OK, target may be elemental
+
+ sp_impure => s_impure1 ! OK, same characteristics
+ sp_impure => s_pure1 ! OK, target may be pure when pointer is not
+ sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not
+
+ !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
+ p_pure => f_impure1
+ p_pure => f_pure1 ! OK, same characteristics
+ p_pure => f_elemental1 ! OK, target may be pure
+ !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
+ p_pure => f_impureElemental1
+
+ !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
+ sp_pure => s_impure1
+ sp_pure => s_pure1 ! OK, same characteristics
+ sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
+
+ !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2'
+ p_impure => f_impure2
+ !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2'
+ p_pure => f_pure2
+ !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2'
+ p_impure => f_elemental2
+
+ !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2'
+ sp_impure => s_impure2
+ !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2'
+ sp_impure => s_pure2
+ !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2'
+ sp_pure => s_elemental2
+
+ !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
+ p_impure => s_impure1
+
+ !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
+ sp_impure => f_impure1
+
contains
- pure integer function f_pure()
- f_pure = 1
+ integer function f_impure1(n)
+ real, intent(in) :: n
+ f_impure = n
+ end
+ pure integer function f_pure1(n)
+ real, intent(in) :: n
+ f_pure = n
end
- integer function f_impure()
- f_impure = 1
+ elemental integer function f_elemental1(n)
+ real, intent(in) :: n
+ f_elemental = n
+ end
+ impure elemental integer function f_impureElemental1(n)
+ real, intent(in) :: n
+ f_impureElemental = n
+ end
+
+ integer function f_impure2(n)
+ real, intent(inout) :: n
+ f_impure = n
+ end
+ pure real function f_pure2(n)
+ real, intent(in) :: n
+ f_pure = n
end
- elemental integer function f_elemental(n)
+ elemental integer function f_elemental2(n)
real, value :: n
f_elemental = n
end
+
+ subroutine s_impure1(n)
+ integer, intent(inout) :: n
+ n = n + 1
+ end
+ pure subroutine s_pure1(n)
+ integer, intent(inout) :: n
+ n = n + 1
+ end
+ elemental subroutine s_elemental1(n)
+ integer, intent(inout) :: n
+ n = n + 1
+ end
+
+ subroutine s_impure2(n) bind(c)
+ integer, intent(inout) :: n
+ n = n + 1
+ end subroutine s_impure2
+ pure subroutine s_pure2(n)
+ integer, intent(out) :: n
+ n = 1
+ end subroutine s_pure2
+ elemental subroutine s_elemental2(m,n)
+ integer, intent(inout) :: m, n
+ n = m + n
+ end subroutine s_elemental2
end
! 10.2.2.4(4)
More information about the flang-commits
mailing list