Hi all,
This patch implements the optional lower argument for the c_f_pointer
intrinsic, as specified in the Fortran 2023 standard. I've also included
documentation and tests, and the regression tests on aarch64-linux passed.
Please take a look when you have a chance.
Thanks,
Yuao
From 74eba4dbd7601ca4c854b0e6138b6bffc727222a Mon Sep 17 00:00:00 2001
From: Yuao Ma <c...@outlook.com>
Date: Tue, 5 Aug 2025 23:33:16 +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_3.f03: Check rank & type for
lower.
* gfortran.dg/c_f_pointer_shape_tests_7.f90: New test.
Signed-off-by: Yuao Ma <c...@outlook.com>
---
gcc/fortran/check.cc | 35 +++++-
gcc/fortran/intrinsic.cc | 5 +-
gcc/fortran/intrinsic.h | 2 +-
gcc/fortran/intrinsic.texi | 12 ++-
gcc/fortran/trans-intrinsic.cc | 100 ++++++++++++------
.../gfortran.dg/c_f_pointer_shape_tests_3.f03 | 29 +++--
.../gfortran.dg/c_f_pointer_shape_tests_7.f90 | 34 ++++++
7 files changed, 171 insertions(+), 46 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 862652683a7..3c4594be9e7 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,38 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr,
gfc_expr *shape)
}
}
+ if (!shape && lower)
+ {
+ gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER "
+ "with scalar FPTR",
+ &fptr->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..d06c9d9dadc 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}:
@@ -3385,8 +3385,12 @@ Subroutine
@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}.
+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}:
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index f68ceb18820..7d874548b32 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,46 @@ 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_3.f03
b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
index 632e4579ce8..67dc0f0a444 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
@@ -2,21 +2,38 @@
! Verify that the type and rank of the SHAPE argument are enforced.
module c_f_pointer_shape_tests_3
use, intrinsic :: iso_c_binding
-
+
contains
subroutine sub0(my_c_array) bind(c)
type(c_ptr), value :: my_c_array
- integer(c_int), dimension(:), pointer :: my_array_ptr
-
+ integer(kind=c_int), dimension(:), pointer :: my_array_ptr
+
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must
be INTEGER" }
end subroutine sub0
subroutine sub1(my_c_array) bind(c)
type(c_ptr), value :: my_c_array
- integer(c_int), dimension(:), pointer :: my_array_ptr
- integer(c_int), dimension(1,1) :: shape
+ integer(kind=c_int), dimension(:), pointer :: my_array_ptr
+ integer(kind=c_int), dimension(1, 1) :: shape
- shape(1,1) = 10
+ shape(1, 1) = 10
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be of
rank 1" }
end subroutine sub1
+
+ 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_3
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..7190961d0f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+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
--
2.43.0
