[PATCH] D84290: Fix for the scenario when type guard has intrinsic type specification and Selector is NOT unlimited Polymorphic.

[Inderjeet via Phabricator via llvm-commits]

inderjeet-hcl created this revision.
inderjeet-hcl added reviewers: PeteSteinfeld, sameeranjoshi, sscalpone, DavidTruby, kiranktp.
inderjeet-hcl added a project: Flang.
Herald added a reviewer: jdoerfert.
Herald added a project: LLVM.

Issue is related to Semantic specification checks for Select Type construct. F18 <https://reviews.llvm.org/F18> compiler is not generating expected compilation error.

As per below Fortran 2018 specification, compile time error should be generated if Selector is NOT unlimited Polymorphic and Intrinsic type specification is specified in Type Guard statement.

C1162 (R1152) If selector is not unlimited polymorphic, each TYPE IS or CLASS IS type-guard-stmt shall specify an extension of the declared type of selector.

Test program:  Error is expected at line #16 as selector is NOT class(*).
=========================================================================

[root at localhost Select_type_fix]# cat -n selecttype04.f90

   1	type base
   2	 integer :: ii
   3	end type
   4	type,extends(base) :: ext
   5	 integer :: jj
   6	end type
   7	call CheckC1162()
   8	contains
   9	  subroutine CheckC1162()
  10	   class(base),allocatable :: aobj
  11	   allocate(ext::aobj)
  12	   select type(sel=>aobj)
  13	    ! OK
  14	    class is(base)
  15	    !ERROR: Intrinsic Type specification must not be specified
  16	    type is(integer)
  17	    ! OK
  18	    class default
  19	   end select
  20	  end
  21	end

- Gfortran behavior is correct, expected compilation Error is coming.

[root at localhost Select_type_fix]# gfortran selecttype04.f90 
selecttype04.f90:16:12:

  type is(integer)
         1

Error: Unexpected intrinsic type ‘INTEGER’ at (1)


Repository:
  rG LLVM Github Monorepo

https://reviews.llvm.org/D84290

Files:
  flang/lib/Semantics/check-select-type.cpp
  flang/test/Semantics/selecttype04.f90


Index: flang/test/Semantics/selecttype04.f90
===================================================================
--- /dev/null
+++ flang/test/Semantics/selecttype04.f90
@@ -0,0 +1,26 @@
+type base
+ integer :: ii
+end type
+type,extends(base) :: ext
+ integer :: jj
+end type
+
+call CheckC1162()
+contains
+  subroutine CheckC1162()
+   class(base),allocatable :: aobj
+   allocate(ext::aobj)
+   select type(sel=>aobj)
+    ! OK
+    class is(base)
+    !ERROR all: Intrinsic Type specification must not be specified
+    type is(integer)
+    type is(real)
+    type is(logical)
+    type is(character(len=*))
+    type is(complex)
+    ! OK
+    class default
+   end select
+  end
+end
Index: flang/lib/Semantics/check-select-type.cpp
===================================================================
--- flang/lib/Semantics/check-select-type.cpp
+++ flang/lib/Semantics/check-select-type.cpp
@@ -39,7 +39,7 @@
     if (std::holds_alternative<parser::Default>(guard.u)) {
       typeCases_.emplace_back(stmt, std::nullopt);
     } else if (std::optional<evaluate::DynamicType> type{GetGuardType(guard)}) {
-      if (PassesChecksOnGuard(guard, *type)) {
+      if (PassesChecksOnGuard(guard, *type, stmt)) {
         typeCases_.emplace_back(stmt, *type);
       } else {
         hasErrors_ = true;
@@ -72,12 +72,21 @@
   }
 
   bool PassesChecksOnGuard(const parser::TypeGuardStmt::Guard &guard,
-      const evaluate::DynamicType &guardDynamicType) {
+      const evaluate::DynamicType &guardDynamicType,
+      const parser::Statement<parser::TypeGuardStmt> &stmt) {
     return std::visit(
         common::visitors{
             [](const parser::Default &) { return true; },
             [&](const parser::TypeSpec &typeSpec) {
               if (const DeclTypeSpec * spec{typeSpec.declTypeSpec}) {
+                if (spec->AsIntrinsic() &&
+                    !selectorType_.IsUnlimitedPolymorphic()) { // C1162
+                  context_.Say(stmt.source,
+                      "If selector is not Unlimited Polymorphic, "
+                      "intrinsic type specification must not be specified "
+                      "in type guard statement"_err_en_US);
+                  return false;
+                }
                 if (spec->category() == DeclTypeSpec::Character &&
                     !guardDynamicType.IsAssumedLengthCharacter()) { // C1160
                   context_.Say(parser::FindSourceLocation(typeSpec),


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D84290.279692.patch
Type: text/x-patch
Size: 2447 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/llvm-commits/attachments/20200722/aa7c0dd7/attachment.bin>