fortran: add optional lower arg to c_f_pointer

This patch adds support for the optional lower argument in intrinsic
c_f_pointer specified in Fortran 2023. Test cases and documentation have also
been updated.

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_c_f_pointer): Check lower arg legitimacy.
	* intrinsic.cc (add_subroutines): Teach c_f_pointer about lower arg.
	* intrinsic.h (gfc_check_c_f_pointer): Add lower arg.
	* intrinsic.texi: Update lower arg for c_f_pointer.
	* trans-intrinsic.cc (conv_isocbinding_subroutine): Add logic handle lower.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c_f_pointer_shape_tests_7.f90: New test.
	* gfortran.dg/c_f_pointer_shape_tests_8.f90: New test.
	* gfortran.dg/c_f_pointer_shape_tests_9.f90: New test.

Signed-off-by: Yuao Ma <c8ef@outlook.com>

8 files changed, 196 insertions, 43 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 8626526..80aac89 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6081,7 +6081,8 @@ gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
 
 
 bool
-gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape,
+		       gfc_expr *lower)
 {
   symbol_attribute attr;
   const char *msg;
@@ -6156,6 +6157,43 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
 	}
     }
 
+  if (lower
+      && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER",
+			  &lower->where))
+    return false;
+
+  if (!shape && lower)
+    {
+      gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER "
+		 "with scalar FPTR",
+		 &lower->where);
+      return false;
+    }
+
+  if (lower && !rank_check (lower, 3, 1))
+    return false;
+
+  if (lower && !type_check (lower, 3, BT_INTEGER))
+    return false;
+
+  if (lower)
+    {
+      mpz_t size;
+      if (gfc_array_size (lower, &size))
+	{
+	  if (mpz_cmp_ui (size, fptr->rank) != 0)
+	    {
+	      mpz_clear (size);
+	      gfc_error (
+		"LOWER argument at %L to C_F_POINTER must have the same "
+		"size as the RANK of FPTR",
+		&lower->where);
+	      return false;
+	    }
+	  mpz_clear (size);
+	}
+    }
+
   if (fptr->ts.type == BT_CLASS)
     {
       gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index c99a7a8..e2847f0 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3943,11 +3943,12 @@ add_subroutines (void)
 
   /* The following subroutines are part of ISO_C_BINDING.  */
 
-  add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
+  add_sym_4s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
 	      GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
 	      "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
 	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
-	      "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
+	      "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN,
+	      "lower", BT_INTEGER, di, OPTIONAL, INTENT_IN);
   make_from_module();
 
   add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 8a0ab93..048196d 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -165,7 +165,7 @@ bool gfc_check_sign (gfc_expr *, gfc_expr *);
 bool gfc_check_signal (gfc_expr *, gfc_expr *);
 bool gfc_check_sizeof (gfc_expr *);
 bool gfc_check_c_associated (gfc_expr *, gfc_expr *);
-bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
 bool gfc_check_c_funloc (gfc_expr *);
 bool gfc_check_c_loc (gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index a24b234..3941914 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -3368,11 +3368,13 @@ Fortran 2003 and later
 
 @table @asis
 @item @emph{Synopsis}:
-@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE])}
+@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])}
 
 @item @emph{Description}:
-@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} assigns the target of the C pointer
-@var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape.
+@code{C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])} assigns the target of the C
+pointer @var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape.
+For an array @var{FPTR}, the lower bounds are specified by @var{LOWER} if
+present and otherwise equal to 1.
 
 @item @emph{Class}:
 Subroutine
@@ -3384,9 +3386,11 @@ Subroutine
 @item @var{FPTR}  @tab pointer interoperable with @var{cptr}. It is
 @code{INTENT(OUT)}.
 @item @var{SHAPE} @tab (Optional) Rank-one array of type @code{INTEGER}
-with @code{INTENT(IN)}. It shall be present
-if and only if @var{fptr} is an array. The size
-must be equal to the rank of @var{fptr}.
+with @code{INTENT(IN)}. It shall be present if and only if @var{FPTR} is an
+array. The size must be equal to the rank of @var{FPTR}.
+@item @var{LOWER} @tab (Optional) Rank-one array of type @code{INTEGER}
+with @code{INTENT(IN)}. It shall not be present if @var{SHAPE} is not present.
+The size must be equal to the rank of @var{FPTR}.
 @end multitable
 
 @item @emph{Example}:
@@ -3408,7 +3412,7 @@ end program main
 @end smallexample
 
 @item @emph{Standard}:
-Fortran 2003 and later
+Fortran 2003 and later, with @var{LOWER} argument Fortran 2023 and later
 
 @item @emph{See also}:
 @ref{C_LOC}, @*
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index f68ceb1..71556b1 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9918,38 +9918,40 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
 static tree
 conv_isocbinding_subroutine (gfc_code *code)
 {
-  gfc_se se;
-  gfc_se cptrse;
-  gfc_se fptrse;
-  gfc_se shapese;
-  gfc_ss *shape_ss;
-  tree desc, dim, tmp, stride, offset;
+  gfc_expr *cptr, *fptr, *shape, *lower;
+  gfc_se se, cptrse, fptrse, shapese, lowerse;
+  gfc_ss *shape_ss, *lower_ss;
+  tree desc, dim, tmp, stride, offset, lbound, ubound;
   stmtblock_t body, block;
   gfc_loopinfo loop;
-  gfc_actual_arglist *arg = code->ext.actual;
+  gfc_actual_arglist *arg;
+
+  arg = code->ext.actual;
+  cptr = arg->expr;
+  fptr = arg->next->expr;
+  shape = arg->next->next ? arg->next->next->expr : NULL;
+  lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
 
   gfc_init_se (&se, NULL);
   gfc_init_se (&cptrse, NULL);
-  gfc_conv_expr (&cptrse, arg->expr);
+  gfc_conv_expr (&cptrse, cptr);
   gfc_add_block_to_block (&se.pre, &cptrse.pre);
   gfc_add_block_to_block (&se.post, &cptrse.post);
 
   gfc_init_se (&fptrse, NULL);
-  if (arg->next->expr->rank == 0)
+  if (fptr->rank == 0)
     {
       fptrse.want_pointer = 1;
-      gfc_conv_expr (&fptrse, arg->next->expr);
+      gfc_conv_expr (&fptrse, fptr);
       gfc_add_block_to_block (&se.pre, &fptrse.pre);
       gfc_add_block_to_block (&se.post, &fptrse.post);
-      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
-	  && arg->next->expr->symtree->n.sym->attr.dummy)
-	fptrse.expr = build_fold_indirect_ref_loc (input_location,
-						       fptrse.expr);
-      se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
-				 TREE_TYPE (fptrse.expr),
-				 fptrse.expr,
-				 fold_convert (TREE_TYPE (fptrse.expr),
-					       cptrse.expr));
+      if (fptr->symtree->n.sym->attr.proc_pointer
+	  && fptr->symtree->n.sym->attr.dummy)
+	fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
+      se.expr
+	= fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
+			   fptrse.expr,
+			   fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
       gfc_add_expr_to_block (&se.pre, se.expr);
       gfc_add_block_to_block (&se.pre, &se.post);
       return gfc_finish_block (&se.pre);
@@ -9959,7 +9961,7 @@ conv_isocbinding_subroutine (gfc_code *code)
 
   /* Get the descriptor of the Fortran pointer.  */
   fptrse.descriptor_only = 1;
-  gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
+  gfc_conv_expr_descriptor (&fptrse, fptr);
   gfc_add_block_to_block (&block, &fptrse.pre);
   desc = fptrse.expr;
 
@@ -9976,18 +9978,33 @@ conv_isocbinding_subroutine (gfc_code *code)
 
   /* Start scalarization of the bounds, using the shape argument.  */
 
-  shape_ss = gfc_walk_expr (arg->next->next->expr);
+  shape_ss = gfc_walk_expr (shape);
   gcc_assert (shape_ss != gfc_ss_terminator);
   gfc_init_se (&shapese, NULL);
+  if (lower)
+    {
+      lower_ss = gfc_walk_expr (lower);
+      gcc_assert (lower_ss != gfc_ss_terminator);
+      gfc_init_se (&lowerse, NULL);
+    }
 
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, shape_ss);
+  if (lower)
+    gfc_add_ss_to_loop (&loop, lower_ss);
   gfc_conv_ss_startstride (&loop);
-  gfc_conv_loop_setup (&loop, &arg->next->expr->where);
+  gfc_conv_loop_setup (&loop, &fptr->where);
   gfc_mark_ss_chain_used (shape_ss, 1);
+  if (lower)
+    gfc_mark_ss_chain_used (lower_ss, 1);
 
   gfc_copy_loopinfo_to_se (&shapese, &loop);
   shapese.ss = shape_ss;
+  if (lower)
+    {
+      gfc_copy_loopinfo_to_se (&lowerse, &loop);
+      lowerse.ss = lower_ss;
+    }
 
   stride = gfc_create_var (gfc_array_index_type, "stride");
   offset = gfc_create_var (gfc_array_index_type, "offset");
@@ -9998,27 +10015,44 @@ conv_isocbinding_subroutine (gfc_code *code)
   gfc_start_scalarized_body (&loop, &body);
 
   dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     loop.loopvar[0], loop.from[0]);
+			 loop.loopvar[0], loop.from[0]);
+
+  if (lower)
+    {
+      gfc_conv_expr (&lowerse, lower);
+      gfc_add_block_to_block (&body, &lowerse.pre);
+      lbound = fold_convert (gfc_array_index_type, lowerse.expr);
+      gfc_add_block_to_block (&body, &lowerse.post);
+    }
+  else
+    lbound = gfc_index_one_node;
 
   /* Set bounds and stride.  */
-  gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+  gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
   gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
 
-  gfc_conv_expr (&shapese, arg->next->next->expr);
+  gfc_conv_expr (&shapese, shape);
   gfc_add_block_to_block (&body, &shapese.pre);
-  gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+  ubound = fold_build2_loc (
+    input_location, MINUS_EXPR, gfc_array_index_type,
+    fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
+		     fold_convert (gfc_array_index_type, shapese.expr)),
+    gfc_index_one_node);
+  gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
   gfc_add_block_to_block (&body, &shapese.post);
 
   /* Calculate offset.  */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 stride, lbound);
   gfc_add_modify (&body, offset,
 		  fold_build2_loc (input_location, PLUS_EXPR,
-				   gfc_array_index_type, offset, stride));
+				   gfc_array_index_type, offset, tmp));
+
   /* Update stride.  */
-  gfc_add_modify (&body, stride,
-		  fold_build2_loc (input_location, MULT_EXPR,
-				   gfc_array_index_type, stride,
-				   fold_convert (gfc_array_index_type,
-						 shapese.expr)));
+  gfc_add_modify (
+    &body, stride,
+    fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
+		     fold_convert (gfc_array_index_type, shapese.expr)));
   /* Finish scalarization loop.  */
   gfc_trans_scalarizing_loops (&loop, &body);
   gfc_add_block_to_block (&block, &loop.pre);
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90
new file mode 100644
index 0000000..3504e68
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+! { dg-options "-std=f2023" }
+program lower
+  use iso_c_binding
+  type(c_ptr) :: x
+  integer, target :: array_2d(12), array_3d(24)
+  integer, pointer :: ptr_2d(:, :), ptr_3d(:, :, :)
+  integer :: myshape_2d(2), myshape_3d(3)
+  integer :: mylower_2d(2), mylower_3d(3)
+
+  array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
+  x = c_loc(array_2d)
+  myshape_2d = [3, 4]
+  mylower_2d = [2, 2]
+
+  call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d)
+  if (any(lbound(ptr_2d) /= [2, 2])) stop 1
+  if (any(ubound(ptr_2d) /= [4, 5])) stop 2
+  if (any(shape(ptr_2d) /= [3, 4])) stop 3
+  if (ptr_2d(2, 2) /= 1) stop 4
+  if (ptr_2d(3, 4) /= 8) stop 5
+  if (ptr_2d(4, 5) /= 12) stop 6
+
+  array_3d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24]
+  x = c_loc(array_3d)
+  myshape_3d = [2, 3, 4]
+  mylower_3d = [-1, -2, -3]
+
+  call c_f_pointer(x, ptr_3d, shape=myshape_3d, lower=mylower_3d)
+  if (any(lbound(ptr_3d) /= [-1, -2, -3])) stop 7
+  if (any(ubound(ptr_3d) /= [0, 0, 0])) stop 8
+  if (any(shape(ptr_3d) /= [2, 3, 4])) stop 9
+  if (ptr_3d(0, 0, 0) /= 24) stop 10
+
+end program lower
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90
new file mode 100644
index 0000000..b9b851a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-options "-std=f2023" }
+! Verify that the type and rank of the LOWER argument are enforced.
+module c_f_pointer_shape_tests_8
+  use, intrinsic :: iso_c_binding
+
+contains
+  subroutine sub2(my_c_array) bind(c)
+    type(c_ptr), value :: my_c_array
+    integer(kind=c_int), dimension(:), pointer :: my_array_ptr
+
+    call c_f_pointer(my_c_array, my_array_ptr, (/ 10 /), (/ 10.0 /)) ! { dg-error "must be INTEGER" }
+  end subroutine sub2
+
+  subroutine sub3(my_c_array) bind(c)
+    type(c_ptr), value :: my_c_array
+    integer(kind=c_int), dimension(:), pointer :: my_array_ptr
+    integer(kind=c_int), dimension(1) :: shape
+    integer(kind=c_int), dimension(1, 1) :: lower
+
+    lower(1, 1) = 10
+    call c_f_pointer(my_c_array, my_array_ptr, shape, lower) ! { dg-error "must be of rank 1" }
+  end subroutine sub3
+end module c_f_pointer_shape_tests_8
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90
new file mode 100644
index 0000000..e501e3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! { dg-options "-std=f2018" }
+program lower
+  use iso_c_binding
+  type(c_ptr) :: x
+  integer, target :: array_2d(12)
+  integer, pointer :: ptr_2d(:, :)
+  integer :: myshape_2d(2)
+  integer :: mylower_2d(2)
+
+  array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
+  x = c_loc(array_2d)
+  myshape_2d = [3, 4]
+  mylower_2d = [2, 2]
+
+  call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d) ! { dg-error "Fortran 2023: LOWER argument at" }
+end program lower