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))
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;
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
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;
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.
}
}
}
+ 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);
+ }
+ }
}
}
}
}
+ 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
