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.
This commit is contained in:
Harald Anlauf
parent
7744da67e9
commit
f70c1d517e
2 changed files with 300 additions and 0 deletions
|
|
@ -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
|
||||
|
|
|
|||
221
gcc/testsuite/gfortran.dg/null_actual_6.f90
Normal file
221
gcc/testsuite/gfortran.dg/null_actual_6.f90
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Reference in a new issue