procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

trans-intrinsic.c (gfc_conv_associated): If pointer in first arguments has zero array length of zero string length...

Browse source 
2006-05-27  Paul Thomas  <pault@gcc.gnu.org>

	* trans-intrinsic.c (gfc_conv_associated): If pointer in first
	arguments has zero array length of zero string length, return
	false.

2006-05-27  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/associated_2.f90: New test.

From-SVN: r114149
This commit is contained in:
Paul Thomas 2006-05-27 05:16:57 +00:00
parent cc4c889131
commit f5b854f230
4 changed files with 74 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View file

@ -1,3 +1,9 @@
2006-05-27 Paul Thomas <pault@gcc.gnu.org>
* trans-intrinsic.c (gfc_conv_associated): If pointer in first
arguments has zero array length of zero string length, return
false.
2006-05-26 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/27524

26
gcc/fortran/trans-intrinsic.c
View file

@ -2813,6 +2813,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
tree tmp2;
tree tmp;
tree args, fndecl;
tree nonzero_charlen;
tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
gfc_init_se (&arg1se, NULL);
@ -2821,6 +2823,23 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
arg1->expr->ts.cl->backend_decl,
integer_zero_node);
nonzero_arraylen = NULL_TREE;
if (ss1 != gfc_ss_terminator)
{
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp = gfc_conv_descriptor_stride (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
tmp, integer_zero_node);
}
if (!arg2->expr)
{
/* No optional target. */
@ -2874,6 +2893,13 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
se->expr = build_function_call_expr (fndecl, args);
}
}
if (nonzero_charlen != NULL_TREE)
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_charlen);
if (nonzero_arraylen != NULL_TREE)
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_arraylen);
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}

4
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,7 @@
2006-05-27 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/associated_2.f90: New test.
2006-05-26 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR fortran/27524

38
gcc/testsuite/gfortran.dg/associated_2.f90 Normal file
View file

@ -0,0 +1,38 @@
! { dg-do run }
! Tests the implementation of 13.14.13 of the f95 standard
! in respect of zero character and zero array length.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
call test1 ()
call test2 ()
call test3 (0)
call test3 (1)
contains
subroutine test1 ()
integer, pointer, dimension(:, :, :) :: a, b
allocate (a(2,0,2))
b => a
if (associated (b)) call abort ()
allocate (a(2,1,2))
b => a
if (.not.associated (b)) call abort ()
end subroutine test1
subroutine test2 ()
integer, pointer, dimension(:, :, :) :: a, b
allocate (a(2,0,2))
b => a
if (associated (b, a)) call abort ()
allocate (a(2,1,2))
b => a
if (.not.associated (b, a)) call abort ()
end subroutine test2
subroutine test3 (n)
integer :: n
character(len=n), pointer, dimension(:) :: a, b
allocate (a(2))
b => a
if (associated (b, a) .and. (n .eq. 0)) call abort ()
if ((.not.associated (b, a)) .and. (n .ne. 0)) call abort ()
end subroutine test3
end