Re: [gfortran] Fix PR 15234 : asseumed length character arrays

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Tobias Schlüter wrote:
> With patient coaching by Paul (thanks!), I managed to fix PR 15234.
> There were two issues:

There were more issues, fixed in this updated patch. I also appended a
testcase. All the code samples from the duplicates of 15324 compile now
(the testcase from pr 16550 was not self-contained, but this is easily
fixed).

Built & tested.

- Tobi

2004-07-15  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/15234
	* trans-array.c gfc_trans_g77_array,
	gfc_trans_dummy_array_bias): Don't call gfc_trans_string_init
	for assumed length characters.
	(gfc_conv_expr_descriptor): Set se->string_length if dealing
	with a character expression.
	(gfc_cvonv_array_parameter): Pass string length when passing
	character array according to g77 conventions.

Index: trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.10
diff -u -p -r1.10 trans-array.c
--- trans-array.c       12 Jul 2004 01:23:36 -0000      1.10
+++ trans-array.c       15 Jul 2004 14:13:42 -0000
@@ -2947,7 +2947,7 @@ gfc_trans_g77_array (gfc_symbol * sym, t
   gfc_start_block (&block);

   if (sym->ts.type == BT_CHARACTER
-      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+      && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
     gfc_trans_init_string_length (sym->ts.cl, &block);

   /* Evaluate the bounds of the array.  */
@@ -3026,7 +3026,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
   gfc_start_block (&block);

   if (sym->ts.type == BT_CHARACTER
-      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+      && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
     gfc_trans_init_string_length (sym->ts.cl, &block);

   checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
@@ -3359,6 +3359,8 @@ gfc_conv_expr_descriptor (gfc_se * se, g
            {
              se->expr = desc;
            }
+         if (expr->ts.type == BT_CHARACTER)
+           se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
          return;
        }
     }
@@ -3390,7 +3392,12 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       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);
-      loop.temp_ss->data.temp.string_length = NULL;
+      /* Which can hold our string, if present.  */
+      if (expr->ts.type == BT_CHARACTER)
+       se->string_length = loop.temp_ss->data.temp.string_length
+         = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+      else
+       loop.temp_ss->data.temp.string_length = NULL;
       loop.temp_ss->data.temp.dimen = loop.dimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
@@ -3451,6 +3458,10 @@ gfc_conv_expr_descriptor (gfc_se * se, g
       tree to;
       tree base;

+      /* 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;
+
       /* Otherwise make a new descriptor and point it at the section we
          want.  The loop variable limits will be the limits of the section.
        */
@@ -3625,6 +3636,8 @@ gfc_conv_array_parameter (gfc_se * se, g
     {
       sym = expr->symtree->n.sym;
       tmp = gfc_get_symbol_decl (sym);
+      if (sym->ts.type == BT_CHARACTER)
+       se->string_length = sym->ts.cl->backend_decl;
       if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
           && !sym->attr.allocatable)
         {

! { dg-do run }
! PR 15234
! tests for passing arrays of assumed length characters
program strarray_6
character(5), dimension(:), allocatable :: c
n = 3
allocate(c(-1:n-1))
c = "BLUBB"
call foo(c)
call bar(c,n)
deallocate(c)
contains
subroutine foo(x)
  character (len = *), dimension(:) :: x
  if (any (x .ne. "BLUBB")) CALL abort()
end subroutine foo
end

subroutine bar(x,n)
  character (len = *), dimension(n) :: x
  if (any (x .ne. "BLUBB")) CALL abort()
end subroutine bar