[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

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index bb2f43c..ad94039 100644 (file)
--- 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 (file)
index 0000000..532b046
--- /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 a251840..e389b3d 100644 (file)
--- 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 51e8f07..83f2579 100644 (file)
--- 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