Dear all,
this patch is the 4th part of a series on the passing of NULL() to
assumed-rank dummies. This one handles the case of a derived type
dummy and is mostly straightforward.
There was one particular problem I encountered: passing NULL() to
an allocatable dummy with no intent given. This lead to an ICE
I could not resolve other than treating this the same as if an
intent(in) were given. If someone has a better idea, I'd love
to learn about it...
Testcase cross-checked with Intel's ifx.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
P.S.: if someone would like to assist with the case of class
dummies, please let me know.
From bef5e605ee14c4db85c96a3b30a765669570cac0 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Sat, 14 Dec 2024 20:26:47 +0100
Subject: [PATCH] Fortran: fix passing of NULL() to assumed-rank, derived type
dummy [PR104819]
PR fortran/104819
gcc/fortran/ChangeLog:
* interface.cc (compare_parameter): For the rank check, NULL()
inherits the rank of a provided MOLD argument.
(gfc_compare_actual_formal): Adjust check of NULL() actual argument
against formal to accept F2008 enhancements (allocatable dummy).
NULL() with MOLD argument retains a pointer/allocatable attribute.
* trans-expr.cc (conv_null_actual): Implement passing NULL() to
derived-type dummy with pointer/allocatable attribute, and ensure
that the actual rank is passed to an assumed-rank dummy.
(gfc_conv_procedure_call): Use it.
gcc/testsuite/ChangeLog:
* gfortran.dg/null_actual_7.f90: New test.
---
gcc/fortran/interface.cc | 42 +++++--
gcc/fortran/trans-expr.cc | 49 +++++++-
gcc/testsuite/gfortran.dg/null_actual_7.f90 | 123 ++++++++++++++++++++
3 files changed, 203 insertions(+), 11 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/null_actual_7.f90
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index fd39c01653e..8730269b251 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2756,7 +2756,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
rank_check = where != NULL && !is_elemental && formal_as
&& (formal_as->type == AS_ASSUMED_SHAPE
|| formal_as->type == AS_DEFERRED)
- && actual->expr_type != EXPR_NULL;
+ && !(actual->expr_type == EXPR_NULL
+ && actual->ts.type == BT_UNKNOWN);
/* Skip rank checks for NO_ARG_CHECK. */
if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
@@ -3230,6 +3231,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_array_ref *actual_arr_ref;
gfc_array_spec *fas, *aas;
bool pointer_dummy, pointer_arg, allocatable_arg;
+ bool procptr_dummy, optional_dummy, allocatable_dummy;
bool ok = true;
@@ -3382,15 +3384,33 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
goto match;
}
+ /* Allow passing of NULL() as disassociated pointer, procedure
+ pointer, or unallocated allocatable (F2008+) to a respective dummy
+ argument. */
+ pointer_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.pointer)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.class_pointer));
+
+ procptr_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.proc_pointer)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.proc_pointer));
+
+ optional_dummy = f->sym->attr.optional;
+
+ allocatable_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.allocatable));
+
if (a->expr->expr_type == EXPR_NULL
- && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
- && (f->sym->attr.allocatable || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))
- || (f->sym->ts.type == BT_CLASS
- && !CLASS_DATA (f->sym)->attr.class_pointer
- && (CLASS_DATA (f->sym)->attr.allocatable
- || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+ && !pointer_dummy
+ && !procptr_dummy
+ && !(optional_dummy
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ && !(allocatable_dummy
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0))
{
if (where
&& (!f->sym->attr.optional
@@ -3589,7 +3609,9 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
pointer_dummy = f->sym->attr.pointer;
}
- if (a->expr->expr_type != EXPR_VARIABLE)
+ if (a->expr->expr_type != EXPR_VARIABLE
+ && !(a->expr->expr_type == EXPR_NULL
+ && a->expr->ts.type != BT_UNKNOWN))
{
aas = NULL;
pointer_arg = false;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3718b0e645b..21dfc167bd7 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6398,7 +6398,7 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
static void
conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
{
- gcc_assert (fsym && !fsym->attr.optional);
+ gcc_assert (fsym && e->expr_type == EXPR_NULL);
/* Obtain the character length for a NULL() actual with a character
MOLD argument. Otherwise substitute a suitable dummy length.
@@ -6461,6 +6461,44 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
}
}
}
+ else if (fsym->ts.type == BT_DERIVED)
+ {
+ if (e->ts.type != BT_UNKNOWN)
+ /* MOLD is present. Pass a corresponding temporary NULL pointer.
+ For an assumed-rank dummy we provide a descriptor that passes
+ the correct rank. */
+ {
+ tree rank;
+ tree tmp = parmse->expr;
+
+ tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
+ rank = gfc_conv_descriptor_rank (tmp);
+ gfc_add_modify (&parmse->pre, rank,
+ build_int_cst (TREE_TYPE (rank), e->rank));
+ gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+ else
+ /* MOLD is not present. Use attributes from dummy argument, which is
+ not allowed to be assumed-rank. */
+ {
+ int dummy_rank;
+ tree tmp = parmse->expr;
+
+ if (fsym->attr.allocatable && fsym->attr.intent == INTENT_UNKNOWN)
+ fsym->attr.intent = INTENT_IN;
+ tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
+ dummy_rank = fsym->as ? fsym->as->rank : 0;
+ if (dummy_rank > 0)
+ {
+ tree rank = gfc_conv_descriptor_rank (tmp);
+ gfc_add_modify (&parmse->pre, rank,
+ build_int_cst (TREE_TYPE (rank), dummy_rank));
+ }
+ gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+ }
}
@@ -6699,6 +6737,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
}
+ else if (e->expr_type == EXPR_NULL
+ && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
+ && fsym && attr && (attr->pointer || attr->allocatable)
+ && fsym->ts.type == BT_DERIVED)
+ {
+ gfc_init_se (&parmse, NULL);
+ gfc_conv_expr_reference (&parmse, e);
+ conv_null_actual (&parmse, e, fsym);
+ }
else if (arg->expr->expr_type == EXPR_NULL
&& fsym && !fsym->attr.pointer
&& (fsym->ts.type != BT_CLASS
diff --git a/gcc/testsuite/gfortran.dg/null_actual_7.f90 b/gcc/testsuite/gfortran.dg/null_actual_7.f90
new file mode 100644
index 00000000000..ba3cd10f21b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_7.f90
@@ -0,0 +1,123 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=bounds" }
+!
+! PR fortran/104819 - passing NULL() to assumed-rank, derived type dummy
+
+program null_actual
+ implicit none
+ integer :: stop_base
+ type t
+ end type t
+ type(t), pointer :: p2(:,:) => NULL()
+ type(t), allocatable :: a2(:,:)
+
+ ! Basic tests passing unallocated allocatable / disassociated pointer
+ stop_base = 0
+ ! ... to assumed-rank dummy:
+ call chk_t_a (a2)
+ call chk_t_p (p2)
+ call chk_t_a_i (a2)
+ call chk_t_p_i (p2)
+ call opt_t_a (a2)
+ call opt_t_p (p2)
+ call opt_t_a_i (a2)
+ call opt_t_p_i (p2)
+ ! ... to rank-2 dummy:
+ call chk2_t_a (a2)
+ call chk2_t_p (p2)
+ call opt2_t_a (a2)
+ call opt2_t_p (p2)
+
+ ! Test NULL with MOLD argument
+ stop_base = 20
+ call chk_t_a (null(a2))
+ call chk_t_p (null(p2))
+ call chk_t_a_i (null(a2))
+ call chk_t_p_i (null(p2))
+ call opt_t_a (null(a2))
+ call opt_t_p (null(p2))
+ call opt_t_a_i (null(a2))
+ call opt_t_p_i (null(p2))
+ call chk2_t_a (null(a2))
+ call chk2_t_p (null(p2))
+ call opt2_t_a (null(a2))
+ call opt2_t_p (null(p2))
+
+ ! Test NULL without MOLD argument
+ stop_base = 40
+ call chk2_t_a (null())
+ call chk2_t_p (null())
+ call opt2_t_a (null())
+ call opt2_t_p (null())
+
+contains
+ ! Check assumed-rank dummy:
+ subroutine chk_t_a (x)
+ type(t), allocatable :: x(..)
+ if (rank (x) /= 2) stop stop_base + 1
+ if (allocated (x)) stop stop_base + 2
+ end subroutine chk_t_a
+
+ subroutine chk_t_a_i (x)
+ type(t), allocatable, intent(in) :: x(..)
+ if (rank (x) /= 2) stop stop_base + 3
+ if (allocated (x)) stop stop_base + 4
+ end subroutine chk_t_a_i
+
+ subroutine chk_t_p (x)
+ type(t), pointer :: x(..)
+ if (rank (x) /= 2) stop stop_base + 5
+ if (associated (x)) stop stop_base + 6
+ end subroutine chk_t_p
+
+ subroutine chk_t_p_i (x)
+ type(t), pointer, intent(in) :: x(..)
+ if (rank (x) /= 2) stop stop_base + 7
+ if (associated (x)) stop stop_base + 8
+ end subroutine chk_t_p_i
+
+ ! Check assumed-rank optional dummy:
+ subroutine opt_t_a (x)
+ type(t), optional, allocatable :: x(..)
+ if (.not. present (x)) stop stop_base + 11
+ end subroutine opt_t_a
+
+ subroutine opt_t_a_i (x)
+ type(t), optional, allocatable, intent(in) :: x(..)
+ if (.not. present (x)) stop stop_base + 12
+ end subroutine opt_t_a_i
+
+ subroutine opt_t_p (x)
+ type(t), optional, pointer :: x(..)
+ if (.not. present (x)) stop stop_base + 13
+ end subroutine opt_t_p
+
+ subroutine opt_t_p_i (x)
+ type(t), optional, pointer, intent(in) :: x(..)
+ if (.not. present (x)) stop stop_base + 14
+ end subroutine opt_t_p_i
+
+ ! Checks with fixed rank:
+ subroutine chk2_t_a (x)
+ type(t), allocatable :: x(:,:)
+ if (allocated (x)) stop stop_base + 15
+ end subroutine chk2_t_a
+
+ subroutine chk2_t_p (x)
+ type(t), pointer, intent(in) :: x(:,:)
+ if (associated (x)) stop stop_base + 16
+ end subroutine chk2_t_p
+
+ ! Checks with fixed rank optional dummy:
+ subroutine opt2_t_a (x)
+ type(t), optional, allocatable :: x(:,:)
+ if (.not. present (x)) stop stop_base + 17
+ if (allocated (x)) stop stop_base + 18
+ end subroutine opt2_t_a
+
+ subroutine opt2_t_p (x)
+ type(t), optional, pointer, intent(in) :: x(:,:)
+ if (.not. present (x)) stop stop_base + 19
+ if (associated (x)) stop stop_base + 20
+ end subroutine opt2_t_p
+end
--
2.35.3
