[Patch, fortran] PR64120

[Paul Richard Thomas]

I found this 'obvious' fix, while going through PRs assigned to me.

Regtests. OK for mainline?

Cheers

Paul


Fortran: Allocatable automatic charlen must not be saved [PR64120].

2023-10-31  Paul Thomas  <pa...@gcc.gnu.org>

gcc/fortran
PR fortran/64120
* trans-decl.cc (gfc_trans_deferred_vars): Detect automatic
character length and allow allocatable variants to be nullified
on scope entry and freed on scope exit. Remove trailing white
space.

gcc/testsuite/
PR fortran/64120
* gfortran.dg/pr64120_2.f90: New test.

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index a3f037bd07b..5e0e78ace40 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4689,9 +4689,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 				&& (sym->ts.u.derived->attr.alloc_comp
 				    || gfc_is_finalizable (sym->ts.u.derived,
 							   NULL));
+      bool automatic_char_len;
       if (sym->assoc)
 	continue;
 
+      automatic_char_len = sym->ts.type == BT_CHARACTER
+			   && sym->ts.u.cl && sym->ts.u.cl->length
+			   && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE;
+
       /* Set the vptr of unlimited polymorphic pointer variables so that
 	 they do not cause segfaults in select type, when the selector
 	 is an intrinsic type.  */
@@ -4951,7 +4956,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		    || (sym->ts.type == BT_CLASS
 			&& CLASS_DATA (sym)->attr.allocatable)))
 	{
-	  if (!sym->attr.save && flag_max_stack_var_size != 0)
+	  if ((!sym->attr.save || automatic_char_len)
+	       && flag_max_stack_var_size != 0)
 	    {
 	      tree descriptor = NULL_TREE;
 
@@ -5210,8 +5216,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	tree tmp = lookup_attribute ("omp allocate",
 				     DECL_ATTRIBUTES (n->sym->backend_decl));
 	tmp = TREE_VALUE (tmp);
-	TREE_PURPOSE (tmp) = se.expr;	
-	TREE_VALUE (tmp) = align;	
+	TREE_PURPOSE (tmp) = se.expr;
+	TREE_VALUE (tmp) = align;
 	TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
 	TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
       }

! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! Test fix of second testcase in PR64120.
! The first testcase is allocatable_scalar_14.f90.
!
! Contributed by Francois-Xavier Coudert  <fxcoud...@gcc.gnu.org>
!
program test
   logical :: L
   L = g(1)
   write(*,*) L
   L = g(2)
   write(*,*) L
contains
  logical function g(x)
      integer :: x
      character(len=x), allocatable :: s
      save
      if(.NOT.allocated(s)) then
        allocate(s)
        g = .FALSE.
      else
        g = .TRUE.
      end if
      write(*,*) len(s)
  end function g
end
! { dg-final { scan-tree-dump-times "s = 0B;" 2 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 1 "original" } }