This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch/gfortran] PR16939, 17192,17193,17202,18689,18890 &21297


This patch deals with all the issues concerning character pointers, assignments of characters and passing array pointers as procedure arguments. I believe that the meta-bug 17193 is resolved.

Fortran changelog entry.

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

PR fortran/16939
PR fortran/17192
PR fortran/17193
PR fortran/17202
PR fortran/18689
PR fortran/18890
PR fortran/21297
* fortran/trans-array.c (gfc_conv_resolve_dependencies): Add string
length to temp_ss for character pointer array assignments.
* fortran/trans-expr.c (gfc_conv_variable): Correct errors in
dereferencing of characters and character pointers.
* fortran/trans-expr.c (gfc_conv_function_call): Provide string
length as return argument for various kinds of handling of return.
Return a char[]* temporary for character pointer functions and
dereference the temporary upon return.

Bootstrapped and regtested on i686/RH9. OK for 4.1?

I have realised that one more test case is needed to check that dependencies are indeed resolved. This will follow with the testsuite changelog entry. In fact, might it be an idea to extend these tests to cover the intrinsic and derived types? It might be nice, for a change, to have testsuite entries for the things that work, rather than those that are broken!

Paul Thomas

Enclosures: patch, character_pointer_assign.f90, character_pointer_dummy.f90 and character_pointer_func.f90.

Index: gcc/gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.43
diff -c -3 -p -r1.43 trans-array.c
*** gcc/gcc/fortran/trans-array.c 29 Apr 2005 15:31:38 -0000 1.43
--- gcc/gcc/fortran/trans-array.c 25 May 2005 06:12:25 -0000
*************** gfc_conv_resolve_dependencies (gfc_loopi
*** 2342,2348 ****
       loop->temp_ss->type = GFC_SS_TEMP;
       loop->temp_ss->data.temp.type =
  gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
!       loop->temp_ss->string_length = NULL_TREE;
       loop->temp_ss->data.temp.dimen = loop->dimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
--- 2342,2348 ----
       loop->temp_ss->type = GFC_SS_TEMP;
       loop->temp_ss->data.temp.type =
  gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
!       loop->temp_ss->string_length = dest->string_length;
       loop->temp_ss->data.temp.dimen = loop->dimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
Index: gcc/gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.44
diff -c -3 -p -r1.44 trans-expr.c
*** gcc/gcc/fortran/trans-expr.c 11 May 2005 14:52:27 -0000 1.44
--- gcc/gcc/fortran/trans-expr.c 25 May 2005 06:12:28 -0000
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 354,383 ****
        se->expr = gfc_build_addr_expr (NULL, se->expr);
      }
    return;
!  }
!
!       /* Dereference scalar dummy variables.  */
!       if (sym->attr.dummy
!    && sym->ts.type != BT_CHARACTER
!    && !sym->attr.dimension)
!  se->expr = gfc_build_indirect_ref (se->expr);
!
!       /* Dereference scalar hidden result.  */
!       if (gfc_option.flag_f2c
!    && (sym->attr.function || sym->attr.result)
!    && sym->ts.type == BT_COMPLEX
!    && !sym->attr.dimension)
!  se->expr = gfc_build_indirect_ref (se->expr);
!
!       /* Dereference pointer variables.  */
!       if ((sym->attr.pointer || sym->attr.allocatable)
!    && (sym->attr.dummy
!        || sym->attr.result
!        || sym->attr.function
!        || !sym->attr.dimension)
!           && sym->ts.type != BT_CHARACTER)
!  se->expr = gfc_build_indirect_ref (se->expr);

       ref = expr->ref;
     }

--- 354,396 ----
        se->expr = gfc_build_addr_expr (NULL, se->expr);
      }
    return;
!  }

+
+       /* Dereference the expression, where needed. Since characters
+   are entirely different from other types, they are treated
+   separately.  */
+       if (sym->ts.type == BT_CHARACTER)
+  {
+           /* Dereference character pointer dummy arguments
+       or results.  */
+    if ((sym->attr.pointer || sym->attr.allocatable)
+        && ((sym->attr.dummy)
+     || (sym->attr.function
+     || sym->attr.result)))
+      se->expr = gfc_build_indirect_ref (se->expr);
+  }
+       else
+  {
+           /* Dereference non-charcter scalar dummy arguments.  */
+    if ((sym->attr.dummy) && (!sym->attr.dimension))
+      se->expr = gfc_build_indirect_ref (se->expr);
+
+           /* Dereference scalar hidden result.  */
+    if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX)
+        && (sym->attr.function || sym->attr.result)
+        && (!sym->attr.dimension))
+      se->expr = gfc_build_indirect_ref (se->expr);
+
+           /* Dereference non-character pointer variables.
+       These must be dummys or results or scalars.  */
+    if ((sym->attr.pointer || sym->attr.allocatable)
+        && ((sym->attr.dummy)
+     || (sym->attr.function || sym->attr.result)
+     || (!sym->attr.dimension)))
+      se->expr = gfc_build_indirect_ref (se->expr);
+  }
+
       ref = expr->ref;
     }

*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1083,1088 ****
--- 1096,1110 ----
   var = NULL_TREE;
   len = NULL_TREE;

+   /* Obtain the string length now because it is needed often below.  */
+   if (sym->ts.type == BT_CHARACTER)
+     {
+       gcc_assert (sym->ts.cl && sym->ts.cl->length
+     && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+       len = gfc_conv_mpz_to_tree
+        (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+     }
+
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1097,1102 ****
--- 1119,1127 ----
               /* Access the previously obtained result.  */
               gfc_conv_tmp_array_ref (se);
               gfc_advance_se_ss_chain (se);
+
+        /* Bundle in the string length.  */
+        se->string_length=len;
               return;
             }
  }
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1108,1121 ****
   byref = gfc_return_by_reference (sym);
   if (byref)
     {
!       if (se->direct_byref)
!  arglist = gfc_chainon_list (arglist, se->expr);
       else if (sym->result->attr.dimension)
  {
!    gcc_assert (se->loop && se->ss);
    /* Set the type of the array.  */
    tmp = gfc_typenode_for_spec (&sym->ts);
!    info->dimen = se->loop->dimen;
    /* Allocate a temporary to store the result.  */
    gfc_trans_allocate_temp_array (se->loop, info, tmp);

--- 1133,1158 ----
   byref = gfc_return_by_reference (sym);
   if (byref)
     {
!       if (se->direct_byref)
!  {
!    arglist = gfc_chainon_list (arglist, se->expr);
!
!    /* Add string length to argument list.  */
!    if (sym->ts.type == BT_CHARACTER)
!      {
!        sym->ts.cl->backend_decl = len;
!        arglist = gfc_chainon_list (arglist,
!           convert (gfc_charlen_type_node, len));
!      }
!  }
       else if (sym->result->attr.dimension)
  {
!    gcc_assert (se->loop && se->ss);
!
    /* Set the type of the array.  */
    tmp = gfc_typenode_for_spec (&sym->ts);
!    info->dimen = se->loop->dimen;
!
    /* Allocate a temporary to store the result.  */
    gfc_trans_allocate_temp_array (se->loop, info, tmp);

*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1124,1145 ****
      gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
    gfc_add_modify_expr (&se->pre, tmp,
           convert (TREE_TYPE (tmp), integer_zero_node));
    /* Pass the temporary as the first argument.  */
    tmp = info->descriptor;
    tmp = gfc_build_addr_expr (NULL, tmp);
    arglist = gfc_chainon_list (arglist, tmp);
  }
       else if (sym->ts.type == BT_CHARACTER)
  {
!    gcc_assert (sym->ts.cl && sym->ts.cl->length
!     && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
!    len = gfc_conv_mpz_to_tree
!      (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
    sym->ts.cl->backend_decl = len;
    type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
    type = build_pointer_type (type);

!    var = gfc_conv_string_tmp (se, type, len);
    arglist = gfc_chainon_list (arglist, var);
    arglist = gfc_chainon_list (arglist,
           convert (gfc_charlen_type_node, len));
--- 1161,1206 ----
      gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
    gfc_add_modify_expr (&se->pre, tmp,
           convert (TREE_TYPE (tmp), integer_zero_node));
+
    /* Pass the temporary as the first argument.  */
    tmp = info->descriptor;
    tmp = gfc_build_addr_expr (NULL, tmp);
    arglist = gfc_chainon_list (arglist, tmp);
+
+    /* Add string length to argument list.  */
+    if (sym->ts.type == BT_CHARACTER)
+      {
+        sym->ts.cl->backend_decl = len;
+        arglist = gfc_chainon_list (arglist,
+           convert (gfc_charlen_type_node, len));
+      }
+
  }
       else if (sym->ts.type == BT_CHARACTER)
  {
!
!    /* Pass the string length.  */
    sym->ts.cl->backend_decl = len;
    type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
    type = build_pointer_type (type);

! /* Return an address to a char[4]* temporary for character pointers. */
! if (sym->attr.pointer || sym->attr.allocatable)
! {
! /* Build char[4] * pstr. */
! tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
! convert (gfc_charlen_type_node, integer_one_node));
! tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
! tmp = build_array_type (gfc_character1_type_node, tmp);
! var = gfc_create_var (build_pointer_type (tmp), "pstr");
!
! /* Provide an address expression for the function arguments. */
! var = gfc_build_addr_expr (NULL, var);
! }
! else
! {
! var = gfc_conv_string_tmp (se, type, len);
! }
arglist = gfc_chainon_list (arglist, var);
arglist = gfc_chainon_list (arglist,
convert (gfc_charlen_type_node, len));
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1199,1215 ****
argss = gfc_walk_expr (arg->expr);


    if (argss == gfc_ss_terminator)
!             {
        gfc_conv_expr_reference (&parmse, arg->expr);
!               if (formal && formal->sym->attr.pointer
     && arg->expr->expr_type != EXPR_NULL)
!                 {
!                   /* Scalar pointer dummy args require an extra level of
!                      indirection. The null pointer already contains
!        this level of indirection.  */
!                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
!                 }
!             }
    else
      {
        /* If the procedure requires an explicit interface, the
--- 1260,1276 ----
    argss = gfc_walk_expr (arg->expr);

    if (argss == gfc_ss_terminator)
!      {
        gfc_conv_expr_reference (&parmse, arg->expr);
!        if (formal && formal->sym->attr.pointer
     && arg->expr->expr_type != EXPR_NULL)
!   {
!     /* Scalar pointer dummy args require an extra level of
!     indirection. The null pointer already contains
!     this level of indirection.  */
!     parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
!   }
!      }
    else
      {
        /* If the procedure requires an explicit interface, the
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1299,1308 ****
     gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
   }
        se->expr = info->descriptor;
      }
    else if (sym->ts.type == BT_CHARACTER)
!      {
!        se->expr = var;
        se->string_length = len;
      }
    else
--- 1360,1376 ----
     gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
   }
        se->expr = info->descriptor;
+        /* Bundle in the string length.  */
+        se->string_length = len;
      }
    else if (sym->ts.type == BT_CHARACTER)
!      {
!        /* Dereference for character pointer results.  */
!        if (sym->attr.pointer || sym->attr.allocatable)
!   se->expr = gfc_build_indirect_ref (var);
!        else
!          se->expr = var;
!
        se->string_length = len;
      }
    else
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1312,1317 ****
--- 1380,1386 ----
      }
  }
     }
+
 }


*************** gfc_trans_assignment (gfc_expr * expr1, *** 2229,2235 **** } else gfc_conv_expr (&lse, expr1); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); gfc_add_expr_to_block (&body, tmp);

--- 2298,2304 ----
     }
   else
     gfc_conv_expr (&lse, expr1);
!
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
   gfc_add_expr_to_block (&body, tmp);

! { dg-do run }
program char_pointer_assign
! Test character pointer assignments, required
! to fix PR18890
! Provided by Paul Thomas pault@gcc.gnu.org
 implicit none
 character*4, target        :: t1
 character*4, target        :: t2(4) =(/"lmno","lmno","lmno","lmno"/)
 character*4                :: const
 character*4, pointer       :: c1, c3
 character*4, pointer       :: c2(:), c4(:)
 allocate (c3, c4(4))
! Scalars first.
 c3 = "lmno"          ! pointer = constant
 t1 = c3              ! target = pointer
 c1 => t1             ! pointer =>target
 c1(2:3) = "nm"
 c3 = c1              ! pointer = pointer
 c3(1:1) = "o"
 c3(4:4) = "l"
 c1 => c3             ! pointer => pointer
 if (t1 /= "lnmo") call abort ()
 if (c1 /= "onml") call abort ()

! Now arrays.
 c4 = "lmno"          ! pointer = constant
 t2 = c4              ! target = pointer
 c2 => t2             ! pointer =>target
 const = c2(1)
 const(2:3) ="nm"     ! c2(:)(2:3) = "nm" is still broken
 c2 = const
 c4 = c2              ! pointer = pointer
 const = c4(1)
 const(1:1) ="o"      ! c4(:)(1:1) = "o" is still broken
 const(4:4) ="l"      ! c4(:)(4:4) = "l" is still broken
 c4 = const
 c2 => c4             ! pointer => pointer
 if (any (t2 /= "lnmo")) call abort ()
 if (any (c2 /= "onml")) call abort ()
 deallocate (c3, c4)
end program char_pointer_assign

! { dg-do run }
program char_pointer_dummy
! Test character pointer dummy arguments, required
! to fix PR16939 and PR18689
! Provided by Paul Thomas pault@gcc.gnu.org
 implicit none
 character*4                :: c0
 character*4, pointer       :: c1
 character*4, pointer       :: c2(:)
 allocate (c1, c2(1))
! Check that we have not broken non-pointer characters.
 c0 = "wxyz"
 call foo (c0)
! Now the pointers
 c1 = "wxyz"
 call sfoo (c1)
 c2 = "wxyz"
 call afoo (c2)
 deallocate (c1, c2)
contains
 subroutine foo (cc1)
   character*4                :: cc1
   if (cc1 /= "wxyz") call abort ()
 end subroutine foo
 subroutine sfoo (sc1)
   character*4, pointer       :: sc1
   if (sc1 /= "wxyz") call abort ()
 end subroutine sfoo
 subroutine afoo (ac1)
   character*4, pointer       :: ac1(:)
   if (ac1(1) /= "wxyz") call abort ()
 end subroutine afoo
end program char_pointer_dummy

! { dg-do run }
program char_pointer_func
! Test assignments from character pointer functions, required
! to fix PR17192 and PR17202
! Provided by Paul Thomas pault@gcc.gnu.org
implicit none
character*4 :: c0
character*4, pointer :: c1
character*4, pointer :: c2(:)
allocate (c1, c2(1))
! Check that we have not broken non-pointer characters.
c0 = foo ()
if (c0 /= "abcd") call abort ()
! Value assignments
c1 = sfoo ()
if (c1 /= "abcd") call abort ()
c2 = afoo (c0)
if (c2(1) /= "abcd") call abort ()
deallocate (c1, c2)
! Pointer assignments
c1 => sfoo ()
if (c1 /= "abcd") call abort ()
c2 => afoo (c0)
if (c2(1) /= "abcd") call abort ()
deallocate (c1, c2)
contains
function foo () result (cc1)
character*4 :: cc1
cc1 = "abcd"
end function foo
function sfoo () result (sc1)
character*4, pointer :: sc1
allocate (sc1)
sc1 = "abcd"
end function sfoo
function afoo (c0) result (ac1)
character*4 :: c0
character*4, pointer :: ac1(:)
allocate (ac1(1))
ac1 = "abcd"
end function afoo
end program char_pointer_func




Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]