trans-array.c (gfc_conv_expr_descriptor): Check for substriungs.

2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
	Paul Brook  <paul@codesourcery.com>

	* trans-array.c (gfc_conv_expr_descriptor): Check for substriungs.
	Use gfc_get_expr_charlen.
	* trans-expr.c (gfc_get_expr_charlen): New function.
	* trans.h (gfc_get_expr_charlen): Add prototype.
testsuite/
	* gfortran.dg/pr17612.f90: New test.

Co-Authored-By: Paul Brook <paul@codesourcery.com>

From-SVN: r88483

gcc/fortran/ChangeLog

+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Paul Brook  <paul@codesourcery.com>
+
+	* trans-array.c (gfc_conv_expr_descriptor): Check for substriungs.
+	Use gfc_get_expr_charlen.
+	* trans-expr.c (gfc_get_expr_charlen): New function.
+	* trans.h (gfc_get_expr_charlen): Add prototype.
+
 2004-10-04  Kazu Hirata  <kazu@cs.umass.edu>
 
 	* trans-intrinsic.c: Fix a comment typo.

gcc/fortran/trans-array.c

@@ -3486,6 +3486,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
   tree offset;
   int full;
   gfc_ss *vss;
+  gfc_ref *ref;
 
   gcc_assert (ss != gfc_ss_terminator);
 
@@ -3528,23 +3529,42 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	full = 0;
       else
 	{
-	  gcc_assert (info->ref->u.ar.type == AR_SECTION);
+	  ref = info->ref;
+	  gcc_assert (ref->u.ar.type == AR_SECTION);
 
 	  full = 1;
-	  for (n = 0; n < info->ref->u.ar.dimen; n++)
+	  for (n = 0; n < ref->u.ar.dimen; n++)
 	    {
 	      /* Detect passing the full array as a section.  This could do
 	         even more checking, but it doesn't seem worth it.  */
-	      if (info->ref->u.ar.start[n]
-		  || info->ref->u.ar.end[n]
-		  || (info->ref->u.ar.stride[n]
-		      && !gfc_expr_is_one (info->ref->u.ar.stride[n], 0)))
+	      if (ref->u.ar.start[n]
+		  || ref->u.ar.end[n]
+		  || (ref->u.ar.stride[n]
+		      && !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
 		{
 		  full = 0;
 		  break;
 		}
 	    }
 	}
+
+      /* Check for substring references.  */
+      ref = expr->ref;
+      if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
+	{
+	  while (ref->next)
+	    ref = ref->next;
+	  if (ref->type == REF_SUBSTRING)
+	    {
+	      /* In general character substrings need a copy.  Character
+		 array strides are expressed as multiples of the element
+		 size (consistent with other array types), not in
+		 characters.  */
+	      full = 0;
+	      need_tmp = 1;
+	    }
+	}
+
       if (full)
 	{
 	  if (se->direct_byref)
@@ -3562,8 +3582,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	    {
 	      se->expr = desc;
 	    }
+
 	  if (expr->ts.type == BT_CHARACTER)
-	    se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+	    se->string_length = gfc_get_expr_charlen (expr);
+
 	  return;
 	}
       break;
@@ -3634,7 +3656,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       loop.temp_ss->type = GFC_SS_TEMP;
       loop.temp_ss->next = gfc_ss_terminator;
       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-      /* Which can hold our string, if present.  */
+      /* ... which can hold our string, if present.  */
       if (expr->ts.type == BT_CHARACTER)
 	se->string_length = loop.temp_ss->string_length
 	  = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
@@ -3716,7 +3738,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 
       /* Set the string_length for a character array.  */
       if (expr->ts.type == BT_CHARACTER)
-	se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+	se->string_length =  gfc_get_expr_charlen (expr);
 
       desc = info->descriptor;
       gcc_assert (secss && secss != gfc_ss_terminator);

gcc/fortran/trans-expr.c

@@ -140,6 +140,53 @@ gfc_conv_expr_present (gfc_symbol * sym)
 }
 
 
+/* Get the character length of an expression, looking through gfc_refs
+   if necessary.  */
+
+tree
+gfc_get_expr_charlen (gfc_expr *e)
+{
+  gfc_ref *r;
+  tree length;
+
+  gcc_assert (e->expr_type == EXPR_VARIABLE 
+	      && e->ts.type == BT_CHARACTER);
+  
+  length = NULL; /* To silence compiler warning.  */
+
+  /* First candidate: if the variable is of type CHARACTER, the
+     expression's length could be the length of the character
+     variable. */
+  if (e->symtree->n.sym->ts.type == BT_CHARACTER)
+    length = e->symtree->n.sym->ts.cl->backend_decl;
+
+  /* Look through the reference chain for component references.  */
+  for (r = e->ref; r; r = r->next)
+    {
+      switch (r->type)
+	{
+	case REF_COMPONENT:
+	  if (r->u.c.component->ts.type == BT_CHARACTER)
+	    length = r->u.c.component->ts.cl->backend_decl;
+	  break;
+
+	case REF_ARRAY:
+	  /* Do nothing.  */
+	  break;
+
+	default:
+	  /* We should never got substring references here.  These will be
+	     broken down by the scalarizer.  */
+	  gcc_unreachable ();
+	}
+    }
+
+  gcc_assert (length != NULL);
+  return length;
+}
+
+  
+
 /* Generate code to initialize a string length variable. Returns the
    value.  */
 

gcc/fortran/trans.h

@@ -316,6 +316,8 @@ tree gfc_conv_expr_present (gfc_symbol *);
 
 /* Generate code to allocate a string temporary.  */
 tree gfc_conv_string_tmp (gfc_se *, tree, tree);
+/* Get the string length variable belonging to an expression.  */
+tree gfc_get_expr_charlen (gfc_expr *);
 /* Initialize a string length variable.  */
 void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
 

gcc/testsuite/ChangeLog

+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	* gfortran.dg/pr17612.f90: New test.
+
 2004-10-03  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
 	* g++.dg/template/local1.C: Adjust quoting marks in

gcc/testsuite/gfortran.dg/pr17612.f90

+! { dg-do run }
+! PR 17612
+! We used to not determine the length of character-valued expressions
+! correctly, leading to a segfault.
+program prog
+  character(len=2), target :: c(4)
+  type pseudo_upf 
+     character(len=2), pointer :: els(:)
+  end type pseudo_upf
+  type (pseudo_upf) :: p
+  type t
+    character(5) :: s(2)
+  end type
+  type (t) v
+  ! A full arrays.
+  c = (/"ab","cd","ef","gh"/)
+  call n(p)
+  if (any (c /= p%els)) call abort
+  ! An array section that needs a new array descriptor.
+  v%s(1) = "hello"
+  v%s(2) = "world"
+  call test (v%s)
+contains 
+
+  subroutine n (upf) 
+    type (pseudo_upf), intent(inout) :: upf 
+    upf%els => c
+    return 
+  end subroutine n
+
+  subroutine test(s)
+    character(len=*) :: s(:)
+    if ((len (s) .ne. 5) .or. (any (s .ne. (/"hello", "world"/)))) call abort
+  end subroutine
+end program
+  
+