Re: [Fortran, Patch] PR60334 - Segmentation fault on character pointer assignments

[Andre Vehreschild <vehre at gmx dot de>]

Hi Paul,

thanks for the review. I do not have commits rights.

Unfortunately is the patch not ok. I figured today, that it needs an extension
when function calls that return deferred char len arrays are nested. In this
special case the string length would have been lost. The attached extended
version fixes this issue. 

Sorry for the duplicate work.

Bootstraps and regtests ok on x86_64-linux-gnu.

Regards,
	Andre

On Sun, 11 Jan 2015 16:11:10 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Dear Andre,
> 
> This is OK for trunk. I have not been keeping track of whether or not
> you have commit rights yet. If not, I will get to it sometime this
> week.
> 
> Thanks for the patch.
> 
> Paul
> 
> On 10 January 2015 at 15:59, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi all,
> >
> > attached patch fixes the bug reported in pr 60334. The issue here was that
> > the function's result being (a pointer to) a deferred length char array.
> > The string length for the result value was wrapped in a local variable,
> > whose value was never written back to the string length of the result. This
> > lead the calling routine to take the length of the result to be random
> > leading to a crash.
> >
> > This patch addresses the issue by preventing the instantiation of the local
> > var and instead using a reference to the parameter. This not only saves one
> > value on the stack, but also because for small functions the compiler will
> > hold all parameters in registers for a significant level of optimization,
> > all the overhead of memory access (I hope :-).
> >
> > Bootstraps and regtests ok on x86_64-linux-gnu.
> >
> > - Andre
> > --
> > Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> > Tel.: +49 241 9291018 * Email: vehre@gmx.de
> 
> 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de

Attachment: pr60334_2.clog
Description: Binary data

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 1e74125..86873f7 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1333,12 +1333,30 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	     (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
 	    sym->ts.u.cl->backend_decl = NULL_TREE;
 
-	  if (sym->ts.deferred && fun_or_res
-		&& sym->ts.u.cl->passed_length == NULL
-		&& sym->ts.u.cl->backend_decl)
+	  if (sym->ts.deferred && byref)
 	    {
-	      sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
-	      sym->ts.u.cl->backend_decl = NULL_TREE;
+	      /* The string length of a deferred char array is stored in the
+		 parameter at sym->ts.u.cl->backend_decl as a reference and
+		 marked as a result.  Exempt this variable from generating a
+		 temporary for it.  */
+	      if (sym->attr.result)
+		{
+		  /* We need to insert a indirect ref for param decls.  */
+		  if (sym->ts.u.cl->backend_decl
+		      && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
+		    sym->ts.u.cl->backend_decl =
+			build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
+		}
+	      /* For all other parameters make sure, that they are copied so
+		 that the value and any modifications are local to the routine
+		 by generating a temporary variable.  */
+	      else if (sym->attr.function
+		       && sym->ts.u.cl->passed_length == NULL
+		       && sym->ts.u.cl->backend_decl)
+		{
+		  sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+		  sym->ts.u.cl->backend_decl = NULL_TREE;
+		}
 	    }
 
 	  if (sym->ts.u.cl->backend_decl == NULL_TREE)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6bd3b03..a0390c1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5058,10 +5058,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	 so that the value can be returned.  */
       if (parmse.string_length && fsym && fsym->ts.deferred)
 	{
-	  tmp = parmse.string_length;
-	  if (TREE_CODE (tmp) != VAR_DECL)
-	    tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
-	  parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+	  if (INDIRECT_REF_P (parmse.string_length))
+	    /* In chains of functions/procedure calls the string_length already
+	       is a pointer to the variable holding the length.  Therefore
+	       remove the deref on call.  */
+	    parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
+	  else
+	    {
+	      tmp = parmse.string_length;
+	      if (TREE_CODE (tmp) != VAR_DECL)
+		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+	    }
 	}
 
       /* Character strings are passed as two parameters, a length and a
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_6.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_6.f90
index eb00778..a2fabe8 100644
--- a/gcc/testsuite/gfortran.dg/deferred_type_param_6.f90
+++ b/gcc/testsuite/gfortran.dg/deferred_type_param_6.f90
@@ -2,15 +2,23 @@
 !
 ! PR fortran/51055
 ! PR fortran/49110
-!
+! PR fortran/60334
 
 subroutine test()
   implicit none
   integer :: i = 5
   character(len=:), allocatable :: s1
+  character(len=:), pointer :: s2
+  character(len=5), target :: fifeC = 'FIVEC'
   call sub(s1, i)
   if (len(s1) /= 5) call abort()
   if (s1 /= "ZZZZZ") call abort()
+  s2 => subfunc()
+  if (len(s2) /= 5) call abort()
+  if (s2 /= "FIVEC") call abort()
+  s1 = addPrefix(subfunc())
+  if (len(s1) /= 7) call abort()
+  if (s1 /= "..FIVEC") call abort()
 contains
   subroutine sub(str,j)
     character(len=:), allocatable :: str
@@ -19,6 +27,17 @@ contains
     if (len(str) /= 5) call abort()
     if (str /= "ZZZZZ") call abort()
   end subroutine sub
+  function subfunc() result(res)
+    character(len=:), pointer :: res
+    res => fifec
+    if (len(res) /= 5) call abort()
+    if (res /= "FIVEC") call abort()
+  end function subfunc
+  function addPrefix(str) result(res)
+    character(len=:), pointer :: str
+    character(len=:), allocatable :: res
+    res = ".." // str
+  end function addPrefix
 end subroutine test
 
 program a