[flang][semantics] make sure dynamic type inquiry functions take extensible or unlimited polymorphic types

[akuhlens]

Adds error message when type is derived but not extensible and more detailed error message when the type doesn't match.
fixes #162712

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Andre Kuhlenschmidt (akuhlens)

Changes

fixes #162712

---

Full diff: https://github.com/llvm/llvm-project/pull/162931.diff

4 Files Affected:

• (modified) flang/lib/Evaluate/intrinsics.cpp (+25-3)
• (modified) flang/lib/Semantics/check-declarations.cpp (+2)
• (added) flang/test/Semantics/dynamic-type-intrinsics.f90 (+71)
• (modified) flang/test/Semantics/io11.f90 (+21)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index f204eef54ef84..ec69197937a47 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -111,6 +111,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
     atomicIntKind, // atomic_int_kind from iso_fortran_env
     atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
     sameAtom, // same type and kind as atom
+    ExtensibleOrUnlimitedType, // extensible or unlimited polymorphic type
 )
 
 struct TypePattern {
@@ -160,7 +161,8 @@ static constexpr TypePattern AnyChar{CharType, KindCode::any};
 static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
 static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
 static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
-static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};
+static constexpr TypePattern ExtensibleDerived{
+    DerivedType, KindCode::ExtensibleOrUnlimitedType};
 static constexpr TypePattern AnyData{AnyType, KindCode::any};
 
 // Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
@@ -2103,9 +2105,18 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       }
       return std::nullopt;
     } else if (!d.typePattern.categorySet.test(type->category())) {
+      std::string expectedText;
+      switch (d.typePattern.kindCode) {
+      case KindCode::ExtensibleOrUnlimitedType:
+        expectedText = "extensible derived or unlimited polymorphic type";
+        break;
+      default:
+        break;
+      }
       messages.Say(arg->sourceLocation(),
-          "Actual argument for '%s=' has bad type '%s'"_err_en_US, d.keyword,
-          type->AsFortran());
+          "Actual argument for '%s=' has bad type '%s'%s"_err_en_US, d.keyword,
+          type->AsFortran(),
+          expectedText.empty() ? "" : ", expected " + expectedText);
       return std::nullopt; // argument has invalid type category
     }
     bool argOk{false};
@@ -2244,6 +2255,17 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         return std::nullopt;
       }
       break;
+    case KindCode::ExtensibleOrUnlimitedType:
+      argOk = type->IsUnlimitedPolymorphic() ||
+          (type->category() == TypeCategory::Derived &&
+              IsExtensibleType(GetDerivedTypeSpec(type)));
+      if (!argOk) {
+        messages.Say(arg->sourceLocation(),
+            "Actual argument for '%s=' has bad type '%s', expected extensible derived or unlimited polymorphic type"_err_en_US,
+            d.keyword, type->AsFortran());
+        return std::nullopt;
+      }
+      break;
     default:
       CRASH_NO_CASE;
     }
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index ea5e2c095d31a..31e246cf0ab03 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3622,6 +3622,7 @@ void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,
                 ioKind == common::DefinedIo::ReadUnformatted
             ? Attr::INTENT_INOUT
             : Attr::INTENT_IN);
+    CheckDioDummyIsScalar(subp, *arg);
   }
 }
 
@@ -3687,6 +3688,7 @@ void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
           "Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,
           arg->name());
     }
+    CheckDioDummyIsScalar(subp, *arg);
   }
 }
 
diff --git a/flang/test/Semantics/dynamic-type-intrinsics.f90 b/flang/test/Semantics/dynamic-type-intrinsics.f90
new file mode 100644
index 0000000000000..f63f1ee483637
--- /dev/null
+++ b/flang/test/Semantics/dynamic-type-intrinsics.f90
@@ -0,0 +1,71 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module m
+    type :: t1
+      real :: x
+    end type
+    type :: t2(k)
+      integer, kind :: k
+      real(kind=k) :: x
+    end type
+    type :: t3
+      real :: x
+    end type
+    type, extends(t1) :: t4
+      integer :: y
+    end type
+    type :: t5
+      sequence
+      integer :: x
+      integer :: y
+    end type
+  
+  
+    integer :: i
+    real :: r
+    type(t1) :: x1, y1
+    type(t2(4)) :: x24, y24
+    type(t2(8)) :: x28
+    type(t3) :: x3
+    type(t4) :: x4
+    type(t5) :: x5
+    class(t1), allocatable :: a1
+    class(t3), allocatable :: a3
+
+  
+    logical :: t1_1 = same_type_as(x1, x1)
+    logical :: t1_2 = same_type_as(x1, y1)
+    logical :: t1_3 = same_type_as(x24, x24)
+    logical :: t1_4 = same_type_as(x24, y24)
+    logical :: t1_5 = same_type_as(x24, x28) ! ignores parameter
+    logical :: t1_6 = .not. same_type_as(x1, x3)
+    logical :: t1_7 = .not. same_type_as(a1, a3)
+    !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t1_8 = same_type_as(x5, x5)
+    !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t1_9 = same_type_as(x5, x1)
+    !ERROR: Actual argument for 'b=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t1_10 = same_type_as(x1, x5)
+    !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+    logical :: t1_11 = same_type_as(i, i)
+    !ERROR: Actual argument for 'a=' has bad type 'REAL(4)', expected extensible derived or unlimited polymorphic type
+    logical :: t1_12 = same_type_as(r, r)
+    !ERROR: Actual argument for 'a=' has bad type 'INTEGER(4)', expected extensible derived or unlimited polymorphic type
+    logical :: t1_13 = same_type_as(i, t)
+    
+    logical :: t2_1 = extends_type_of(x1, y1)
+    logical :: t2_2 = extends_type_of(x24, x24)
+    logical :: t2_3 = extends_type_of(x24, y24)
+    logical :: t2_4 = extends_type_of(x24, x28) ! ignores parameter
+    logical :: t2_5 = .not. extends_type_of(x1, x3)
+    logical :: t2_6 = .not. extends_type_of(a1, a3)
+    logical :: t2_7 = .not. extends_type_of(x1, x4)
+    logical :: t2_8 = extends_type_of(x4, x1)
+    !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t2_9 = extends_type_of(x5, x5)
+    !ERROR: Actual argument for 'a=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t2_10 = extends_type_of(x5, x1)
+    !ERROR: Actual argument for 'mold=' has bad type 't5', expected extensible derived or unlimited polymorphic type
+    logical :: t2_11 = extends_type_of(x1, x5)
+end module
+  
\ No newline at end of file
diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index c00deede6b516..6bb7a71f0defc 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -809,3 +809,24 @@ subroutine wf(dtv, unit, iotype, v_list, iostat, iomsg)
     end
   end interface
 end
+
+module m30
+    type base
+        character(5), allocatable :: data
+    end type
+    interface write(formatted)
+        subroutine formattedRead (dtv, unit, iotype, v_list, iostat, iomsg)
+        import base
+            !ERROR: Dummy argument 'dtv' of a defined input/output procedure must be a scalar
+            class (base), intent(in) :: dtv(10)
+            integer, intent(in) :: unit
+            !ERROR: Dummy argument 'iotype' of a defined input/output procedure must be a scalar
+            character(*), intent(in) :: iotype(2)
+            integer, intent(in) :: v_list(:)
+            !ERROR: Dummy argument 'iostat' of a defined input/output procedure must be a scalar
+            integer, intent(out) :: iostat(*)
+            !ERROR: Dummy argument 'iomsg' of a defined input/output procedure must be a scalar
+            character(*), intent(inout) :: iomsg(:)
+        end subroutine
+    end interface
+end module

[DanielCChen]

LGTM.
Thanks.

Nit:
162931.patch:160: trailing whitespace.
162931.patch:161: trailing whitespace.
162931.patch:173: trailing whitespace.
162931.patch:193: trailing whitespace.
162931.patch:209: trailing whitespace.