initial commit

Author: akuhlens

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

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
+