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

[inderjeet-hcl]

Summary

There are 2 issues:

• • Bug 46789 : Expected compile time error is not coming for Select type specification. Compile time error should be generated if Selector is NOT unlimited Polymorphic and Intrinsic type specification is specified in Type Guard statement.
• Bug 46830 : Semantic error is not coming for duplicate intrinsic type specification in type guard statement.

Bug 46789 : 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@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@localhost Select_type_fix]# gfortran selecttype04.f90
selecttype04.f90:16:12:

type is(integer)
       1

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

[inderjeet-hcl]

Additional compilation error will come in selecttype01.f90 and symbol11.f90 test cases and it is expected with the patch. Also I am uploading patch file to add "RUN: line" in newly added test case selecttype04.f90.

1. selecttype01.f90: Addition error will come at line 122 and 130 selecttype01.f90:122:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement type is (integer) ^^^^^^^^^^^^^^^^^
   
   selecttype01.f90:130:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement type is (integer) ^^^^^^^^^^^^^^^^^

2. symbol11.f90: Addition error will come at line 74.

symbol11.f90:74:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement

type is (integer(kind=8))
^^^^^^^^^^^^^^^^^^^^^^^^^

testcasefix.patch994 BDownload

[sameeranjoshi]

In D84290#2165893, @inderjeet-hcl wrote:

Additional compilation error will come in selecttype01.f90 and symbol11.f90 test cases and it is expected with the patch. Also I am uploading patch file to add "RUN: line" in newly added test case selecttype04.f90.

1. selecttype01.f90: Addition error will come at line 122 and 130 selecttype01.f90:122:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement type is (integer) ^^^^^^^^^^^^^^^^^
   
   selecttype01.f90:130:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement type is (integer) ^^^^^^^^^^^^^^^^^

2. symbol11.f90: Addition error will come at line 74.

symbol11.f90:74:3: error: If selector is not Unlimited Polymorphic, intrinsic type specification must not be specified in type guard statement

type is (integer(kind=8))
^^^^^^^^^^^^^^^^^^^^^^^^^

testcasefix.patch994 BDownload

Thank you for finding this! Some comments below:

Can you add checks with !ERROR: in the respective files?
Also I never saw someone sending a .patch file for review separately in llvm-project, you need to include the changes with the revision itself.

flang/lib/Semantics/check-select-type.cpp

85

I tried to minimize the use of passing stmt as a parameter by using parser::FindSourceLocation(typeSpec) it was strange that I couldn't see the source location information printed.

Does parser::FindSourceLocation fail in some scenarios @PeteSteinfeld ?
If that's the case using stmt is completely fine here.

86

Why are u and p capitalized?
Read more on error message to user guideline:
https://github.com/llvm/llvm-project/blob/master/flang/documentation/C%2B%2Bstyle.md#error-messages

101–102

How about adding an else if statement here?

if (){
...
} else if (!selectorType_.IsUnlimitedPolymorphic() && spec->AsIntrinsic()) {  // C1162
  ...
}

flang/test/Semantics/selecttype04.f90

1 ↗

(On Diff #279692)

There's already a file with a test for C1162, can you add these tests in it?

[sameeranjoshi]

You could have reduced the effort of writing summary, by just pointing to the bugzilla issue.

[inderjeet-hcl]

@sameeranjoshi, Kindly find reply inline and let me know if it seems fine.

flang/lib/Semantics/check-select-type.cpp

85

Kindly refer following case when line number information is not output in error message.
In case of intrinsic types 'integer','character' etc. parser::FindSourceLocation(typespec) is returning empty:

[root@localhost Github_compiler]# f18 selecttype.f90
error: The type specification statement must have LEN type parameter as assumed
f18: semantic errors in selecttype.f90
[root@localhost Github_compiler]# cat -n selecttype.f90

1	class(*),allocatable :: cptr
2	
3	select type(cptr)
4	 !ERROR: The type specification statement must have LEN type parameter as assumed
5	 type is(character) !<-- assumed length-type
6	end select
7	end

86

Thanks for sharing document reference. I will update it as follows:

context_.Say(stmt.source,
    "If selector is not unlimited polymorphic, "
    "intrinsic type specification must not be specified "
    "in type guard statement"_err_en_US);

101–102

I think either way is fine. I added 'if' condition at the beginning considering if type specification is of intrinsic type then that should be the first check to be performed.

flang/test/Semantics/selecttype04.f90

1 ↗

(On Diff #279692)

I agree, I will update test program selecttype01.f90 to add tests.

[inderjeet-hcl]

@sameeranjoshi. I missed to reply for below points, kindly find the reply below.

Can you add checks with !ERROR: in the respective files?

I will add '!ERROR:' and share updated test programs.

Also I never saw someone sending a .patch file for review separately in llvm-project, you need to include the changes with the revision itself.

Please note that I referred following point in document(https://www.llvm.org/docs/Phabricator.html#code-reviews-with-phabricator) to submit the patch. Kindly let me know if any other method needs to be following to share modified source files and test programs.
"Note that you can upload patches created through git,"

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

101–102

I think adding at beginning would never check C1160.

[inderjeet-hcl]

@sameeranjoshi , Kindly refer comment inline.

flang/lib/Semantics/check-select-type.cpp

101–102

I agree, If added at the begging and selector is not uninlimited polymorphic then C1160 will not be checked and return will execute after generating NEW error message for C1162.

However, adding "elseif" will never generate new error if C1160 is generated. Kindly refer below case.
One solution might be to change code and add if condition for 'Intrinsic type' and perform error checks for C1160 and C1162 before returning false.
Kindly suggest, if I should modify source code.

[root@localhost Github_compiler]# ./f18 selecttype.f90
error: The type specification statement must have LEN type parameter as assumed
./f18: semantic errors in selecttype.f90
[root@localhost Github_compiler]# cat -n selecttype.f90

 1	type ty
 2	 integer :: ii
 3	end type
 4	class(ty),allocatable :: cptr
 5	
 6	select type(cptr)
 7	 !ERROR: The type specification statement must have LEN type parameter as assumed
 8	 type is(character) !<-- assumed length-type
 9	end select
10	end

[PeteSteinfeld]

Thanks for working on this!

flang/lib/Semantics/check-select-type.cpp

85

It looks like you could simplify this by just passing the TypeGuardStmt. You can use it to find the TypeGuardStmt::Guard and the source location of the TypeGuardStmt.

86

Here's what I would prefer for the message:

context_.Say(stmt.source,
    "If the selector is not unlimited polymorphic, "
    "an intrinsic type specification must not be specified "
    "in the type guard statement"_err_en_US);

[inderjeet-hcl]

@PeteSteinfeld , Thanks for sharing review comments. I will share the modified source file to accommodate comments.

[inderjeet-hcl]

Kindly review modified sources and test program. Modifications contain fix for Bugs: 46789 and 46830.

Source file check-select-type.cpp is updated for following points:

• updated text of new message.
• modified function PassesChecksOnGuard to generate correct messages for Intrinsic type.
• For better code readability, modified PassesChecksOnGuard to remove extra if/else conditions and added CHECK() .

Following test program are modified:
selecttype01.f90
symbol11.f90

[sameeranjoshi]

Thank you for working !
This patch builds successfully but fails for check-flang for me.

flang/lib/Semantics/check-select-type.cpp

77

Can you please use GetGuardFromStmt here?

103

DeclTypeSpec::AsDerived might return nullptr. Please wrap it in some conditional statement.

flang/test/Semantics/selecttype01.f90

122

Is this error correct?
I see check-flang failing for both the files.
Did you verify check-flang before submitting this patch?

[inderjeet-hcl]

Kindly check reply inline.

flang/lib/Semantics/check-select-type.cpp

77

ok, I will update source code.

flang/test/Semantics/selecttype01.f90

122

sorry, I was not aware of the option check-flang. I will test it before submitting updated files.

Error seems correct, selector should be unlimited Polymorphic in case of Intrinsic type specification.
Function ReportConflictingTypeCases is generating 'INTEGER*4' in error message instead of 'integer' which is specified in test case. Do you have any idea how to update function ReportConflictingTypeCases to display correct name ?

[sameeranjoshi]

flang/test/Semantics/selecttype01.f90

122

4 specifies kind type parameter.
I am speaking of
!ERROR : Intrinsic type specification must not be specified
replaced with
!ERROR : If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement

[inderjeet-hcl]

Kindly check reply inline and suggest.

flang/lib/Semantics/check-select-type.cpp

77

GetGuardFromStmt is defined in struct TypeCase and can not be called from PassesChecksOnGuard as we do not have object of class TypeCase in function PassesChecksOnGuard.
Kindly suggest if I should pass object of class TypeCase as a parameter to PassesChecksOnGuard or we can keep above modifications without calling GetGuardFromStmt.

flang/test/Semantics/selecttype01.f90

122

I will update comment.

[inderjeet-hcl]

Kindly check comments inline and suggest.

flang/lib/Semantics/check-select-type.cpp

103

I have added CHECK(spec); and CHECK(spec->AsIntrinsic() || spec->AsDerived()); at the start considering if code in block "[&](const parser::TypeSpec &typeSpec)" is executed then spec will always be one of intrinsic or derived type and one of AsIntrinsic() or AsDerived() will return non NULL value.
Considering above description, I think AsDerived() will not return NULL at this location as this code is present in 'else' of AsIntrinsic().
Kindly suggest.

[sameeranjoshi]

flang/lib/Semantics/check-select-type.cpp

77

Ok, please revert with the older way.

103

Sorry, I missed it.
Your point seems correct.

[inderjeet-hcl]

Kindly find updated test cases. There is no change in source file.

Kindly review and let me know if any other modification is required.

[sameeranjoshi]

I can build and test successfully.
I have verified bugs Bug 46789 & Bug 46830.
Please wait for a day before you commit until other reviewers accept it.

Thanks for working on it.

[PeteSteinfeld]

All builds, tests, and looks good.

Thanks for doing this!

flang/lib/Semantics/check-select-type.cpp

83

Please move the declaration of typeSpecRetVal below the calls to CHECK().

[inderjeet-hcl]

I have uploaded final patch.
This is my first time to commit changes in LLVM repository, kindly guide how to commit changes to LLVM github repository.
I have referred section "Committing a change" section in "https://www.llvm.org/docs/Phabricator.html#code-reviews-with-phabricator" and it seems I need to use "git push" to push my changes but I think I do not have write permission to the repository.

[PeteSteinfeld]

Here's the process for getting commit access to the repository -- https://llvm.org/docs/DeveloperPolicy.html#obtaining-commit-access

[sameeranjoshi]

Thanks for working @inderjeet-hcl. Do let us know if you still see any issues in committing changes.

[inderjeet-hcl]

@sameeranjoshi , thanks. I have received reply from Chris, I think now I can commit my changes. I will try and let you know in case of any issues.

[inderjeet-hcl]

@sameeranjoshi , I have committed modifications to LLVM/FLANG repository. Am I supposed to close PR46789 and PR46830 in Bugzilla ?

flang/lib/Semantics/check-select-type.cpp

 private:
   void AddTypeCase(const parser::SelectTypeConstruct::TypeCase &c) {
     const auto &stmt{std::get<parser::Statement<parser::TypeGuardStmt>>(c.t)};
     const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
     const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
     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(stmt, *type)) {
         typeCases_.emplace_back(stmt, *type);
       } else {
         hasErrors_ = true;
       }
     } else {
       hasErrors_ = true;
     }
   }
return std::visit(
                 return evaluate::DynamicType(*derivedTypeSpec);
               }
               return std::nullopt;
             },
         },
         guard.u);
   }
 
-  bool PassesChecksOnGuard(const parser::TypeGuardStmt::Guard &guard,
+  bool PassesChecksOnGuard(const parser::Statement<parser::TypeGuardStmt> &stmt,
       const evaluate::DynamicType &guardDynamicType) {
+    const parser::TypeGuardStmt &typeGuardStmt{stmt.statement};
+    const auto &guard{std::get<parser::TypeGuardStmt::Guard>(typeGuardStmt.t)};
     return std::visit(
         common::visitors{
             [](const parser::Default &) { return true; },
             [&](const parser::TypeSpec &typeSpec) {
-              if (const DeclTypeSpec * spec{typeSpec.declTypeSpec}) {
+              const DeclTypeSpec *spec{typeSpec.declTypeSpec};
+              bool typeSpecRetVal{false};
+              CHECK(spec);
+              CHECK(spec->AsIntrinsic() || spec->AsDerived());
+              if (spec->AsIntrinsic()) {
+                typeSpecRetVal = true;
+                if (!selectorType_.IsUnlimitedPolymorphic()) { // C1162
+                  context_.Say(stmt.source,
+                      "If selector is not unlimited polymorphic, "
+                      "an intrinsic type specification must not be specified "
+                      "in the type guard statement"_err_en_US);
+                  typeSpecRetVal = false;
+                }
                 if (spec->category() == DeclTypeSpec::Character &&
                     !guardDynamicType.IsAssumedLengthCharacter()) { // C1160
                   context_.Say(parser::FindSourceLocation(typeSpec),
                       "The type specification statement must have "
                       "LEN type parameter as assumed"_err_en_US);
-                  return false;
+                  typeSpecRetVal = false;
                 }
-                if (const DerivedTypeSpec * derived{spec->AsDerived()}) {
-                  return PassesDerivedTypeChecks(
-                      *derived, parser::FindSourceLocation(typeSpec));
-                }
-                return false;
-              }
-              return false;
+              } else {
+                const DerivedTypeSpec *derived{spec->AsDerived()};
+                typeSpecRetVal = PassesDerivedTypeChecks(
+              return typeSpecRetVal;
             },
             [&](const parser::DerivedTypeSpec &x) {
-              if (const semantics::DerivedTypeSpec *
-                  derived{x.derivedTypeSpec}) {
-                return PassesDerivedTypeChecks(
-                    *derived, parser::FindSourceLocation(x));
-              }
-              return false;
+              CHECK(x.derivedTypeSpec);
+              const semantics::DerivedTypeSpec *derived{x.derivedTypeSpec};
             },
         },
         guard.u);
   }
 
   bool PassesDerivedTypeChecks(const semantics::DerivedTypeSpec &derived,
       parser::CharBlock sourceLoc) const {
     for (const auto &pair : derived.parameters()) {

flang/test/Semantics/selecttype01.f90

subroutine CheckC1159a
   select type(char_variable)
   end select
 end
 
 subroutine CheckC1159b
   integer :: x
   !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
   select type (a => x)
+  !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
   type is (integer)
     print *,'integer ',a
   end select
 end
 
 subroutine CheckC1159c
   !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
   select type (a => x)
+  !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
   type is (integer)
     print *,'integer ',a
   end select
 end
 
 subroutine s(arg)
   class(*) :: arg
     select type (arg)
select type (rectangle_polymorphic)
     type is (shape)
     !ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
     type is (unrelated)
     !all are ok
     type is (square)
     type is (extsquare)
     !Handle same types
     type is (rectangle)
+    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+    type is(integer)
+    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+    type is(real)
+    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+    type is(logical)
+    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+    type is(character(len=*))
+    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
+    type is(complex)
   end select
 
   !Unlimited polymorphic objects are allowed.
   unlim_polymorphic => rect_obj
   select type (unlim_polymorphic)
     type is (shape)
     type is (unrelated)
   end select
 end
 
 subroutine CheckC1163
   use m1
   !assign dynamically
   shape_lim_polymorphic => rect_obj
   unlim_polymorphic => shape_obj
   select type (shape_lim_polymorphic)
     type is (shape)
     !ERROR: Type specification 'shape' conflicts with previous type specification
     type is (shape)
     class is (square)
     !ERROR: Type specification 'square' conflicts with previous type specification
     class is (square)
   end select
+  select type (unlim_polymorphic)
+    type is (INTEGER(4))
+    type is (shape)
+    !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
+    type is (INTEGER(4))
+  end select
 end
 
 subroutine CheckC1164
   use m1
   shape_lim_polymorphic => rect_obj
   unlim_polymorphic => shape_obj
   select type (shape_lim_polymorphic)
     CLASS DEFAULT

flang/test/Semantics/symbol11.f90

  !REF: /s3/x
  select type (y => x)
   !REF: /s3/t2
   class is (t2)
    !REF: /s3/i
    !DEF: /s3/Block1/y TARGET AssocEntity TYPE(t2)
    !REF: /s3/t2/a2
    i = y%a2
-  type is (integer(kind=8))
+  !REF: /s3/t1
+  type is (t1)
    !REF: /s3/i
-   !DEF: /s3/Block2/y TARGET AssocEntity INTEGER(8)
-   i = y
+   !DEF: /s3/Block2/y TARGET AssocEntity TYPE(t1)
+   !REF: /s3/t1/a1
+   i = y%a1
   class default
    !DEF: /s3/Block3/y TARGET AssocEntity CLASS(t1)
    print *, y
  end select
 end subroutine
 
 !DEF: /s4 (Subroutine) Subprogram
 subroutine s4