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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@88483 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7cc833b..f99c54f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+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.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9fe3513..a6397d3 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/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);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index fc5b41b..45f3acf 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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.  */
 

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 67bc234..f61fd4f 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/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 *);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4d1a7ce..3f54500 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/pr17612.f90 b/gcc/testsuite/gfortran.dg/pr17612.f90
new file mode 100644 (file)
index 0000000..1b68532
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr17612.f90
@@ -0,0 +1,37 @@
+! { 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
+  
+