trans-intrinsic.c (gfc_conv_associated): If pointer in first arguments has zero…

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

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

gcc/fortran/ChangeLog

+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

gcc/fortran/trans-intrinsic.c

@@ -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);
 }
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/associated_2.f90

+! { 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
\ No newline at end of file