https://gcc.gnu.org/g:f70c1d517e09c4dde421774a8cec591ca3c479a0
commit r15-5295-gf70c1d517e09c4dde421774a8cec591ca3c479a0
Author: Harald Anlauf <anl...@gmx.de>
Date: Thu Nov 14 21:38:04 2024 +0100
Fortran: fix passing of NULL() actual argument to character dummy [PR104819]
Ensure that character length is set and passed by the call to a procedure
when its dummy argument is NULL() with MOLD argument present, or set length
to either 0 or the callee's expected character length. For assumed-rank
dummies, use the rank of the MOLD argument. Generate temporaries for
passed arguments when needed.
PR fortran/104819
gcc/fortran/ChangeLog:
* trans-expr.cc (conv_null_actual): Helper function to handle
passing of NULL() to non-optional dummy arguments of non-bind(c)
procedures.
(gfc_conv_procedure_call): Use it for character dummies.
gcc/testsuite/ChangeLog:
* gfortran.dg/null_actual_6.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 79 ++++++++++
gcc/testsuite/gfortran.dg/null_actual_6.f90 | 221 ++++++++++++++++++++++++++++
2 files changed, 300 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ddbb5ecf068a..f004af713344 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6378,6 +6378,76 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e,
gfc_symbol * fsym,
}
+/* Helper function for the handling of NULL() actual arguments associated with
+ non-optional dummy variables. Argument parmse should already be set up. */
+static void
+conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
+{
+ gcc_assert (fsym && !fsym->attr.optional);
+
+ /* Obtain the character length for a NULL() actual with a character
+ MOLD argument. Otherwise substitute a suitable dummy length.
+ Here we handle only non-optional dummies of non-bind(c) procedures. */
+ if (fsym->ts.type == BT_CHARACTER)
+ {
+ if (e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->ts.type == BT_CHARACTER)
+ {
+ /* MOLD is present. Substitute a temporary character NULL pointer.
+ For an assumed-rank dummy we need a descriptor that passes the
+ correct rank. */
+ if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ tree rank;
+ tree tmp = parmse->expr;
+ tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
+ rank = gfc_conv_descriptor_rank (tmp);
+ gfc_add_modify (&parmse->pre, rank,
+ build_int_cst (TREE_TYPE (rank), e->rank));
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+ else
+ {
+ tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
+ gfc_add_modify (&parmse->pre, tmp,
+ build_zero_cst (TREE_TYPE (tmp)));
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ /* Ensure that a usable length is available. */
+ if (parmse->string_length == NULL_TREE)
+ {
+ gfc_typespec *ts = &e->symtree->n.sym->ts;
+
+ if (ts->u.cl->length != NULL
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ gfc_conv_const_charlen (ts->u.cl);
+
+ if (ts->u.cl->backend_decl)
+ parmse->string_length = ts->u.cl->backend_decl;
+ }
+ }
+ else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
+ {
+ /* MOLD is not present. Pass length of associated dummy character
+ argument if constant, or zero. */
+ if (fsym->ts.u.cl->length != NULL
+ && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ gfc_conv_const_charlen (fsym->ts.u.cl);
+ parmse->string_length = fsym->ts.u.cl->backend_decl;
+ }
+ else
+ {
+ parmse->string_length = gfc_create_var (gfc_charlen_type_node,
+ "slen");
+ gfc_add_modify (&parmse->pre, parmse->string_length,
+ build_zero_cst (gfc_charlen_type_node));
+ }
+ }
+ }
+}
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
@@ -7542,6 +7612,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
}
+
+ /* Obtain the character length for a NULL() actual with a character
+ MOLD argument. Otherwise substitute a suitable dummy length.
+ Here we handle non-optional dummies of non-bind(c) procedures. */
+ if (e->expr_type == EXPR_NULL
+ && fsym->ts.type == BT_CHARACTER
+ && !fsym->attr.optional
+ && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
+ conv_null_actual (&parmse, e, fsym);
}
/* If any actual argument of the procedure is allocatable and passed
diff --git a/gcc/testsuite/gfortran.dg/null_actual_6.f90
b/gcc/testsuite/gfortran.dg/null_actual_6.f90
new file mode 100644
index 000000000000..e68bdc9562e3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_6.f90
@@ -0,0 +1,221 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=bounds" }
+!
+! PR fortran/104819 - passing of NULL() actual argument to character dummy
+
+program p
+ implicit none
+ character(kind=1,len=10), pointer :: c => NULL()
+ character(kind=1,len=:), pointer :: d => NULL()
+ character(kind=1,len=10), pointer :: c1(:) => NULL()
+ character(kind=1,len=:), pointer :: d1(:) => NULL()
+ character(kind=4,len=10), pointer :: c4(:) => NULL()
+ character(kind=4,len=:), pointer :: d4(:) => NULL()
+
+ ! scalar character variables:
+ ! kind=1, assumed length
+ call rank0_al (null(c))
+ call rank0_al (c)
+ call arank_al (null(c))
+ call arank_al (c)
+ call rank0_alb(null(c))
+ call rank0_alb(c)
+
+ ! kind=1, fixed length
+ call rank0_fl (null(c))
+ call rank0_fl (null())
+ call rank0_fl (c)
+ call arank_fl (null(c))
+ call arank_fl (c)
+ call rank0_flb(null(c))
+ call rank0_flb(c)
+
+ ! kind=1, deferred length
+ call rank0_dl (null(d))
+ call rank0_dl (null())
+ call rank0_dl (d)
+ call arank_dl (null(d)) ! <- this crashes nagfor 7.2
+ call arank_dl (d)
+ call rank0_dlb(null(d))
+ call rank0_dlb(null())
+
+ ! rank-1 character variables:
+ ! kind=1, assumed length
+ call rank1_al (null(c1))
+ call rank1_al (c1)
+ call arank_al (null(c1))
+ call arank_al (c1)
+ call rank1_alb(null(c1))
+ call rank1_alb(c1)
+
+ ! kind=1, fixed length
+ call rank1_fl (null(c1))
+ call rank1_fl (null())
+ call rank1_fl (c1)
+ call arank_fl (null(c1))
+ call arank_fl (c1)
+ call rank1_flb(null(c1))
+ call rank1_flb(c1)
+
+ ! kind=1, deferred length
+ call rank1_dl (null(d1))
+ call rank1_dl (null())
+ call rank1_dl (d1)
+ call arank_dl (null(d1))
+ call arank_dl (d1)
+ call rank1_dlb(null(d1))
+ call rank1_dlb(null())
+
+ ! kind=4, assumed length
+ call rank1_al_4 (null(c4))
+ call rank1_al_4 (c4)
+ call arank_al_4 (null(c4))
+ call arank_al_4 (c4)
+ call rank1_al_4b(null(c4))
+ call rank1_al_4b(c4)
+
+ ! kind=4, fixed length
+ call rank1_fl_4 (null(c4))
+ call rank1_fl_4 (null())
+ call rank1_fl_4 (c4)
+ call arank_fl_4 (null(c4))
+ call arank_fl_4 (c4)
+ call rank1_fl_4b(null(c4))
+ call rank1_fl_4b(c4)
+
+ ! kind=4, deferred length
+ call rank1_dl_4 (null(d4))
+ call rank1_dl_4 (null())
+ call rank1_dl_4 (d4)
+ call arank_dl_4 (null(d4))
+ call arank_dl_4 (d4)
+ call rank1_dl_4b(null(d4))
+ call rank1_dl_4b(null())
+
+contains
+
+ ! kind=4, rank=1
+ subroutine rank1_al_4 (x)
+ character(kind=4,len=*), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 41
+ end
+ subroutine rank1_fl_4 (x)
+ character(kind=4,len=10), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 42
+ end
+ subroutine rank1_dl_4 (x)
+ character(kind=4,len=:), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 43
+ end
+
+ subroutine rank1_al_4b (y)
+ character(kind=4,len=*), pointer, intent(in) :: y(:)
+ call rank1_al_4 (y)
+ if (associated (y)) stop 44
+ end
+ subroutine rank1_fl_4b (y)
+ character(kind=4,len=10), pointer, intent(in) :: y(:)
+ call rank1_fl_4 (y)
+ if (associated (y)) stop 45
+ end
+ subroutine rank1_dl_4b (y)
+ character(kind=4,len=:), pointer, intent(in) :: y(:)
+ call rank1_dl_4 (y)
+ if (associated (y)) stop 46
+ end
+
+ ! kind=4, assumed-rank versions
+ subroutine arank_al_4 (x)
+ character(kind=4,len=*), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 47
+ ! this testcase assumes that we call this subroutine only with rank=1
+ if (rank (x) /= 1) stop 57
+ end
+ subroutine arank_fl_4 (x)
+ character(kind=4,len=10), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 48
+ ! this testcase assumes that we call this subroutine only with rank=1
+ if (rank (x) /= 1) stop 58
+ end
+ subroutine arank_dl_4 (x)
+ character(kind=4,len=:), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 49
+ ! this testcase assumes that we call this subroutine only with rank=1
+ if (rank (x) /= 1) stop 59
+ end
+
+ ! kind=1, rank=1
+ subroutine rank1_al (x)
+ character(kind=1,len=*), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 11
+ end
+ subroutine rank1_fl (x)
+ character(kind=1,len=10), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 12
+ end
+ subroutine rank1_dl (x)
+ character(kind=1,len=:), pointer, intent(in) :: x(:)
+ if (associated (x)) stop 13
+ end
+
+ subroutine rank1_alb (y)
+ character(kind=1,len=*), pointer, intent(in) :: y(:)
+ call rank1_al (y)
+ if (associated (y)) stop 14
+ end
+ subroutine rank1_flb (y)
+ character(kind=1,len=10), pointer, intent(in) :: y(:)
+ call rank1_fl (y)
+ if (associated (y)) stop 15
+ end
+ subroutine rank1_dlb (y)
+ character(kind=1,len=:), pointer, intent(in) :: y(:)
+ call rank1_dl (y)
+ if (associated (y)) stop 16
+ end
+
+ ! kind=1, assumed-rank versions
+ subroutine arank_al (x)
+ character(kind=1,len=*), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 17
+ end
+ subroutine arank_fl (x)
+ character(kind=1,len=10), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 18
+ end
+ subroutine arank_dl (x)
+ character(kind=1,len=:), pointer, intent(in) :: x(..)
+ if (associated (x)) stop 19
+ end
+
+ ! kind=1, scalar
+ subroutine rank0_al (x)
+ character(kind=1,len=*), pointer, intent(in) :: x
+ if (associated (x)) stop 1
+ end
+ subroutine rank0_fl (x)
+ character(kind=1,len=10), pointer, intent(in) :: x
+ if (associated (x)) stop 2
+ end
+ subroutine rank0_dl (x)
+ character(kind=1,len=:), pointer, intent(in) :: x
+ if (associated (x)) stop 3
+ end
+
+ subroutine rank0_alb (y)
+ character(kind=1,len=*), pointer, intent(in) :: y
+ call rank0_al (y)
+ if (associated (y)) stop 4
+ end
+ subroutine rank0_flb (y)
+ character(kind=1,len=10), pointer, intent(in) :: y
+ call rank0_fl (y)
+ if (associated (y)) stop 5
+ end
+ subroutine rank0_dlb (y)
+ character(kind=1,len=:), pointer, intent(in) :: y
+ call rank0_dl (y)
+ if (associated (y)) stop 6
+ end
+
+end
