re PR fortran/28174 (Corruption of multiple character arrays when passing array sections)

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

	PR fortran/28174
	* trans-array.c (gfc_conv_expr_descriptor): When building temp,
	ensure that the substring reference uses a new charlen.
	* trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to
	the argument list, lift the treatment of missing string lengths
	from the above and implement the use of the intent.
	(gfc_conv_function_call): Add the extra argument to the call to
	the above.

	PR fortran/28167
	* trans-array.c (get_array_ctor_var_strlen): Treat a constant
	substring reference.
	* array.c (gfc_resolve_character_array_constructor): Remove 
	static attribute and add the gfc_ prefix, make use of element
	charlens for the expression and pick up constant string lengths
	for expressions that are not themselves constant.
	* gfortran.h : resolve_character_array_constructor prototype
	added.
	* resolve.c (gfc_resolve_expr): Call resolve_character_array_
	constructor again after expanding the constructor, to ensure
	that the character length is passed to the expression.

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

	PR fortran/28174
	* gfortran.dg/actual_array_substr_2.f90: New test.

	PR fortran/28167
	* gfortran.dg/actual_array_constructor_2.f90: New test.

From-SVN: r115182

8 files changed, 219 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6deaea5..efa3140 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2006-07-04  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28174
+	* trans-array.c (gfc_conv_expr_descriptor): When building temp,
+	ensure that the substring reference uses a new charlen.
+	* trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to
+	the argument list, lift the treatment of missing string lengths
+	from the above and implement the use of the intent.
+	(gfc_conv_function_call): Add the extra argument to the call to
+	the above.
+
+	PR fortran/28167
+	* trans-array.c (get_array_ctor_var_strlen): Treat a constant
+	substring reference.
+	* array.c (gfc_resolve_character_array_constructor): Remove 
+	static attribute and add the gfc_ prefix, make use of element
+	charlens for the expression and pick up constant string lengths
+	for expressions that are not themselves constant.
+	* gfortran.h : resolve_character_array_constructor prototype
+	added.
+	* resolve.c (gfc_resolve_expr): Call resolve_character_array_
+	constructor again after expanding the constructor, to ensure
+	that the character length is passed to the expression.
+
 2006-07-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 	    Daniel Franke  <franke.daniel@gmail.com>
 
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 2cb3499..fa38ab9 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1518,8 +1518,8 @@ resolve_array_list (gfc_constructor * p)
    not specified character length, update character length to the maximum of
    its element constructors' length.  */
 
-static void
-resolve_character_array_constructor (gfc_expr * expr)
+void
+gfc_resolve_character_array_constructor (gfc_expr * expr)
 {
   gfc_constructor * p;
   int max_length;
@@ -1531,20 +1531,53 @@ resolve_character_array_constructor (gfc_expr * expr)
 
   if (expr->ts.cl == NULL)
     {
+      for (p = expr->value.constructor; p; p = p->next)
+	if (p->expr->ts.cl != NULL)
+	  {
+	    /* Ensure that if there is a char_len around that it is
+	       used; otherwise the middle-end confuses them!  */
+	    expr->ts.cl = p->expr->ts.cl;
+	    goto got_charlen;
+	  }
+
       expr->ts.cl = gfc_get_charlen ();
       expr->ts.cl->next = gfc_current_ns->cl_list;
       gfc_current_ns->cl_list = expr->ts.cl;
     }
 
+got_charlen:
+
   if (expr->ts.cl->length == NULL)
     {
       /* Find the maximum length of the elements. Do nothing for variable array
-	 constructor.  */
+	 constructor, unless the character length is constant or there is a
+	constant substring reference.  */
+
       for (p = expr->value.constructor; p; p = p->next)
-	if (p->expr->expr_type == EXPR_CONSTANT)
-	  max_length = MAX (p->expr->value.character.length, max_length);
-	else
-	  return;
+	{
+	  gfc_ref *ref;
+	  for (ref = p->expr->ref; ref; ref = ref->next)
+	    if (ref->type == REF_SUBSTRING
+		  && ref->u.ss.start->expr_type == EXPR_CONSTANT
+		  && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+	      break;
+
+	  if (p->expr->expr_type == EXPR_CONSTANT)
+	    max_length = MAX (p->expr->value.character.length, max_length);
+
+	  else if (ref)
+	    max_length = MAX ((int)(mpz_get_ui (ref->u.ss.end->value.integer)
+			      - mpz_get_ui (ref->u.ss.start->value.integer))
+			      + 1, max_length);
+
+	  else if (p->expr->ts.cl && p->expr->ts.cl->length
+		     && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+	    max_length = MAX ((int)mpz_get_si (p->expr->ts.cl->length->value.integer),
+			      max_length);
+
+	  else
+	    return;
+	}
 
       if (max_length != -1)
 	{
@@ -1552,7 +1585,8 @@ resolve_character_array_constructor (gfc_expr * expr)
 	  expr->ts.cl->length = gfc_int_expr (max_length);
 	  /* Update the element constructors.  */
 	  for (p = expr->value.constructor; p; p = p->next)
-	    gfc_set_constant_character_len (max_length, p->expr);
+	    if (p->expr->expr_type == EXPR_CONSTANT)
+	      gfc_set_constant_character_len (max_length, p->expr);
 	}
     }
 }
@@ -1568,7 +1602,7 @@ gfc_resolve_array_constructor (gfc_expr * expr)
   if (t == SUCCESS)
     t = gfc_check_constructor_type (expr);
   if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
-    resolve_character_array_constructor (expr);
+    gfc_resolve_character_array_constructor (expr);
 
   return t;
 }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 834d23f..21b0d09 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2028,6 +2028,7 @@ void gfc_simplify_iterator_var (gfc_expr *);
 try gfc_expand_constructor (gfc_expr *);
 int gfc_constant_ac (gfc_expr *);
 int gfc_expanded_ac (gfc_expr *);
+void gfc_resolve_character_array_constructor (gfc_expr *);
 try gfc_resolve_array_constructor (gfc_expr *);
 try gfc_check_constructor_type (gfc_expr *);
 try gfc_check_iter_variable (gfc_expr *);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0e9916a..c3aaf87 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2942,6 +2942,11 @@ gfc_resolve_expr (gfc_expr * e)
 	  gfc_expand_constructor (e);
 	}
 
+      /* This provides the opportunity for the length of constructors with character
+	valued function elements to propogate the string length to the expression.  */
+      if (e->ts.type == BT_CHARACTER)
+        gfc_resolve_character_array_constructor (e);
+
       break;
 
     case EXPR_STRUCTURE:
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6a2c2de..01c78d4 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1341,6 +1341,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
 {
   gfc_ref *ref;
   gfc_typespec *ts;
+  mpz_t char_len;
 
   /* Don't bother if we already know the length is a constant.  */
   if (*len && INTEGER_CST_P (*len))
@@ -1360,6 +1361,19 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
 	  ts = &ref->u.c.component->ts;
 	  break;
 
+	case REF_SUBSTRING:
+	  if (ref->u.ss.start->expr_type != EXPR_CONSTANT
+		|| ref->u.ss.start->expr_type != EXPR_CONSTANT)
+	    break;
+	  mpz_init_set_ui (char_len, 1);
+	  mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
+	  mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
+	  *len = gfc_conv_mpz_to_tree (char_len,
+				       gfc_default_character_kind);
+	  *len = convert (gfc_charlen_type_node, *len);
+	  mpz_clear (char_len);
+	  return;
+
 	default:
 	  /* TODO: Substrings are tricky because we can't evaluate the
 	     expression more than once.  For now we just give up, and hope
@@ -4192,7 +4206,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 		if (char_ref->type == REF_SUBSTRING)
 		  {
 		    mpz_t char_len;
-		    expr->ts.cl = char_ref->u.ss.length;
+		    expr->ts.cl = gfc_get_charlen ();
+		    expr->ts.cl->next = char_ref->u.ss.length->next;
+		    char_ref->u.ss.length->next = expr->ts.cl;
+
 		    mpz_init_set_ui (char_len, 1);
 		    mpz_add (char_len, char_len,
 			     char_ref->u.ss.end->value.integer);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1d429c9..30cf80a 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1591,7 +1591,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    handling aliased arrays.  */
 
 static void
-gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
+		      int g77, sym_intent intent)
 {
   gfc_se lse;
   gfc_se rse;
@@ -1635,7 +1636,37 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
   loop.temp_ss->data.temp.type = base_type;
 
   if (expr->ts.type == BT_CHARACTER)
-    loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+    {
+      gfc_ref *char_ref = expr->ref;
+
+      for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
+	if (char_ref->type == REF_SUBSTRING)
+	  {
+	    gfc_se tmp_se;
+
+	    expr->ts.cl = gfc_get_charlen ();
+	    expr->ts.cl->next = char_ref->u.ss.length->next;
+	    char_ref->u.ss.length->next = expr->ts.cl;
+
+	    gfc_init_se (&tmp_se, NULL);
+	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
+				gfc_array_index_type);
+	    tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			       tmp_se.expr, gfc_index_one_node);
+	    tmp = gfc_evaluate_now (tmp, &parmse->pre);
+	    gfc_init_se (&tmp_se, NULL);
+	    gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
+				gfc_array_index_type);
+	    tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			       tmp, tmp_se.expr);
+	    expr->ts.cl->backend_decl = tmp;
+
+	    break;
+	  }
+      loop.temp_ss->data.temp.type
+		= gfc_typenode_for_spec (&expr->ts);
+      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+    }
 
   loop.temp_ss->data.temp.dimen = loop.dimen;
   loop.temp_ss->next = gfc_ss_terminator;
@@ -1668,12 +1699,13 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
   gfc_conv_tmp_array_ref (&lse);
   gfc_advance_se_ss_chain (&lse);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
-  gfc_add_expr_to_block (&body, tmp);
-
-  gcc_assert (rse.ss == gfc_ss_terminator);
-
-  gfc_trans_scalarizing_loops (&loop, &body);
+  if (intent != INTENT_OUT)
+    {
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+      gfc_add_expr_to_block (&body, tmp);
+      gcc_assert (rse.ss == gfc_ss_terminator);
+      gfc_trans_scalarizing_loops (&loop, &body);
+    }
 
   /* Add the post block after the second loop, so that any
      freeing of allocated memory is done at the right time.  */
@@ -1761,10 +1793,13 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
   gfc_trans_scalarizing_loops (&loop2, &body);
 
   /* Wrap the whole thing up by adding the second loop to the post-block
-     and following it by the post-block of the fist loop.  In this way,
+     and following it by the post-block of the first loop.  In this way,
      if the temporary needs freeing, it is done after use!  */
-  gfc_add_block_to_block (&parmse->post, &loop2.pre);
-  gfc_add_block_to_block (&parmse->post, &loop2.post);
+  if (intent != INTENT_IN)
+    {
+      gfc_add_block_to_block (&parmse->post, &loop2.pre);
+      gfc_add_block_to_block (&parmse->post, &loop2.post);
+    }
 
   gfc_add_block_to_block (&parmse->post, &loop.post);
 
@@ -1799,7 +1834,8 @@ is_aliased_array (gfc_expr * e)
       if (ref->type == REF_ARRAY)
 	seen_array = true;
 
-      if (ref->next == NULL && ref->type == REF_COMPONENT)
+      if (ref->next == NULL
+	    && ref->type != REF_ARRAY)
 	return seen_array;
     }
   return false;
@@ -1937,13 +1973,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		  && !(fsym->attr.pointer || fsym->attr.allocatable)
 		  && fsym->as->type != AS_ASSUMED_SHAPE;
 	      f = f || !sym->attr.always_explicit;
+
 	      if (e->expr_type == EXPR_VARIABLE
 		    && is_aliased_array (e))
 		/* The actual argument is a component reference to an
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
 		   written back after the procedure call.  */
-		gfc_conv_aliased_arg (&parmse, e, f);
+		gfc_conv_aliased_arg (&parmse, e, f, fsym->attr.intent);
 	      else
 	        gfc_conv_array_parameter (&parmse, e, argss, f);
 
diff --git a/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 b/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90
new file mode 100644
index 0000000..0a86b70
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! Tests the fix for pr28167, in which character array constructors

+! with an implied do loop would cause an ICE, when used as actual

+! arguments.
+!
+! Based on the testscase by Harald Anlauf  <anlauf@gmx.de>
+!
+  character(4), dimension(4) :: c1, c2

+  integer m

+  m = 4

+! Test the original problem

+  call foo ((/( 'abcd',i=1,m )/), c2)

+  if (any(c2(:) .ne. (/'abcd','abcd', &

+                            'abcd','abcd'/))) call abort ()

+

+! Now get a bit smarter

+  call foo ((/"abcd", "efgh", "ijkl", "mnop"/), c1) ! worked previously

+  call foo ((/(c1(i), i = m,1,-1)/), c2)            ! was broken

+  if (any(c2(4:1:-1) .ne. c1)) call abort ()

+

+! gfc_todo: Not Implemented: complex character array constructors

+  call foo ((/(c1(i)(i/2+1:i/2+2), i = 1,4)/), c2)  ! Ha! take that..!
+  if (any (c2 .ne. (/"ab  ","fg  ","jk  ","op  "/))) call abort ()
+

+! Check functions in the constructor

+  call foo ((/(achar(64+i)//achar(68+i)//achar(72+i)// &

+               achar(76+i),i=1,4 )/), c1)           ! was broken

+  if (any (c1 .ne. (/"AEIM","BFJN","CGKO","DHLP"/))) call abort ()

+contains

+  subroutine foo (chr1, chr2)

+    character(*), dimension(:) :: chr1, chr2

+    chr2 = chr1

+  end subroutine foo

+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 b/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90
new file mode 100644
index 0000000..365557d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90
@@ -0,0 +1,44 @@
+! { dg-do run }
+! Tests the fix for pr28174, in which the fix for pr28118 was
+! corrupting the character lengths of arrays that shared a
+! character length structure.  In addition, in developing the
+! fix, it was noted that intent(out/inout) arguments were not
+! getting written back to the calling scope.
+!
+! Based on the testscase by Harald Anlauf  <anlauf@gmx.de>
+!
+program pr28174

+  implicit none

+  character(len=12) :: teststring(2) = (/ "abc def ghij", &
+                                          "klm nop qrst" /)

+  character(len=12) :: a(2), b(2), c(2), d(2)
+  integer :: m = 7, n

+  a = teststring

+  b = a

+  c = a

+  d = a
+  n = m - 4
+
+! Make sure that variable substring references work.

+  call foo (a(:)(m:m+5), c(:)(n:m+2), d(:)(5:9))

+  if (any (a .ne. teststring)) call abort ()
+  if (any (b .ne. teststring)) call abort ()
+  if (any (c .ne. (/"ab456789#hij", &
+                    "kl7654321rst"/))) call abort ()
+  if (any (d .ne. (/"abc 23456hij", &
+                    "klm 98765rst"/))) call abort ()

+contains

+  subroutine foo (w, x, y)

+    character(len=*), intent(in) :: w(:)

+    character(len=*), intent(inOUT) :: x(:)

+    character(len=*), intent(OUT) :: y(:)
+    character(len=12) :: foostring(2) = (/"0123456789#$" , &
+                                          "$#9876543210"/)
+! This next is not required by the standard but tests the
+! functioning of the gfortran implementation.

+!   if (all (x(:)(3:7) .eq. y)) call abort ()
+    x = foostring (:)(5 : 4 + len (x))
+    y = foostring (:)(3 : 2 + len (y))
+  end subroutine foo

+end program pr28174

+