Oops, looks like I mess up a testcase name. Fixed in this version.
On 8/6/2025 10:57 PM, Yuao Ma wrote:
Hi Tobias,
On 8/6/2025 4:32 PM, Tobias Burnus wrote:
Hi Yuao,
thanks for your patch. I have two nits:
* There is no diagnostic for -std=f2018 (or lower);
can you add the 'gfc_notify_std (GFC_STD_F2023' ?
Done. Testcase added.
* I have a minor documentation nit; current wording is
at https://gcc.gnu.org/onlinedocs/gfortran/C_005fF_005fPOINTER.html
Namely, ...
Yuao Ma wrote:
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -3368,10 +3368,10 @@ 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
+@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.
I think some wording like the following is missing:
"For an array @var{FPTR}, the lower bounds are specified by
@var{LOWER} if present and otherwise equal to 1."
Done.
@item @emph{Standard}:
Fortran 2003 and later
I think we should append ", with @var{LOWER} argument Fortran 2023 and
later" to "Standard".
Done.
PS: Eventually, we should update https://gcc.gnu.org/gcc-16/
changes.html for the accumulated Fortran changes … [That's the
https://gcc.gnu.org/ about.html#git ]
Yes, we could summarize the work done for Fortran 2023, similar to how
the Flang documentation(https://flang.llvm.org/docs/
FortranStandardsSupport.html#fortran-2023) does.
The new version of this patch also fixes two minor issues, the token
location in check.cc and the removal of unnecessary braces for single
statements after an else clause.
Thanks,
Yuao
From 41c6172ddc053c4c902e81d60e061bd6901a4e31 Mon Sep 17 00:00:00 2001
From: Yuao Ma <c...@outlook.com>
Date: Wed, 6 Aug 2025 23:01:14 +0800
Subject: [PATCH] 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 <c...@outlook.com>
---
gcc/fortran/check.cc | 41 +++++++-
gcc/fortran/intrinsic.cc | 5 +-
gcc/fortran/intrinsic.h | 2 +-
gcc/fortran/intrinsic.texi | 15 +--
gcc/fortran/trans-intrinsic.cc | 98 +++++++++++++------
.../gfortran.dg/c_f_pointer_shape_tests_7.f90 | 35 +++++++
.../gfortran.dg/c_f_pointer_shape_tests_8.f90 | 24 +++++
.../gfortran.dg/c_f_pointer_shape_tests_9.f90 | 17 ++++
8 files changed, 195 insertions(+), 42 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90
create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90
create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 862652683a7..e8bbf638d9f 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,44 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr,
gfc_expr *shape)
}
}
+ if (lower
+ && !gfc_notify_std (GFC_STD_F2023,
+ "Unexpected 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 c99a7a86aea..e2847f08daa 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 8a0ab935e1f..048196d65c3 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 a24b234316c..a3f665fdcd0 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -3368,10 +3368,10 @@ 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
+@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.
@item @emph{Class}:
@@ -3384,9 +3384,12 @@ 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}. For an array @var{FPTR}, the
+lower bounds are specified by @var{LOWER} if present and otherwise equal to 1.
@end multitable
@item @emph{Example}:
@@ -3408,7 +3411,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 f68ceb18820..71556b1c4ef 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 00000000000..3504e682f05
--- /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 00000000000..b9b851ac7dc
--- /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 00000000000..7bcf3795b4d
--- /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: Unexpected LOWER argument at" }
+end program lower
--
2.43.0
