[Path, fortran] PR35959 - Recursive function with allocatable array

[Path, fortran] PR35959 - Recursive function with allocatable array

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 1425 bytes --]

:ADDPATCH fortran:

This is a bug that I caused.  Default initializers of derived types
with allocatable components were being applied by making them static.
This was OK up to the point where recursive procedures come into the
picture.  Instead of a new instance of local variables fo each scope,
we wound up with one, in this case, and the reporter's test fails.
The fix is to use an existing initialization procedure in trans-decl.c
and to apply it after nullification of the allocatable components.
Two existing tests have to be modified to allow for the increased
occurrences of builtin_free.  The testcase is essentially the
reporter's.

Bootstrapped and regtested on x86_ia64/fc8 - OK for trunk and 4.3?

Paul

2008-04-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/35959
	* trans-decl.c (gfc_init_default_dt): Add gfc_ prefix to name
	and allow for NULL body.  Change all references from
	init_default_dt to gfc_init_default_dt.
	* trans.h : Add prototype for gfc_init_default_dt.
	* trans-array.c (gfc_trans_deferred_vars): After nullification
	call gfc_init_default_dt for derived types with allocatable
	components.

2008-04-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/35959
	* gfortran.dg/alloc_comp_default_init_2.f90: New test.
	* gfortran.dg/alloc_comp_basics_1.f90: Change occurrences of
	"builtin_free" to 27.
	* gfortran.dg/alloc_comp_constructor_1.f90: Change occurrences
	of "builtin_free" to 21.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch; name=submit.diff, Size: 7162 bytes --]

Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 134362)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_get_symbol_decl (gfc_symbol *);
*** 405,410 ****
--- 405,413 ----
  /* Build a static initializer.  */
  tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
  
+ /* Assign a default initializer to a derived type.  */
+ tree gfc_init_default_dt (gfc_symbol *, tree);
+ 
  /* Substitute a temporary variable in place of the real one.  */
  void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
  
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 134362)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 5569,5574 ****
--- 5569,5579 ----
  	  rank = sym->as ? sym->as->rank : 0;
  	  tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
  	  gfc_add_expr_to_block (&fnblock, tmp);
+ 	  if (sym->value)
+ 	    {
+ 	      tmp = gfc_init_default_dt (sym, NULL);
+ 	      gfc_add_expr_to_block (&fnblock, tmp);
+ 	    }
  	}
      }
    else if (!GFC_DESCRIPTOR_TYPE_P (type))
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 134362)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 512,520 ****
       SAVE_EXPLICIT.  */
    if (!sym->attr.use_assoc
  	&& (sym->attr.save != SAVE_NONE || sym->attr.data
- 	      || (sym->ts.type == BT_DERIVED
- 		    && sym->ts.derived->attr.alloc_comp
- 		    && sym->value)
  	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
      TREE_STATIC (decl) = 1;
  
--- 512,517 ----
*************** gfc_trans_vla_type_sizes (gfc_symbol *sy
*** 2532,2539 ****
  
  /* Initialize a derived type by building an lvalue from the symbol
     and using trans_assignment to do the work.  */
! static tree
! init_default_dt (gfc_symbol * sym, tree body)
  {
    stmtblock_t fnblock;
    gfc_expr *e;
--- 2529,2536 ----
  
  /* Initialize a derived type by building an lvalue from the symbol
     and using trans_assignment to do the work.  */
! tree
! gfc_init_default_dt (gfc_symbol * sym, tree body)
  {
    stmtblock_t fnblock;
    gfc_expr *e;
*************** init_default_dt (gfc_symbol * sym, tree 
*** 2553,2559 ****
      }
    gfc_add_expr_to_block (&fnblock, tmp);
    gfc_free_expr (e);
!   gfc_add_expr_to_block (&fnblock, body);
    return gfc_finish_block (&fnblock);
  }
  
--- 2550,2557 ----
      }
    gfc_add_expr_to_block (&fnblock, tmp);
    gfc_free_expr (e);
!   if (body)
!     gfc_add_expr_to_block (&fnblock, body);
    return gfc_finish_block (&fnblock);
  }
  
*************** init_intent_out_dt (gfc_symbol * proc_sy
*** 2571,2577 ****
  	  && f->sym->ts.type == BT_DERIVED
  	  && !f->sym->ts.derived->attr.alloc_comp
  	  && f->sym->value)
!       body = init_default_dt (f->sym, body);
  
    gfc_add_expr_to_block (&fnblock, body);
    return gfc_finish_block (&fnblock);
--- 2569,2575 ----
  	  && f->sym->ts.type == BT_DERIVED
  	  && !f->sym->ts.derived->attr.alloc_comp
  	  && f->sym->value)
!       body = gfc_init_default_dt (f->sym, body);
  
    gfc_add_expr_to_block (&fnblock, body);
    return gfc_finish_block (&fnblock);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2672,2678 ****
  			     && sym->value
  			     && !sym->attr.data
  			     && sym->attr.save == SAVE_NONE)
! 		    fnbody = init_default_dt (sym, fnbody);
  
  		  gfc_get_backend_locus (&loc);
  		  gfc_set_backend_locus (&sym->declared_at);
--- 2670,2676 ----
  			     && sym->value
  			     && !sym->attr.data
  			     && sym->attr.save == SAVE_NONE)
! 		    fnbody = gfc_init_default_dt (sym, fnbody);
  
  		  gfc_get_backend_locus (&loc);
  		  gfc_set_backend_locus (&sym->declared_at);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2732,2738 ****
  		 && sym->value
  		 && !sym->attr.data
  		 && sym->attr.save == SAVE_NONE)
! 	fnbody = init_default_dt (sym, fnbody);
        else
  	gcc_unreachable ();
      }
--- 2730,2736 ----
  		 && sym->value
  		 && !sym->attr.data
  		 && sym->attr.save == SAVE_NONE)
! 	fnbody = gfc_init_default_dt (sym, fnbody);
        else
  	gcc_unreachable ();
      }
Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(revision 134362)
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(working copy)
*************** contains
*** 139,144 ****
      end subroutine check_alloc2
  
  end program alloc
! ! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  ! { dg-final { cleanup-modules "alloc_m" } }
--- 139,144 ----
      end subroutine check_alloc2
  
  end program alloc
! ! { dg-final { scan-tree-dump-times "builtin_free" 27 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  ! { dg-final { cleanup-modules "alloc_m" } }
Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90	(revision 134362)
--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90	(working copy)
*************** contains
*** 104,108 ****
      end function blaha
  
  end program test_constructor
! ! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
--- 104,108 ----
      end function blaha
  
  end program test_constructor
! ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_default_init_2.f90	(revision 0)
***************
*** 0 ****
--- 1,26 ----
+ ! { dg-do run }
+ ! Tests the fix for PR35959, in which the structure subpattern was declared static
+ ! so that this test faied on the second recursive call.
+ !
+ ! Contributed by Michaël Baudin <michael.baudin@gmail.com>
+ !
+ program testprog
+   type :: t_type
+     integer, dimension(:), allocatable :: chars
+   end type t_type
+   integer, save :: callnb = 0
+   type(t_type) :: this
+   allocate ( this % chars ( 4))
+   if (.not.recursivefunc (this) .or. (callnb .ne. 10)) call abort ()
+ contains
+   recursive function recursivefunc ( this ) result ( match )
+     type(t_type), intent(in) :: this
+     type(t_type) :: subpattern
+     logical :: match
+     callnb = callnb + 1
+     match = (callnb == 10)
+     if ((.NOT. allocated (this % chars)) .OR. match) return
+     allocate ( subpattern % chars ( 4 ) )
+     match = recursivefunc ( subpattern )
+   end function recursivefunc
+ end program testprog

Re: [Path, fortran] PR35959 - Recursive function with allocatable array

[Paul Richard Thomas]

Dominique,

> Your patch works as expected without regression on i686-apple-darwin9 provided
> I use
>
> ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
>
> in gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90. At this occasion I discovered
> that I had made a similar adjustment for i686-apple-darwin9 some time ago
> (no memory of it).

This is worrying.  Before I blindly apply this fix, could you please
send me the original code both with and without the patch applied.

Does anybody know how there could be this OS sensitivity and, if it's
explicable, how I modify the test to cope with it?

Cheers

Paul

Re: [Path, fortran] PR35959 - Recursive function with allocatable array

[Dominique Dhumieres]

> This is worrying. ...

I have found the source: it is your patch for pr34143

*** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90   (revision 132120)
--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90   (working copy)
*************** contains
*** 139,144 ****
      end subroutine check_alloc2
  
  end program alloc
! ! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  ! { dg-final { cleanup-modules "alloc_m" } }
--- 139,144 ----
      end subroutine check_alloc2
  
  end program alloc
! ! { dg-final { scan-tree-dump-times "builtin_free" 18 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  ! { dg-final { cleanup-modules "alloc_m" } }

Dominique