re PR fortran/47523 (Concatenation with deferred length character with lhs variable)

2011-01-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47523
	* trans-expr.c (gfc_trans_assignment_1): If the rhs is an op
	expr and is assigned to a deferred character length scalar,
	make sure that the function is called before reallocation,
	so that the length is available. Include procedure pointer
	and procedure pointer component rhs as well.

2011-01-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47523
	* trans-expr.c (gfc_trans_assignment_1): If the rhs is an op
	expr and is assigned to a deferred character length scalar,
	make sure that the function is called before reallocation,
	so that the length is available. Include procedure pointer
	and procedure pointer component rhs as well.

	PR fortran/45170
	PR fortran/35810
	PR fortran/47350
	* gfortran.dg/allocatable_function_5.f90: New test not added by
	mistake on 2011-01-28.

From-SVN: r169413

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b1df4053d52bf8752aecb2602017257f8e4547db..ce56256017b8f9a6a352194ee310041afbe73d4e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2011-01-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47523
+       * trans-expr.c (gfc_trans_assignment_1): If the rhs is an op
+       expr and is assigned to a deferred character length scalar,
+       make sure that the function is called before reallocation,
+       so that the length is available. Include procedure pointer
+       and procedure pointer component rhs as well.
+
+       PR fortran/45170
+       PR fortran/35810
+       PR fortran/47350
+       * gfortran.dg/allocatable_function_5.f90: New test not added by
+       mistake on 2011-01-28.
+
 2011-01-29  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/47531

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9bbe791d88bfdc1926602e6701662d53fa2b90fd..96828020689c7377b31a3a9b7c22d47c7da5ef75 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5977,6 +5977,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   stmtblock_t body;
   bool l_is_temp;
   bool scalar_to_array;
+  bool def_clen_func;
   tree string_length;
   int n;
 
@@ -6097,10 +6098,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   /* For a deferred character length function, the function call must
      happen before the (re)allocation of the lhs, otherwise the character
      length of the result is not known.  */
+  def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
+                          || (expr2->expr_type == EXPR_COMPCALL)
+                          || (expr2->expr_type == EXPR_PPC))
+                      && expr2->ts.deferred);
   if (gfc_option.flag_realloc_lhs
-       && expr2->expr_type == EXPR_FUNCTION
        && expr2->ts.type == BT_CHARACTER
-       && expr2->ts.deferred)
+       && (def_clen_func || expr2->expr_type == EXPR_OP)
+       && expr1->ts.deferred)
     gfc_add_block_to_block (&block, &rse.pre);
 
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ece39bc30e0bb837400599d03b7724809d8d7c25..a9e16459ecf8659ae79eb4bcc6cfb16b20f2085a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47523
+       * gfortran.dg/realloc_on_assign_5.f03: New test.
+
 2011-01-29  Ulrich Weigand  <Ulrich.Weigand@de.ibm.com>
 
        * gfortran.dg/bessel_6.f90: XFAIL on spu-*-*.
@@ -66,9 +71,8 @@
        PR fortran/47350
        * gfortran.dg/realloc_on_assign_3.f03: New test.
        * gfortran.dg/realloc_on_assign_4.f03: New test.
-       * gfortran.dg/realloc_on_assign_5.f90: New test.
        * gfortran.dg/allocatable_function_5.f90: New test.
-       * gfortran.dg/allocate_deferred_char_scalar_1.f90: New test.
+       * gfortran.dg/allocate_deferred_char_scalar_1.f03: New test.
        * gfortran.dg/deferred_type_param_2.f90: Remove two "not yet
        implemented" dg-errors.
 

diff --git a/gcc/testsuite/gfortran.dg/allocatable_function_5.f90 b/gcc/testsuite/gfortran.dg/allocatable_function_5.f90
new file mode 100644 (file)
index 0000000..8e7d49b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_function_5.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+! Tests function return of deferred length scalars.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module m
+contains
+  function mfoo (carg) result(res)
+    character (:), allocatable :: res
+    character (*) :: carg
+    res = carg(2:4)
+  end function
+  function mbar (carg)
+    character (:), allocatable :: mbar
+    character (*) :: carg
+    mbar = carg(2:13)
+  end function
+end module
+
+  use m
+  character (:), allocatable :: lhs
+  lhs = foo ("foo calling ")
+  if (lhs .ne. "foo") call abort
+  if (len (lhs) .ne. 3) call abort
+  deallocate (lhs)
+  lhs = bar ("bar calling - baaaa!")
+  if (lhs .ne. "bar calling") call abort
+  if (len (lhs) .ne. 12) call abort
+  deallocate (lhs)
+  lhs = mfoo ("mfoo calling ")
+  if (lhs .ne. "foo") call abort
+  if (len (lhs) .ne. 3) call abort
+  deallocate (lhs)
+  lhs = mbar ("mbar calling - baaaa!")
+  if (lhs .ne. "bar calling") call abort
+  if (len (lhs) .ne. 12) call abort
+contains
+  function foo (carg) result(res)
+    character (:), allocatable :: res
+    character (*) :: carg
+    res = carg(1:3)
+  end function
+  function bar (carg)
+    character (:), allocatable :: bar
+    character (*) :: carg
+    bar = carg(1:12)
+  end function
+end

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03
new file mode 100644 (file)
index 0000000..db4233d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_5.f03
@@ -0,0 +1,18 @@
+! { dg-do run }
+! Test the fix for PR47523 in which concatenations did not work
+! correctly with assignments to deferred character length scalars.
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+!
+program main
+  implicit none
+  character(:), allocatable :: a, b
+  a = 'a'
+  if (a .ne. 'a') call abort
+  a = a // 'x'
+  if (a .ne. 'ax') call abort
+  if (len (a) .ne. 2) call abort
+  a = (a(2:2))
+  if (a .ne. 'x') call abort
+  if (len (a) .ne. 1) call abort
+end program main