PATCH: PR fortran/23634: temporary array of character ICE with non constant size

H. J. Lu hjl@lucon.org
Wed Apr 5 05:00:00 GMT 2006


On Tue, Apr 04, 2006 at 07:47:17PM -0700, H. J. Lu wrote:
> On Tue, Apr 04, 2006 at 11:38:43PM +0200, Paul Thomas wrote:
> 
> I will submit a combined path with your testcase.

Here is the patch I checked in.

> 
> > Do not commit to 4.1 for a good few days, please.
> > 
> 
> 

I am also enclosing 4.1 patch here.

Thanks.


H.J.
----
gcc/fortran/

2006-04-04  H.J. Lu  <hongjiu.lu@intel.com>

	PR fortran/25619
	* trans-array.c (gfc_conv_expr_descriptor): Only dereference
	character pointer when copying temporary.

	PR fortran/23634
	* trans-array.c (gfc_conv_expr_descriptor): Properly copy
	temporary character with non constant size.

gcc/testsuite/

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

	PR fortran/23634
	PR fortran/25619
	* gfortran.dg/actual_array_constructor_1.f90: New testcase.

--- gcc/fortran/trans-array.c.array	2006-04-02 10:50:34.000000000 -0700
+++ gcc/fortran/trans-array.c	2006-04-04 21:32:37.000000000 -0700
@@ -3973,23 +3973,32 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       loop.temp_ss->next = gfc_ss_terminator;
       if (expr->ts.type == BT_CHARACTER)
 	{
-	  gcc_assert (expr->ts.cl && expr->ts.cl->length
-		      && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
-	  loop.temp_ss->string_length = gfc_conv_mpz_to_tree
-			(expr->ts.cl->length->value.integer,
-			 expr->ts.cl->length->ts.kind);
-	  expr->ts.cl->backend_decl = loop.temp_ss->string_length;
-	}
-        loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-
-      /* ... which can hold our string, if present.  */
-      if (expr->ts.type == BT_CHARACTER)
-	{
-	  loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+	  if (expr->ts.cl
+	      && expr->ts.cl->length
+	      && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      expr->ts.cl->backend_decl
+		= gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
+					expr->ts.cl->length->ts.kind);
+	      loop.temp_ss->data.temp.type
+		= gfc_typenode_for_spec (&expr->ts);
+	      loop.temp_ss->string_length
+		= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+	    }
+	  else
+	    {
+	      loop.temp_ss->data.temp.type
+		= gfc_typenode_for_spec (&expr->ts);
+	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+	    }
 	  se->string_length = loop.temp_ss->string_length;
 	}
       else
-	loop.temp_ss->string_length = NULL;
+	{
+	  loop.temp_ss->data.temp.type
+	    = gfc_typenode_for_spec (&expr->ts);
+	  loop.temp_ss->string_length = NULL;
+	}
       loop.temp_ss->data.temp.dimen = loop.dimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
@@ -4022,7 +4031,8 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       if (expr->ts.type == BT_CHARACTER)
 	{
 	  gfc_conv_expr (&rse, expr);
-	  rse.expr = build_fold_indirect_ref (rse.expr);
+	  if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+	    rse.expr = build_fold_indirect_ref (rse.expr);
 	}
       else
         gfc_conv_expr_val (&rse, expr);
--- gcc/testsuite/gfortran.dg/actual_array_constructor_1.f90.array	2006-04-04 21:34:40.000000000 -0700
+++ gcc/testsuite/gfortran.dg/actual_array_constructor_1.f90	2006-04-04 21:31:33.000000000 -0700
@@ -0,0 +1,82 @@
+! { dg-do run }
+! Test the fix by HJ Lu for PR23634 and friends. All involve the ICE
+! that arose from a character array constructor usedas an actual
+! argument.
+!
+! The various parts of this test are taken from the PRs.
+!
+! Test PR26491
+module global
+  public    p, line
+  interface p
+    module procedure p
+  end interface
+  character(128) :: line = 'abcdefghijklmnopqrstuvwxyz'
+contains
+  subroutine p()
+    character(128) :: word
+    word = line
+    call redirect_((/word/))
+  end subroutine
+  subroutine redirect_ (ch)
+    character(*) :: ch(:)
+    if (ch(1) /= line) call abort ()
+  end subroutine redirect_
+end module global
+
+! Test PR26550
+module my_module
+  implicit none
+  type point
+    real :: x
+  end type point
+  type(point), pointer, public :: stdin => NULL()
+contains
+  subroutine my_p(w)
+    character(128) :: w
+    call r(stdin,(/w/))
+  end subroutine my_p
+  subroutine r(ptr, io)
+    use global
+    type(point), pointer :: ptr
+    character(128) :: io(:)
+    if (associated (ptr)) call abort ()
+    if (io(1) .ne. line) call abort ()
+  end subroutine r
+end module my_module
+
+program main
+  use global
+  use my_module
+
+  integer :: i(6) = (/1,6,3,4,5,2/)
+  character (6) :: a = 'hello ', t
+  character(len=1) :: s(6) = (/'g','g','d','d','a','o'/)
+  equivalence (s, t)
+
+  call option_stopwatch_s (a) ! Call test of PR25619
+  call p ()                   ! Call test of PR26491
+  call my_p (line)            ! Call test of PR26550
+
+! Test Vivek Rao's bug, as reported in PR25619.
+  s = s(i)
+  call option_stopwatch_a ((/a,'hola! ', t/))
+
+contains
+
+! Test PR23634
+  subroutine option_stopwatch_s(a)
+    character (*), intent(in) :: a
+    character (len=len(a)) :: b
+
+    b = 'hola! '
+    call option_stopwatch_a((/a, b, 'goddag'/))
+  end subroutine option_stopwatch_s 
+  subroutine option_stopwatch_a (a)
+    character (*) :: a(:)
+    if (any (a .ne. (/'hello ','hola! ','goddag'/))) call abort ()
+  end subroutine option_stopwatch_a
+
+end program main
+! { dg-final { cleanup-modules "global my_module" } }
+
-------------- next part --------------
gcc/fortran/

2006-04-04  H.J. Lu  <hongjiu.lu@intel.com>

	PR fortran/25619
	Backport from mainline
	2006-04-04  H.J. Lu  <hongjiu.lu@intel.com>

	* trans-array.c (gfc_conv_expr_descriptor): Only dereference
	character pointer when copying temporary.

	PR fortran/23634
	Backport from mainline
	2006-04-04  H.J. Lu  <hongjiu.lu@intel.com>

	* trans-array.c (gfc_conv_expr_descriptor): Properly copy
	temporary character with non constant size.

gcc/testsuite/

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

	PR fortran/23634
	PR fortran/25619
	Backport from mainline
	2006-04-04  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/actual_array_constructor_1.f90: New testcase.

--- gcc/fortran/trans-array.c.array	2006-03-28 09:21:53.000000000 -0800
+++ gcc/fortran/trans-array.c	2006-04-03 21:37:18.000000000 -0700
@@ -3938,23 +3938,32 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       loop.temp_ss->next = gfc_ss_terminator;
       if (expr->ts.type == BT_CHARACTER)
 	{
-	  gcc_assert (expr->ts.cl && expr->ts.cl->length
-		      && expr->ts.cl->length->expr_type == EXPR_CONSTANT);
-	  loop.temp_ss->string_length = gfc_conv_mpz_to_tree
-			(expr->ts.cl->length->value.integer,
-			 expr->ts.cl->length->ts.kind);
-	  expr->ts.cl->backend_decl = loop.temp_ss->string_length;
-	}
-        loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-
-      /* ... which can hold our string, if present.  */
-      if (expr->ts.type == BT_CHARACTER)
-	{
-	  loop.temp_ss->string_length = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+	  if (expr->ts.cl
+	      && expr->ts.cl->length
+	      && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+	    {
+	      expr->ts.cl->backend_decl
+		= gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
+					expr->ts.cl->length->ts.kind);
+	      loop.temp_ss->data.temp.type
+		= gfc_typenode_for_spec (&expr->ts);
+	      loop.temp_ss->string_length
+		= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+	    }
+	  else
+	    {
+	      loop.temp_ss->data.temp.type
+		= gfc_typenode_for_spec (&expr->ts);
+	      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+	    }
 	  se->string_length = loop.temp_ss->string_length;
 	}
       else
-	loop.temp_ss->string_length = NULL;
+	{
+	  loop.temp_ss->data.temp.type
+	    = gfc_typenode_for_spec (&expr->ts);
+	  loop.temp_ss->string_length = NULL;
+	}
       loop.temp_ss->data.temp.dimen = loop.dimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
@@ -3987,7 +3996,8 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       if (expr->ts.type == BT_CHARACTER)
 	{
 	  gfc_conv_expr (&rse, expr);
-	  rse.expr = gfc_build_indirect_ref (rse.expr);
+	  if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
+	    rse.expr = gfc_build_indirect_ref (rse.expr);
 	}
       else
         gfc_conv_expr_val (&rse, expr);
--- gcc/testsuite/gfortran.dg/actual_array_constructor_1.f90.array	2006-04-04 21:34:40.000000000 -0700
+++ gcc/testsuite/gfortran.dg/actual_array_constructor_1.f90	2006-04-04 21:54:31.000000000 -0700
@@ -0,0 +1,80 @@
+! { dg-do run }
+! Test the fix by HJ Lu for PR23634 and friends. All involve the ICE
+! that arose from a character array constructor usedas an actual
+! argument.
+!
+! The various parts of this test are taken from the PRs.
+!
+! Test PR26491
+module global
+  public    p, line
+  interface p
+    module procedure p
+  end interface
+  character(128) :: line = 'abcdefghijklmnopqrstuvwxyz'
+contains
+  subroutine p()
+    character(128) :: word
+    word = line
+    call redirect_((/word/))
+  end subroutine
+  subroutine redirect_ (ch)
+    character(*) :: ch(:)
+    if (ch(1) /= line) call abort ()
+  end subroutine redirect_
+end module global
+
+! Test PR26550
+module my_module
+  implicit none
+  type point
+    real :: x
+  end type point
+  type(point), pointer, public :: stdin => NULL()
+contains
+  subroutine my_p(w)
+    character(128) :: w
+    call r(stdin,(/w/))
+  end subroutine my_p
+  subroutine r(ptr, io)
+    use global
+    type(point), pointer :: ptr
+    character(128) :: io(:)
+    if (associated (ptr)) call abort ()
+    if (io(1) .ne. line) call abort ()
+  end subroutine r
+end module my_module
+
+program main
+  use global
+  use my_module
+
+  integer :: i(6) = (/1,6,3,4,5,2/)
+  character (6) :: a = 'hello ', t
+  character(len=1) :: s(6) = (/'g','g','d','d','a','o'/)
+  equivalence (s, t)
+
+  call option_stopwatch_s (a) ! Call test of PR25619
+  call p ()                   ! Call test of PR26491
+  call my_p (line)            ! Call test of PR26550
+
+! Test Vivek Rao's bug, as reported in PR25619.
+  s = s(i)
+  call option_stopwatch_a ((/a,'hola! ', t/))
+
+contains
+
+! Test PR23634
+  subroutine option_stopwatch_s(a)
+    character (*), intent(in) :: a
+    character (len=len(a)) :: b
+
+    b = 'hola! '
+    call option_stopwatch_a((/a, b, 'goddag'/))
+  end subroutine option_stopwatch_s 
+  subroutine option_stopwatch_a (a)
+    character (*) :: a(:)
+    if (any (a .ne. (/'hello ','hola! ','goddag'/))) call abort ()
+  end subroutine option_stopwatch_a
+
+end program main


More information about the Gcc-patches mailing list