===================================================================
*************** gfc_conv_associated (gfc_se *se, gfc_exp
gfc_se arg2se;
tree tmp2;
tree tmp;
- tree nonzero_charlen;
tree nonzero_arraylen;
gfc_ss *ss;
bool scalar;
*************** gfc_conv_associated (gfc_se *se, gfc_exp
if (arg2->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg2->expr);
- nonzero_charlen = NULL_TREE;
- if (arg1->expr->ts.type == BT_CHARACTER)
- nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- arg1->expr->ts.u.cl->backend_decl,
- build_zero_cst
- (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl)));
if (scalar)
{
/* A pointer to a scalar. */
*************** gfc_conv_associated (gfc_se *se, gfc_exp
/* If target is present zero character length pointers cannot
be associated. */
! if (nonzero_charlen != NULL_TREE)
! se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
! logical_type_node,
! se->expr, nonzero_charlen);
}
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
/* If target is present zero character length pointers cannot
be associated. */
! if (arg1->expr->ts.type == BT_CHARACTER)
! {
! tmp = arg1se.string_length;
! tmp = fold_build2_loc (input_location, NE_EXPR,
! logical_type_node, tmp,
! build_zero_cst (TREE_TYPE (tmp)));
! se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
! logical_type_node, se->expr, tmp);
! }
}
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR92959, where compilation of ASSOCIATED segfaulted in 's1' and 's2'.
+ !
+ ! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+ !
+ program p
+ character(:), pointer :: x, y => NULL()
+ character, pointer :: u, v => NULL ()
+ character(4), target :: tgt = "abcd"
+
+ ! Manifestly not associated
+ x => tgt
+ u => tgt(1:1)
+ call s1 (.false., 1)
+ call s2 (.false., 2)
+ ! Manifestly associated
+ y => x
+ v => u
+ call s1 (.true., 3)
+ call s2 (.true., 4)
+ ! Zero sized storage sequences must give a false.
+ y => tgt(1:0)
+ x => y
+ call s1 (.false., 5)
+ contains
+ subroutine s1 (state, err_no)
+ logical :: state
+ integer :: err_no
+ if (associated(x, y) .neqv. state) stop err_no
+ end
+ subroutine s2 (state, err_no)
+ logical :: state
+ integer :: err_no
+ if (associated(u, v) .neqv. state) stop err_no
+ end
+ end