[Patch, fortran] PR34438 - gfortran not compliant w.r.t default initialization of derived type component and implicit SAVE attribute

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

:ADDPATCH fortran:

This patch is described by the ChangeLogs and the comments in the
text.  The problem is that default initializers at present force the
variable to be TREE_STATIC or SAVED.  Thus they are only initialized
once during the execution of a program.  The standard requires that
they be initialized every time they come into scope.  This is
accomplished by building an lvalue expression from the symbol and
deploying gfc_trans_assignment with the 'value' expression as the
lvalue.

The testcase contains, more or less, the two provided by the reporter.

Bootstrapped and regtested on x86_ia64/FC5  - OK for trunk?

Paul

-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

Attachment: commit.msg
Description: Binary data

Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 130987)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 517,524 ****
        TREE_STATIC (decl) = 1;
      }
  
!   if ((sym->attr.save || sym->attr.data || sym->value)
!       && !sym->attr.use_assoc)
      TREE_STATIC (decl) = 1;
  
    if (sym->attr.volatile_)
--- 517,531 ----
        TREE_STATIC (decl) = 1;
      }
  
!   /* Derived types are a bit peculiar because of the possibility of
!      a default initializer; this must be applied each time the variable
!      comes into scope it therefore need not be static.  These variables
!      are SAVE_NONE but have an initializer.  Otherwise explicitly
!      intitialized variables are SAVE_IMPLICIT and explicitly saved are
!      SAVE_EXPLICIT.  */
!   if (!sym->attr.use_assoc
! 	&& (sym->attr.save != SAVE_NONE || sym->attr.data
! 	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
      TREE_STATIC (decl) = 1;
  
    if (sym->attr.volatile_)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 995,1000 ****
--- 1002,1015 ----
  
    if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
      gfc_defer_symbol_init (sym);
+   /* This applies a derived type default initializer.  */
+   else if (sym->ts.type == BT_DERIVED
+ 	     && sym->attr.save == SAVE_NONE
+ 	     && !sym->attr.data
+ 	     && !sym->attr.allocatable
+ 	     && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+ 	     && !sym->attr.use_assoc)
+     gfc_defer_symbol_init (sym);
  
    gfc_finish_var_decl (decl, sym);
  
*************** gfc_trans_vla_type_sizes (gfc_symbol *sy
*** 2572,2615 ****
  }
  
  
  /* Initialize INTENT(OUT) derived type dummies.  */
  static tree
  init_intent_out_dt (gfc_symbol * proc_sym, tree body)
  {
    stmtblock_t fnblock;
    gfc_formal_arglist *f;
-   gfc_expr *tmpe;
-   tree tmp;
-   tree present;
  
    gfc_init_block (&fnblock);
- 
    for (f = proc_sym->formal; f; f = f->next)
!     {
!       if (f->sym && f->sym->attr.intent == INTENT_OUT
! 	    && f->sym->ts.type == BT_DERIVED
! 	    && !f->sym->ts.derived->attr.alloc_comp
! 	    && f->sym->value)
! 	{
! 	  gcc_assert (!f->sym->attr.allocatable);
! 	  gfc_set_sym_referenced (f->sym);
! 	  tmpe = gfc_lval_expr_from_sym (f->sym);
! 	  tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
! 
! 	  present = gfc_conv_expr_present (f->sym);
! 	  tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
! 			tmp, build_empty_stmt ());
! 	  gfc_add_expr_to_block (&fnblock, tmp);
! 	  gfc_free_expr (tmpe);
! 	}
!     }
  
    gfc_add_expr_to_block (&fnblock, body);
    return gfc_finish_block (&fnblock);
  }
  
  
- 
  /* Generate function entry and exit code, and add it to the function body.
     This includes:
      Allocation and initialization of array variables.
--- 2587,2633 ----
  }
  
  
+ /* 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;
+   tree tmp;
+ 
+   gfc_init_block (&fnblock);
+   gcc_assert (!sym->attr.allocatable);
+   gfc_set_sym_referenced (sym);
+   e = gfc_lval_expr_from_sym (sym);
+   tmp = gfc_trans_assignment (e, sym->value, false);
+   gfc_add_expr_to_block (&fnblock, tmp);
+   gfc_free_expr (e);
+   gfc_add_expr_to_block (&fnblock, body);
+   return gfc_finish_block (&fnblock);
+ }
+ 
+ 
  /* Initialize INTENT(OUT) derived type dummies.  */
  static tree
  init_intent_out_dt (gfc_symbol * proc_sym, tree body)
  {
    stmtblock_t fnblock;
    gfc_formal_arglist *f;
  
    gfc_init_block (&fnblock);
    for (f = proc_sym->formal; f; f = f->next)
!     if (f->sym && f->sym->attr.intent == INTENT_OUT
! 	  && 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);
  }
  
  
  /* Generate function entry and exit code, and add it to the function body.
     This includes:
      Allocation and initialization of array variables.
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2698,2703 ****
--- 2716,2726 ----
  		      seen_trans_deferred_array = true;
  		      fnbody = gfc_trans_deferred_array (sym, fnbody);
  		    }
+ 		  else if (sym->ts.type == BT_DERIVED
+ 			     && 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);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 2753,2758 ****
--- 2776,2786 ----
  	  fnbody = gfc_trans_assign_aux_var (sym, fnbody);
  	  gfc_set_backend_locus (&loc);
  	}
+       else if (sym->ts.type == BT_DERIVED
+ 		 && sym->value
+ 		 && !sym->attr.data
+ 		 && sym->attr.save == SAVE_NONE)
+ 	fnbody = init_default_dt (sym, fnbody);
        else
  	gcc_unreachable ();
      }
Index: /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90	(revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/default_initialization_3.f90	(revision 0)
***************
*** 0 ****
--- 1,76 ----
+ ! { dg-do run }
+ ! Test the fix for PR34438, in which default initializers
+ ! forced the derived type to be static; ie. initialized once
+ ! during the lifetime of the programme.  Instead, they should
+ ! be initialized each time they come into scope.
+ !
+ ! Contributed by Sven Buijssen <sven.buijssen@math.uni-dortmund.de>
+ !
+ module demo
+    type myint
+      integer :: bar = 42
+    end type myint
+ end module demo
+ 
+ ! As the name implies, this was the original testcase
+ ! provided by the contributor....
+ subroutine original
+   use demo
+   integer val1 (6)
+   integer val2 (6)
+   call recfunc (1)
+   if (any (val1 .ne. (/1, 2, 3, 1, 2, 3/))) call abort ()
+   if (any (val2 .ne. (/1, 2, 3, 4, 4, 4/))) call abort ()
+ contains
+ 
+   recursive subroutine recfunc (ivalue)
+     integer, intent(in) :: ivalue
+     type(myint) :: foo1
+     type(myint) :: foo2 = myint (99)
+     foo1%bar = ivalue
+     foo2%bar = ivalue
+     if (ivalue .le. 3) then
+       val1(ivalue) = foo1%bar
+       val2(ivalue) = foo2%bar
+       call recfunc (ivalue + 1)
+       val1(ivalue + 3) = foo1%bar
+       val2(ivalue + 3) = foo2%bar
+     endif
+   end subroutine recfunc
+ end subroutine original
+ 
+ ! ...who came up with this one too.
+ subroutine func (ivalue, retval1, retval2)
+   use demo
+   integer, intent(in) :: ivalue
+   type(myint) :: foo1
+   type(myint) :: foo2 = myint (77)
+   type(myint) :: retval1
+   type(myint) :: retval2
+   retval1 = foo1
+   retval2 = foo2
+   foo1%bar = 999
+   foo2%bar = 999
+ end subroutine func
+ 
+ subroutine other
+   use demo
+   interface
+     subroutine func(ivalue, rv1, rv2)
+       use demo
+       integer, intent(in) :: ivalue
+       type(myint) :: foo, rv1, rv2
+    end subroutine func
+   end interface
+   type(myint) :: val1, val2
+   call func (1, val1, val2)
+   if ((val1%bar .ne. 42) .or. (val2%bar .ne. 77)) call abort ()
+   call func (2, val1, val2)
+   if ((val1%bar .ne. 42) .or. (val2%bar .ne. 999)) call abort ()
+ 
+ end subroutine other
+ 
+ ! Run both tests.
+   call original
+   call other
+ end