[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

     }
   } 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;

flang/lib/Evaluate/formatting.cpp

 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()) {

flang/lib/Evaluate/type.cpp

   }
   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;
 }

flang/lib/Semantics/expression.cpp

   } 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

flang/test/Semantics/assign09.f90

 
   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

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

     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)

flang/test/Semantics/global01.f90

 
 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