[flang-commits] [flang] 0bb3260 - [flang] Fix constraint check on CLASS() entities
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jul 17 12:19:36 PDT 2023
Author: Peter Klausler
Date: 2023-07-17T12:19:30-07:00
New Revision: 0bb3260b7c5fe138bb8b51e04d050a94f6eb22c2
URL: https://github.com/llvm/llvm-project/commit/0bb3260b7c5fe138bb8b51e04d050a94f6eb22c2
DIFF: https://github.com/llvm/llvm-project/commit/0bb3260b7c5fe138bb8b51e04d050a94f6eb22c2.diff
LOG: [flang] Fix constraint check on CLASS() entities
Entities declared with CLASS() must be dummy arguments, allocatables,
or pointers. This constraint check is currently correct for objects
but not for procedures, and getting it right needs to avoid being
confused between pointers to procedures and pointers returned by
procedures.
Differential Revision: https://reviews.llvm.org/D155491
Added:
flang/test/Semantics/declarations06.f90
Modified:
flang/lib/Semantics/check-declarations.cpp
flang/test/Semantics/resolve44.f90
flang/test/Semantics/resolve71.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index bb2f43cd7ad479..ad940394375036 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -824,13 +824,6 @@ void CheckHelper::CheckObjectEntity(
"An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
}
}
- if (type && type->IsPolymorphic() &&
- !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
- IsDummy(symbol))) { // C708
- messages_.Say("CLASS entity '%s' must be a dummy argument or have "
- "ALLOCATABLE or POINTER attribute"_err_en_US,
- symbol.name());
- }
if (derived && InPure() && !InInterface() &&
IsAutomaticallyDestroyed(symbol) &&
!IsIntentOut(symbol) /*has better messages*/ &&
@@ -3093,15 +3086,22 @@ void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
}
void CheckHelper::CheckSymbolType(const Symbol &symbol) {
- if (!IsAllocatable(symbol) &&
- (!IsPointer(symbol) ||
- (IsProcedure(symbol) && !symbol.HasExplicitInterface()))) { // C702
- if (auto dyType{evaluate::DynamicType::From(symbol)}) {
- if (dyType->HasDeferredTypeParameter()) {
- messages_.Say(
- "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
- symbol.name(), dyType->AsFortran());
- }
+ const Symbol *result{FindFunctionResult(symbol)};
+ const Symbol &relevant{result ? *result : symbol};
+ if (IsAllocatable(relevant)) { // always ok
+ } else if (IsPointer(relevant) && !IsProcedure(relevant)) {
+ // object pointers are always ok
+ } else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
+ if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&
+ !(IsDummy(symbol) && !IsProcedure(relevant))) { // C708
+ messages_.Say(
+ "CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,
+ symbol.name());
+ }
+ if (dyType->HasDeferredTypeParameter()) { // C702
+ messages_.Say(
+ "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
+ symbol.name(), dyType->AsFortran());
}
}
}
diff --git a/flang/test/Semantics/declarations06.f90 b/flang/test/Semantics/declarations06.f90
new file mode 100644
index 00000000000000..532b0461d391e6
--- /dev/null
+++ b/flang/test/Semantics/declarations06.f90
@@ -0,0 +1,36 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! A CLASS() entity must be a dummy argument, allocatable,
+! or object pointer. Don't get confused with procedure pointers.
+module m
+ type t
+ end type
+ !ERROR: CLASS entity 'v1' must be a dummy argument, allocatable, or object pointer
+ class(t) v1
+ class(t), allocatable :: v2 ! ok
+ class(t), pointer :: v3 ! ok
+ !ERROR: CLASS entity 'p1' must be a dummy argument, allocatable, or object pointer
+ procedure(cf1) :: p1
+ procedure(cf2) :: p2
+ procedure(cf3) :: p3
+ !ERROR: CLASS entity 'pp1' must be a dummy argument, allocatable, or object pointer
+ procedure(cf1), pointer :: pp1
+ procedure(cf2), pointer :: pp2
+ procedure(cf3), pointer :: pp3
+ contains
+ !ERROR: CLASS entity 'cf1' must be a dummy argument, allocatable, or object pointer
+ class(t) function cf1()
+ end
+ class(t) function cf2()
+ allocatable cf2 ! ok
+ end
+ class(t) function cf3()
+ pointer cf3 ! ok
+ end
+ subroutine test(d1,d2,d3)
+ class(t) d1 ! ok
+ !ERROR: CLASS entity 'd2' must be a dummy argument, allocatable, or object pointer
+ class(t), external :: d2
+ !ERROR: CLASS entity 'd3' must be a dummy argument, allocatable, or object pointer
+ class(t), external, pointer :: d3
+ end
+end
diff --git a/flang/test/Semantics/resolve44.f90 b/flang/test/Semantics/resolve44.f90
index a251840d43df6b..e389b3d66e2cd4 100644
--- a/flang/test/Semantics/resolve44.f90
+++ b/flang/test/Semantics/resolve44.f90
@@ -11,7 +11,7 @@ program main
type(recursive1), pointer :: ok1
type(recursive1), allocatable :: ok2
!ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
- !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+ !ERROR: CLASS entity 'bad2' must be a dummy argument, allocatable, or object pointer
class(recursive1) :: bad2
class(recursive1), pointer :: ok3
class(recursive1), allocatable :: ok4
@@ -24,7 +24,7 @@ program main
type(recursive2(kind,len)), pointer :: ok1
type(recursive2(kind,len)), allocatable :: ok2
!ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
- !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+ !ERROR: CLASS entity 'bad2' must be a dummy argument, allocatable, or object pointer
class(recursive2(kind,len)) :: bad2
class(recursive2(kind,len)), pointer :: ok3
class(recursive2(kind,len)), allocatable :: ok4
@@ -37,7 +37,7 @@ program main
type(recursive3), pointer :: ok1
type(recursive3), allocatable :: ok2
!ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
- !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+ !ERROR: CLASS entity 'bad2' must be a dummy argument, allocatable, or object pointer
class(recursive3) :: bad2
class(recursive3), pointer :: ok3
class(recursive3), allocatable :: ok4
diff --git a/flang/test/Semantics/resolve71.f90 b/flang/test/Semantics/resolve71.f90
index 51e8f07ae7057f..83f25791159ae0 100644
--- a/flang/test/Semantics/resolve71.f90
+++ b/flang/test/Semantics/resolve71.f90
@@ -9,9 +9,9 @@ subroutine s()
class(parentType), allocatable :: avar
class(*), allocatable :: starAllocatableVar
class(*), pointer :: starPointerVar
- !ERROR: CLASS entity 'barevar' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+ !ERROR: CLASS entity 'barevar' must be a dummy argument, allocatable, or object pointer
class(parentType) :: bareVar
- !ERROR: CLASS entity 'starvar' must be a dummy argument or have ALLOCATABLE or POINTER attribute
+ !ERROR: CLASS entity 'starvar' must be a dummy argument, allocatable, or object pointer
class(*) :: starVar
contains
More information about the flang-commits
mailing list