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 --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ddbb5ecf068a4433f629c36ad4df3417ebcd334b..f004af71334417321aae840f4a85713b5eff81de 100644 (file)
--- 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 (file)
index 0000000..e68bdc9
--- /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