[flang-commits] [flang] c6d8aa2 - [flang] Add semantic check for multiple part-ref with nonzero rank for TBP

[via flang-commits]

Author: Peixin-Qiao
Date: 2022-06-14T10:17:44+08:00
New Revision: c6d8aa27c5fe6aca56c3f95ee61c35265d4fe6b9

URL: https://github.com/llvm/llvm-project/commit/c6d8aa27c5fe6aca56c3f95ee61c35265d4fe6b9
DIFF: https://github.com/llvm/llvm-project/commit/c6d8aa27c5fe6aca56c3f95ee61c35265d4fe6b9.diff

LOG: [flang] Add semantic check for multiple part-ref with nonzero rank for TBP

As Fortran 2018 C919, there shall not be more than one part-ref with
nonzero rank. Support this semantic check for type-bound procedure to
address the issue https://github.com/llvm/llvm-project/issues/55811.

Reviewed By: klausler

Differential Revision: https://reviews.llvm.org/D127602

Added: 
    

Modified: 
    flang/lib/Semantics/expression.cpp
    flang/test/Semantics/expr-errors04.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 9f9107eaee108..1d7026cc5e3c2 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1977,13 +1977,16 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
             return std::nullopt;
           }
         }
+        std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
+        if (dataRef.has_value() && !CheckRanks(std::move(*dataRef))) {
+          return std::nullopt;
+        }
         if (const Symbol *
             resolution{GetBindingResolution(dtExpr->GetType(), *sym)}) {
           AddPassArg(arguments, std::move(*dtExpr), *sym, false);
           return CalleeAndArguments{
               ProcedureDesignator{*resolution}, std::move(arguments)};
-        } else if (std::optional<DataRef> dataRef{
-                       ExtractDataRef(std::move(*dtExpr))}) {
+        } else if (dataRef.has_value()) {
           if (sym->attrs().test(semantics::Attr::NOPASS)) {
             return CalleeAndArguments{
                 ProcedureDesignator{Component{std::move(*dataRef), *sym}},

diff  --git a/flang/test/Semantics/expr-errors04.f90 b/flang/test/Semantics/expr-errors04.f90
index b7888a267f459..e627d31979237 100644
--- a/flang/test/Semantics/expr-errors04.f90
+++ b/flang/test/Semantics/expr-errors04.f90
@@ -2,10 +2,23 @@
 ! Regression test for more than one part-ref with nonzero rank
 
 program m
+  interface
+    function real_info1(i)
+    end
+    subroutine real_info2()
+    end
+    subroutine real_generic()
+    end
+  end interface
   type mt
     complex :: c, c2(2)
     integer :: x, x2(2)
     character(10) :: s, s2(2)
+   contains
+    procedure, nopass :: info1 => real_info1
+    procedure, nopass :: info2 => real_info2
+    procedure, nopass :: real_generic
+    generic :: g1 => real_generic
   end type
   type mt2
     type(mt) :: t1(2,2)
@@ -73,4 +86,26 @@ program m
   print *, t(1)%t3%t2(1)%t1%c2(1)%RE
   !ERROR: Reference to whole rank-2 component 't1' of rank-1 array of derived type is not allowed
   print *, t%t3%t2%t1%c2(1)%IM
+
+  !ERROR: Reference to whole rank-2 component 't1' of rank-1 array of derived type is not allowed
+  call sub0(t%t3%t2%t1%info1(i))
+  !ERROR: Reference to whole rank-2 component 't1' of rank-1 array of derived type is not allowed
+  call t%t3%t2%t1%info2
+  !ERROR: Reference to whole rank-2 component 't1' of rank-1 array of derived type is not allowed
+  call t%t3%t2%t1%g1
+
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call sub0(t%t3%t2%t1(1)%info1(i))
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call t%t3%t2%t1(1)%info2
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call t%t3%t2%t1(1)%g1
+
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call sub0(t%t3%t2%t1(1:)%info1(i))
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call t%t3%t2%t1(1:)%info2
+  !ERROR: Reference to rank-2 object 't1' has 1 subscripts
+  call t%t3%t2%t1(1:)%g1
+
 end