[flang] Fix constraint check on CLASS() entities

[klausler]

Summary

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.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/check-declarations.cpp

if (symbol.owner().kind() == Scope::Kind::BlockData) {
     if (IsAllocatable(symbol)) {
       messages_.Say(
           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
     } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
       messages_.Say(
           "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*/ &&
       !IsFunctionResult(symbol) /*ditto*/) {
     // Check automatically deallocated local variables for possible
     // problems with finalization in PURE.
     if (auto whyNot{
             WhyNotDefinable(symbol.name(), symbol.owner(), {}, symbol)}) {
if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) {
         default:;
         }
       }
     }
   }
 }
 
 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
 
 void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
   auto procClass{ClassifyProcedure(symbol)};
   if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
       subprogram &&
       (procClass == ProcedureDefinitionClass::Module &&
           symbol.attrs().test(Attr::MODULE)) &&
       !subprogram->bindName() && !subprogram->isInterface()) {

flang/test/Semantics/declarations06.f90

+! 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

flang/test/Semantics/resolve44.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Error tests for recursive use of derived types.
 ! C744 If neither the POINTER nor the ALLOCATABLE attribute is specified, the
 ! declaration-type-spec in the component-def-stmt shall specify an intrinsic
 ! type or a previously defined derived type.
 
 program main
   type :: recursive1
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
     type(recursive1) :: bad1
     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
   end type recursive1
   type :: recursive2(kind,len)
     integer, kind :: kind
     integer, len :: len
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
     type(recursive2(kind,len)) :: bad1
     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
   end type recursive2
   type :: recursive3(kind,len)
     integer, kind :: kind = 1
     integer, len :: len = 2
     !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
     type(recursive3) :: bad1
     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
   end type recursive3
   !ERROR: Derived type 'recursive4' cannot extend itself
   type, extends(recursive4) :: recursive4
   end type recursive4
 end program main

flang/test/Semantics/resolve71.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! C708 An entity declared with the CLASS keyword shall be a dummy argument 
 ! or have the ALLOCATABLE or POINTER attribute.
 subroutine s()
   type :: parentType
   end type
 
   class(parentType), pointer :: pvar
   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
       subroutine inner(arg1, arg2, arg3, arg4, arg5)
         class (parenttype) :: arg1, arg3
         type(parentType) :: arg2
         class (parenttype), pointer :: arg4
         class (parenttype), allocatable :: arg5
       end subroutine inner
 end subroutine s