Dear all,
the attached patch is the third part of a series to fix the handling of
NULL() passed to pointer dummy arguments. This one addresses character
dummy arguments (scalar, assumed-shape, assumed-rank) for various
uses in the caller.
The patch is a little larger than I expected, due to corner cases
(MOLD present or not, assumed-rank or other). If someone finds a
more clever version, I would be happy to learn about it.
Especially the treatment of assumed-rank dummy could certainly
be done differently.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
As this fixes wrong code on the one hand, and is very localized,
I would like to backport this to 14-branch after some waiting.
Is this ok?
Thanks,
Harald
From 3c7877fd4a20b6681dab6737f5d5be0d77241709 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Wed, 13 Nov 2024 23:03:47 +0100
Subject: [PATCH] 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 (gfc_conv_procedure_call): Handle passing of NULL()
to non-optional dummy arguments of non-bind(c) procedures.
gcc/testsuite/ChangeLog:
* gfortran.dg/null_actual_6.f90: New test.
---
gcc/fortran/trans-expr.cc | 69 ++++++
gcc/testsuite/gfortran.dg/null_actual_6.f90 | 221 ++++++++++++++++++++
2 files changed, 290 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/null_actual_6.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ddbb5ecf068..f9a6f8fb16f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7542,6 +7542,75 @@ 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)))
+ {
+ if (e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->ts.type == BT_CHARACTER)
+ {
+ /* MOLD is present. Substitute a temporary character NULL
+ pointer. For 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 (&se->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 (&se->pre, parmse.string_length,
+ build_zero_cst (gfc_charlen_type_node));
+ }
+ }
+ }
}
/* 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 00000000000..e6745311bee
--- /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
--
2.35.3
