[Patch/gfortran] PR18109

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

This patch cures pr18109 that arise because calls such as:   call foo 
((/"abcd",efgh"/))  cause seg faults.

Bubblestrapped and regtested on i686/RH9:  OK to commit?

The next stop will be character actual arguments in derived 
type(structure) constructors (PR19017) and assignments to derived type 
components(PR19928) because they are very closely related to the 
previous patches.  Watch this space!

Regards

Paul T

2005-05-29 Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/18109
   * fortran/trans-array.c (gfc_conv_expr_descriptor): Obtain the
   string length from the expression typespec character length value
   and set temp_ss->stringlength and backend_decl. Obtain the
   tree expression from gfc_conv_expr rather than gfc_conv_expr_val.
   Dereference the expression to obtain the character.

2005-05-29 Paul Thomas  <pault@gcc.gnu.org>

   * gfortran.dg/char_initialiser_actual.f90:
   Test character initialisers as actual arguments.



Index: gcc/gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.46
diff -c -3 -p -r1.46 trans-array.c
*** gcc/gcc/fortran/trans-array.c	29 May 2005 16:02:09 -0000	1.46
--- gcc/gcc/fortran/trans-array.c	29 May 2005 16:23:21 -0000
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3616,3627 ****
        loop.temp_ss = gfc_get_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.  */
        if (expr->ts.type == BT_CHARACTER)
! 	se->string_length = loop.temp_ss->string_length
! 	  = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
        else
  	loop.temp_ss->string_length = NULL;
        loop.temp_ss->data.temp.dimen = loop.dimen;
--- 3616,3638 ----
        loop.temp_ss = gfc_get_ss ();
        loop.temp_ss->type = GFC_SS_TEMP;
        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);
! 	  se->string_length = loop.temp_ss->string_length;
! 	}      loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
        else
  	loop.temp_ss->string_length = NULL;
        loop.temp_ss->data.temp.dimen = loop.dimen;
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3653,3659 ****
        rse.ss = ss;
  
        gfc_conv_scalarized_array_ref (&lse, NULL);
!       gfc_conv_expr_val (&rse, expr);
  
        gfc_add_block_to_block (&block, &rse.pre);
        gfc_add_block_to_block (&block, &lse.pre);
--- 3664,3676 ----
        rse.ss = ss;
  
        gfc_conv_scalarized_array_ref (&lse, NULL);
!       if (expr->ts.type == BT_CHARACTER)
! 	{
! 	  gfc_conv_expr (&rse, expr);
! 	  rse.expr = gfc_build_indirect_ref (rse.expr);
! 	}
!       else
!         gfc_conv_expr_val (&rse, expr);
  
        gfc_add_block_to_block (&block, &rse.pre);
        gfc_add_block_to_block (&block, &lse.pre);

! { dg do-run }
! Tests passing of character array initialiser as actual argument.
! Fixes PR18109.
! Contributed by Paul Thomas pault@gcc.gnu.org  
program char_initialiser
  character*5, dimension(3) :: x
  character*5, dimension(:), pointer :: y
  x=(/"is Ja","ne Fo","nda"/)
  call sfoo ("is Ja", x(1))
  call afoo ((/"is Ja","ne Fo","nda"/), x)
  y => pfoo ((/"is Ja","ne Fo","nda"/))
  call afoo (y, x)
contains
  subroutine sfoo(ch1, ch2)
     character*(*)               :: ch1, ch2
     if (ch1 /= ch2) call abort ()
  end subroutine sfoo
  subroutine afoo(ch1, ch2)
     character*(*), dimension(:) :: ch1, ch2
     if (any(ch1 /= ch2)) call abort ()
  end subroutine afoo
  function pfoo(ch2)
     character*5, dimension(:), target  :: ch2
     character*5, dimension(:), pointer :: pfoo
     pfoo => ch2
  end function pfoo
end program