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

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

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);

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),
+		  gfc_add_modify (&se->pre, var,
-					      null_pointer_node));
+				  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
+      /* Add the string length to the argument list.  */
-	    && (sym->attr.allocatable || sym->attr.pointer))
+      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);
 	}
-
+      else if (ts.type == BT_CHARACTER)
-      /* Add the string length to the argument list.  */
-      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;
-		se->string_length = len;
-	      else if (sym->attr.allocatable || sym->attr.pointer)
-		se->string_length = cl.backend_decl;
 	    }
 	  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
+	  && !expr1->ts.deferred
-			&& (TREE_CODE (lse.string_length) == VAR_DECL))
 	  && !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));
 	}

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.

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
+

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

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