[flang] Correct procedure pointer (or dummy) compatibility check

[klausler]

Summary

Fix a subtle bug in procedure compatibility checking with base
derived types vs. their extensions to ensure that a procedure
expecting an extended type cannot be associated with a pointer
(or dummy procedure) to a procedure expecting a base type.

subroutine s1(base); ... subroutine s2(extended)
procedure(s1), pointer :: p
p => s2 ! <- must be caught as an error

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Evaluate/characteristics.cpp

bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
   } else if (functionResult && actual.functionResult &&
       !functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
   } else if (dummyArguments.size() != actual.dummyArguments.size()) {
     if (whyNot) {
       *whyNot = "distinct numbers of dummy arguments";
     }
   } else {
     for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
-      if (!dummyArguments[j].IsCompatibleWith(
-              actual.dummyArguments[j], whyNot)) {
+      // Subtlety: the dummy/actual distinction must be reversed for this
+      // compatibility test in order to correctly check extended vs.
+      // base types.  Example:
+      //   subroutine s1(base); subroutine s2(extended)
+      //   procedure(s1), pointer :: p
+      //   p => s2 ! an error, s2 is more restricted, can't handle "base"
+      if (!actual.dummyArguments[j].IsCompatibleWith(
+              dummyArguments[j], whyNot)) {
         if (whyNot) {
           *whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
               ": "s + *whyNot;
         }
         return false;
       }
     }
     return true;

flang/lib/Evaluate/formatting.cpp

if (values_.empty()) {
     }
   }
   return o << ')';
 }
 
 std::string DynamicType::AsFortran() const {
   if (derived_) {
     CHECK(category_ == TypeCategory::Derived);
-    return DerivedTypeSpecAsFortran(*derived_);
+    std::string result{DerivedTypeSpecAsFortran(*derived_)};
+    if (IsPolymorphic()) {
+      result = "CLASS("s + result + ')';
+    }
+    return result;
   } else if (charLengthParamValue_ || knownLength()) {
     std::string result{"CHARACTER(KIND="s + std::to_string(kind_) + ",LEN="};
     if (knownLength()) {
       result += std::to_string(*knownLength()) + "_8";
     } else if (charLengthParamValue_->isAssumed()) {
       result += '*';
     } else if (charLengthParamValue_->isDeferred()) {
       result += ':';

flang/lib/Evaluate/type.cpp

static const semantics::Symbol *FindParentComponent(
     const semantics::DerivedTypeSpec &derived) {
   const semantics::Symbol &typeSymbol{derived.typeSymbol()};
   const semantics::Scope *scope{derived.scope()};
   if (!scope) {
     scope = typeSymbol.scope();
   }
   if (scope) {
     const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
-    if (auto extends{dtDetails.GetParentComponentName()}) {
-      if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
-        if (const Symbol & symbol{*iter->second};
-            symbol.test(Symbol::Flag::ParentComp)) {
-          return &symbol;
-        }
-      }
-    }
+    return dtDetails.GetParentComponent(*scope);
   }
   return nullptr;
 }
 
 const semantics::DerivedTypeSpec *GetParentTypeSpec(
     const semantics::DerivedTypeSpec &derived) {
   if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
     return &parent->get<semantics::ObjectEntityDetails>()

flang/lib/Semantics/expression.cpp

 }
 
 std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
   if (i >= actuals_.size() || !actuals_[i]) {
     return "missing argument";
   } else if (std::optional<DynamicType> type{GetType(i)}) {
     return type->IsAssumedType()         ? "TYPE(*)"s
         : type->IsUnlimitedPolymorphic() ? "CLASS(*)"s
-        : type->IsPolymorphic()          ? "CLASS("s + type->AsFortran() + ')'
+        : type->IsPolymorphic()          ? type->AsFortran()
         : type->category() == TypeCategory::Derived
         ? "TYPE("s + type->AsFortran() + ')'
         : type->category() == TypeCategory::Character
         ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
         : ToUpperCase(type->AsFortran());
   } else {
     return "untyped";
   }

flang/test/Semantics/assign09.f90

program test
   call sub1(float)
   !ERROR: 'float' is not an unrestricted specific intrinsic procedure
   call sub2(float)
   !ERROR: 'float' is not an unrestricted specific intrinsic procedure
   call sub3(float)
 
   noInterfaceProcPtr => sqrt ! ok
   realToRealProcPtr => sqrt ! ok
-  !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+  !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4)
   intToRealProcPtr => sqrt
   call sub1(sqrt) ! ok
   call sub2(sqrt) ! ok
-  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+  !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4)
   call sub3(sqrt)
 
   noInterfaceProcPtr => noInterfaceExternal ! ok
   realToRealProcPtr => noInterfaceExternal ! ok
   intToRealProcPtr => noInterfaceExternal !ok
   call sub1(noInterfaceExternal) ! ok
   !WARNING: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
   call sub2(noInterfaceExternal)

flang/test/Semantics/assign12.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type base
+    procedure(baseSub), pointer :: baseComponent
+  end type
+  type, extends(base) :: extended
+  end type
+ contains
+  subroutine baseSub(x)
+    class(base), intent(in) :: x
+  end
+  subroutine extendedSub(x)
+    class(extended), intent(in) :: x
+  end
+  subroutine test
+    procedure(baseSub), pointer :: basePtr
+    procedure(extendedSub), pointer :: extendedPtr
+    type(extended) :: extendedVar
+    extendedPtr => baseSub ! ok
+    extendedPtr => basePtr ! ok
+    extendedVar = extended(baseSub) ! ok
+    extendedVar = extended(basePtr) ! ok
+    !ERROR: Procedure pointer 'baseptr' associated with incompatible procedure designator 'extendedsub': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+    basePtr => extendedSub
+    !ERROR: Procedure pointer 'baseptr' associated with incompatible procedure designator 'extendedptr': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+    basePtr => extendedPtr
+    !ERROR: Procedure pointer 'basecomponent' associated with incompatible procedure designator 'extendedsub': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+    extendedVar = extended(extendedSub)
+    !ERROR: Procedure pointer 'basecomponent' associated with incompatible procedure designator 'extendedptr': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+    extendedVar = extended(extendedPtr)
+  end
+end

flang/test/Semantics/call05.f90

subroutine test
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
     call spp(mp)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
     call spa(ma)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sup(pp)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sua(pa)
-    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
+    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
     call spp(up)
-    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
+    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
     call spa(ua)
     !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spp(pp2)
     !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spa(pa2)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
     call smp(mpmat)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2

flang/test/Semantics/global01.f90

 end subroutine
 
 subroutine global5(x)
   integer, intent(in) :: x
 end subroutine
 
 program test
   interface
-    !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4))
+    !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4))
     subroutine global1(x)
       real, intent(in) :: x
     end subroutine
     subroutine global2(x)
       real, intent(in) :: x
     end subroutine
     subroutine global3(x) bind(c,name="abc")
       real, intent(in) :: x