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 -redux


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. Tabs are present in the original patch and will be committed. (A patch to fix PR18109 is on its way - character array initialisers as actual arguments. It has been slowed up by the most general testcase hiting other character bugs. CALL foo ( (/"abcd"/) ) now works fine.)

I have added the test case to check that dependencies are indeed resolved.

I checked that the char[]* temp and its subsequent dereferencing in gfc_conv_function_call is still necessary after resolving the problem with dependencies.

Fortran changelog entry.

2005-05-27 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.

Testsuite changelog entry.

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

   * gfortran.dg/char_pointer_assign.f90:
   Test character pointer assignments and pointer assignments.
   * gfortran.dg/char_pointer_dummy.f90:
   Test character pointer dummy arguments to procedures.
   * gfortran.dg/char_pointer_func.f90:
   Test character pointer pointer function returns.
   * gfortran.dg/char_pointer_dependency.f90:
   Test character pointer functions with dependencies.

Bootstrapped and regtested on i686/RH9. OK to commit on Sunday if there are no adverse comments?

Paul Thomas

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

! { dg-do run }
program char_pointer_assign
! Test character pointer assignments, required
! to fix PR18890 and PR21297
! 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_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
! { dg-do run }
! Test assignments from character pointer functions with dependencies
! are correctly resolved.
! Provided by Paul Thomas pault@gcc.gnu.org
program char_pointer_dependency
  implicit none
  character*4, pointer       :: c2(:)
  allocate (c2(2))
  c2 => afoo (c2)
  if (c2(1) /= "efgh") call abort ()
  if (c2(2) /= "abcd") call abort ()
  deallocate (c2)
contains
  function afoo (ac0) result (ac1)
    integer                    :: j
    character*4                :: ac0(:)
    character*4, pointer       :: ac1(:)
    allocate (ac1(2))
    do j = 1,2
      ac1(j) = ac0(3-j)
    end do
  end function afoo
end program char_pointer_dependency
! { 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
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);


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