[flang] Diagnostic for shape argument in c_f_pointer

[realqhc]

Summary

Fix #59177, add check for dimensionality for shape argument against rank of FPTR argument in c_f_pointer

[peixin]

Please check Fortran 2018 18.2.3.3: SHAPE shall be present if and only if FPTR is an array; its size shall be equal to the rank of FPTR.

I guess you want to add the check when shape has constant size. Please notice that it cannot be checked when the size of shape is compile-time unknown.

[realqhc]

fix the commit to correctly compare size of array against rank, note that expr->Rank() ==1 is required to fix a potential issue when a non-scalar shape is passed into the function, the program crashes after context.message

[realqhc]

fix conflicting naming with previous part in the function

[realqhc]

run clang-format

[jeanPerier]

flang/lib/Evaluate/intrinsics.cpp

2622–2623

2627

The message reads as if SHAPE's rank should be the same as FPTR's rank. I think it may be misleading given it is SHAPE's size that must be the equal to FPTR's rank.

[jeanPerier]

flang/lib/Evaluate/intrinsics.cpp

2622–2623

actually, also probably better to use *argExpr instead of *arguments[2] in the GetConstantShape call.

[realqhc]

replace redundant if statements by GetConstantShape, change argument is GetConstantShape call, rewrite error message

[realqhc]

fix test case

[realqhc]

add back the ERROR prefix for the test case

[peixin]

flang/lib/Evaluate/intrinsics.cpp

2621

Can you also add another check here?

if (argExpr->Rank() != 1)  {
  error: shape argument to c_f_pointer() must be a rank-one array.
} else {
  ...
}

2625

[realqhc]

flang/lib/Evaluate/intrinsics.cpp

2621

I'm afraid this will conflict with check-call error, as it also check if the argument is a scalar (albeit not checking the rank).

[realqhc]

add check for size= array rank

[realqhc]

flang/lib/Evaluate/intrinsics.cpp

2621

error: Semantic errors in test.f90
./test.f90:17:51: error: SHAPE= argument to C_F_POINTER() must be a rank-one array.
      call c_f_pointer(scalarC, multiDimIntF, shape=1)
                                                    ^
./test.f90:17:51: error: Whole scalar actual argument may not be associated with a dummy argument 'shape=' array
      call c_f_pointer(scalarC, multiDimIntF, shape=1)
                                                    ^

which will reult in two reports being issued for the same error.

[peixin]

LGTM now except one clang-format problem in flang/lib/Evaluate/intrinsics.cpp.

flang/lib/Evaluate/intrinsics.cpp

2621

Thanks. This has already been checked elsewhere.

[realqhc]

run clang-format

flang/lib/Evaluate/intrinsics.cpp

if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
             "FPTR= argument to C_F_POINTER() must have a type"_err_en_US);
       }
       if (arguments[2] && fptrRank == 0) {
         context.messages().Say(arguments[2]->sourceLocation(),
             "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US);
       } else if (!arguments[2] && fptrRank > 0) {
         context.messages().Say(
             "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US);
+      } else if (arguments[2]) {
+        if (const auto *argExpr{arguments[2].value().UnwrapExpr()}) {
+          if (argExpr->Rank() > 1) {
+            context.messages().Say(arguments[2]->sourceLocation(),
+                "SHAPE= argument to C_F_POINTER() must be a rank-one array."_err_en_US);
+          } else if (argExpr->Rank() == 1) {
+            if (auto constShape{GetConstantShape(context, *argExpr)}) {
+              if (constShape->At(ConstantSubscripts{1}).ToInt64() != fptrRank) {
+                context.messages().Say(arguments[2]->sourceLocation(),
+                    "SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR="_err_en_US);
+              }
+            }
+          }
+        }
       }
     }
   }
   if (dummies.size() == 2) {
     DynamicType shapeType{TypeCategory::Integer, defaults_.sizeIntegerKind()};
     if (arguments[2]) {
       if (auto type{arguments[2]->GetType()}) {
         if (type->category() == TypeCategory::Integer) {

flang/test/Semantics/c_f_pointer.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Enforce 18.2.3.3
 
 program test
   use iso_c_binding, only: c_ptr, c_f_pointer
   type(c_ptr) :: scalarC, arrayC(1)
   type :: with_pointer
     integer, pointer :: p
   end type
   type(with_pointer) :: coindexed[*]
-  integer, pointer :: scalarIntF, arrayIntF(:)
+  integer, pointer :: scalarIntF, arrayIntF(:), multiDimIntF(:,:)
   character(len=:), pointer :: charDeferredF
   integer :: j
+  integer, dimension(2, 2) :: rankTwoArray
+  rankTwoArray = reshape([1, 2, 3, 4], shape(rankTwoArray))
   call c_f_pointer(scalarC, scalarIntF) ! ok
   call c_f_pointer(scalarC, arrayIntF, [1_8]) ! ok
   call c_f_pointer(shape=[1_8], cptr=scalarC, fptr=arrayIntF) ! ok
   call c_f_pointer(scalarC, shape=[1_8], fptr=arrayIntF) ! ok
   !ERROR: A positional actual argument may not appear after any keyword arguments
   call c_f_pointer(scalarC, fptr=arrayIntF, [1_8])
   !ERROR: CPTR= argument to C_F_POINTER() must be a C_PTR
   call c_f_pointer(j, scalarIntF)
   !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
   call c_f_pointer(arrayC, scalarIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array
   call c_f_pointer(scalarC, arrayIntF)
   !ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar
   call c_f_pointer(scalarC, scalarIntF, [1_8])
   !ERROR: FPTR= argument to C_F_POINTER() may not have a deferred type parameter
   call c_f_pointer(scalarC, charDeferredF)
   !ERROR: FPTR= argument to C_F_POINTER() may not be a coindexed object
   call c_f_pointer(scalarC, coindexed[0]%p)
   !ERROR: FPTR= argument to C_F_POINTER() must have a type
   call c_f_pointer(scalarC, null())
+  !ERROR: SHAPE= argument to C_F_POINTER() must have size equal to the rank of FPTR=
+  call c_f_pointer(scalarC, multiDimIntF, shape=[1_8])
+  !ERROR: SHAPE= argument to C_F_POINTER() must be a rank-one array.
+  call c_f_pointer(scalarC, multiDimIntF, shape=rankTwoArray)
 end program