Re: Memory (de)allocation again..

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

François-Xavier,

> I just realized this patch was not OK. The zero-length conditions are
> only valid in presence of a TARGET (see F2003 13.7.13):
>
> Case (i): If TARGET is absent, the result is true if POINTER is
> associated with a target
> and false if it is not.

Nuts! It's what the F95 standard says too.

> I am now a bit confused about whether we should move the condition
> inside the block for "An optional target", or simply remove it.

The attached patch corrects the defect and the testcase is modified 
appropriately.

> Sorry for not doing the review right, 


The apologies are mine for leaping in too quickly.  Your 48 hour 
deadline made me rush at it.

All the best and thanks

Paul
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 114149)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 2823,2845 ****
    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.  */
--- 2823,2828 ----
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 2865,2870 ****
--- 2848,2860 ----
      {
        /* An optional target.  */
        ss2 = gfc_walk_expr (arg2->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);
+ 
        if (ss1 == gfc_ss_terminator)
          {
            /* A pointer to a scalar.  */
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 2878,2889 ****
--- 2868,2890 ----
          }
        else
          {
+ 
+ 	  /* An array pointer of zero length is not associated if target is
+ 	     present.  */
+ 	  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);
+ 
            /* A pointer to an array, call library function _gfor_associated.  */
            gcc_assert (ss2 != gfc_ss_terminator);
            args = NULL_TREE;
            arg1se.want_pointer = 1;
            gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
            args = gfc_chainon_list (args, arg1se.expr);
+ 
            arg2se.want_pointer = 1;
            gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
            gfc_add_block_to_block (&se->pre, &arg2se.pre);
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 2891,2905 ****
            args = gfc_chainon_list (args, arg2se.expr);
            fndecl = gfor_fndecl_associated;
            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);
  }
  
--- 2892,2910 ----
            args = gfc_chainon_list (args, arg2se.expr);
            fndecl = gfor_fndecl_associated;
            se->expr = build_function_call_expr (fndecl, args);
+ 	  if (nonzero_arraylen != NULL_TREE)
+ 	    se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ 			       se->expr, nonzero_arraylen);
+ 
          }
  
!       /* If target is present zero character length pointers cannot
! 	 be associated.  */
!       if (nonzero_charlen != NULL_TREE)
! 	se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
! 			   se->expr, nonzero_charlen);
!     }
! 
    se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
  }
  
Index: gcc/testsuite/gfortran.dg/associated_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associated_2.f90	(revision 114149)
--- gcc/testsuite/gfortran.dg/associated_2.f90	(working copy)
*************** contains
*** 13,38 ****
      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
--- 13,49 ----
      integer, pointer, dimension(:, :, :)  :: a, b
      allocate (a(2,0,2))
      b => a
! ! Even though b is zero length, associated returns true because
! ! the target argument is not present (case (i))
!     if (.not. associated (b)) call abort ()
!     deallocate (a)
      allocate (a(2,1,2))
      b => a
      if (.not.associated (b)) call abort ()
+     deallocate (a)
    end subroutine test1
    subroutine test2 ()
      integer, pointer, dimension(:, :, :)  :: a, b
      allocate (a(2,0,2))
      b => a
+ ! Associated returns false because target is present (case(iii)).
      if (associated (b, a)) call abort ()
+     deallocate (a)
      allocate (a(2,1,2))
      b => a
      if (.not.associated (b, a)) call abort ()
+     deallocate (a)
    end subroutine test2
    subroutine test3 (n)
      integer :: n
      character(len=n), pointer, dimension(:)  :: a, b
      allocate (a(2))
      b => a
+ ! Again, with zero character length associated returns false
+ ! if target is present.
      if (associated (b, a) .and. (n .eq. 0)) call abort ()
+ !
      if ((.not.associated (b, a))  .and. (n .ne. 0)) call abort ()
+     deallocate (a)
    end subroutine test3
! end