re PR fortran/52158 (Regression on character function with gfortran 4.7)

2012-05-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
            Tobias Burnus  <burnus@net-b.de>

        PR fortran/52158
        PR fortran/45170
        PR fortran/49430
        * resolve.c (resolve_fl_derived0): Deferred character length
        procedure components are supported.
        * trans-expr.c (gfc_conv_procedure_call): Handle TBP with
        deferred-length results.
        (gfc_string_to_single_character): Add a new check to prevent
        NULL read.
        (gfc_conv_procedure_call): Remove unuseful checks on
        symbol's attributes. Add new checks to prevent NULL read on
        string length.

2012-05-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>

        PR fortran/45170
        * gfortran.dg/deferred_type_param_3.f90: New.
        * gfortran.dg/deferred_type_proc_pointer_1.f90: New.
        * gfortran.dg/deferred_type_proc_pointer_2.f90: New.

Co-Authored-By: Tobias Burnus <burnus@net-b.de>
From-SVN: r187436

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index faffa290f24974b2126563fb6e31dc3a59d95899..251194b46af04c42e6de76b54ddb05add85341c1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2012-05-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+           Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52158
+       PR fortran/45170
+       PR fortran/49430
+       * resolve.c (resolve_fl_derived0): Deferred character length 
+       procedure components are supported.
+       * trans-expr.c (gfc_conv_procedure_call): Handle TBP with 
+       deferred-length results.
+       (gfc_string_to_single_character): Add a new check to prevent
+       NULL read.
+       (gfc_conv_procedure_call): Remove unuseful checks on 
+       symbol's attributes. Add new checks to prevent NULL read on
+       string length. 
+
 2012-05-12  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/49110

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4a072303c496208b9871733af489441c0dfbb0e4..9814c14753af7d5c6ec89a4d03abf951a1f0c681 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11665,7 +11665,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
   for ( ; c != NULL; c = c->next)
     {
       /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170.  */
-      if (c->ts.type == BT_CHARACTER && c->ts.deferred)
+      if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
        {
          gfc_error ("Deferred-length character component '%s' at %L is not "
                     "yet supported", c->name, &c->loc);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8045b1f029b81d9bfee65abb912431dee75fabe6..81562d2162d6faae650ae58a7466d35f13e60505 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2073,7 +2073,8 @@ tree
 gfc_string_to_single_character (tree len, tree str, int kind)
 {
 
-  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+  if (len == NULL
+      || !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
       || !POINTER_TYPE_P (TREE_TYPE (str)))
     return NULL_TREE;
 
@@ -4175,7 +4176,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
             we take the character length of the first argument for the result.
             For dummies, we have to look through the formal argument list for
             this function and use the character length found there.*/
-         if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+         if (ts.deferred)
            cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
          else if (!sym->attr.dummy)
            cl.backend_decl = VEC_index (tree, stringargs, 0);
@@ -4186,6 +4187,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                if (strcmp (formal->sym->name, sym->name) == 0)
                  cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
            }
+         len = cl.backend_decl;
         }
       else
         {
@@ -4343,9 +4345,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
              if ((!comp && sym->attr.allocatable)
                  || (comp && comp->attr.allocatable))
-               gfc_add_modify (&se->pre, var,
-                               fold_convert (TREE_TYPE (var),
-                                             null_pointer_node));
+               {
+                 gfc_add_modify (&se->pre, var,
+                                 fold_convert (TREE_TYPE (var),
+                                               null_pointer_node));
+                 tmp = gfc_call_free (convert (pvoid_type_node, var));
+                 gfc_add_expr_to_block (&se->post, tmp);
+               }
 
              /* Provide an address expression for the function arguments.  */
              var = gfc_build_addr_expr (NULL_TREE, var);
@@ -4364,17 +4370,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          VEC_safe_push (tree, gc, retargs, var);
        }
 
-      if (ts.type == BT_CHARACTER && ts.deferred
-           && (sym->attr.allocatable || sym->attr.pointer))
+      /* Add the string length to the argument list.  */
+      if (ts.type == BT_CHARACTER && ts.deferred)
        {
          tmp = len;
          if (TREE_CODE (tmp) != VAR_DECL)
            tmp = gfc_evaluate_now (len, &se->pre);
-         len = gfc_build_addr_expr (NULL_TREE, tmp);
+         tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+         VEC_safe_push (tree, gc, retargs, tmp);
        }
-
-      /* Add the string length to the argument list.  */
-      if (ts.type == BT_CHARACTER)
+      else if (ts.type == BT_CHARACTER)
        VEC_safe_push (tree, gc, retargs, len);
     }
   gfc_free_interface_mapping (&mapping);
@@ -4483,10 +4488,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              else
                se->expr = var;
 
-             if (!ts.deferred)
-               se->string_length = len;
-             else if (sym->attr.allocatable || sym->attr.pointer)
-               se->string_length = cl.backend_decl;
+             se->string_length = len;
            }
          else
            {
@@ -5776,8 +5778,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
         really added if -fbounds-check is enabled.  Exclude deferred
         character length lefthand sides.  */
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
-         && !(expr1->ts.deferred
-                       && (TREE_CODE (lse.string_length) == VAR_DECL))
+         && !expr1->ts.deferred
          && !expr1->symtree->n.sym->attr.proc_pointer
          && !gfc_is_proc_ptr_comp (expr1, NULL))
        {
@@ -5790,11 +5791,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       /* The assignment to an deferred character length sets the string
         length to that of the rhs.  */
-      if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+      if (expr1->ts.deferred)
        {
-         if (expr2->expr_type != EXPR_NULL)
+         if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
            gfc_add_modify (&block, lse.string_length, rse.string_length);
-         else
+         else if (lse.string_length != NULL)
            gfc_add_modify (&block, lse.string_length,
                            build_int_cst (gfc_charlen_type_node, 0));
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2869ef23e1f55c86dd69ccd6d23ec3fe37c47557..9a34ac44c358448afa6217a25e776fb8d27436b3 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2012-05-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
+
+       PR fortran/45170
+       * gfortran.dg/deferred_type_param_3.f90: New.
+       * gfortran.dg/deferred_type_proc_pointer_1.f90: New.
+       * gfortran.dg/deferred_type_proc_pointer_2.f90: New.
+
 2012-05-12  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/null_pointer_deref3.adb: New test.

diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90
new file mode 100644 (file)
index 0000000..809738d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_param_3.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! PR fortran/45170
+! PR fortran/52158
+!
+! Contributed by Damian Rouson
+
+module speaker_class
+  type speaker
+  contains
+    procedure :: speak
+  end type
+contains
+  function speak(this)
+    class(speaker) ,intent(in) :: this
+    character(:) ,allocatable :: speak
+  end function
+  subroutine say_something(somebody)
+    class(speaker) :: somebody
+    print *,somebody%speak()
+  end subroutine
+end module
+

diff --git a/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90
new file mode 100644 (file)
index 0000000..3fc055e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_1.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! PR fortran/45170
+! PR fortran/52158
+!
+! Contributed by Tobias Burnus
+
+module test
+ implicit none
+ type t
+   procedure(deferred_len), pointer, nopass :: ppt
+ end type t
+contains
+ function deferred_len()
+   character(len=:), allocatable :: deferred_len
+   deferred_len = 'abc'
+ end function deferred_len
+ subroutine doIt()
+   type(t) :: x
+   x%ppt => deferred_len
+   if ("abc" /= x%ppt()) call abort()
+ end subroutine doIt
+end module test
+
+use test
+call doIt ()
+end

diff --git a/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90
new file mode 100644 (file)
index 0000000..dbdb3bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_proc_pointer_2.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! PR fortran/45170
+! PR fortran/52158
+
+module test
+ implicit none
+ type t
+   procedure(deferred_len), pointer, nopass :: ppt
+ end type t
+contains
+ function deferred_len()
+   character(len=:), allocatable :: deferred_len
+   deferred_len = 'abc'
+ end function deferred_len
+ subroutine doIt()
+   type(t) :: x
+   character(:), allocatable :: temp
+   x%ppt => deferred_len
+   temp = deferred_len()
+   if ("abc" /= temp) call abort()
+ end subroutine doIt
+end module test
+
+use test
+call doIt ()
+end