re PR fortran/69423 (Invalid optimization with deferred-length character)

2016-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69423
	* trans-decl.c (create_function_arglist): Deferred character
	length functions, with and without declared results, address
	the passed reference type as '.result' and the local string
	length as '..result'.
	(gfc_null_and_pass_deferred_len): Helper function to null and
	return deferred string lengths, as needed.
	(gfc_trans_deferred_vars): Call it, thereby reducing repeated
	code, add call for deferred arrays and reroute pointer function
	results. Avoid using 'tmp' for anything other that a temporary
	tree by introducing 'type_of_array' for the arrayspec type.

2016-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69423
	* gfortran.dg/deferred_character_15.f90 : New test.

From-SVN: r233589

gcc/fortran/ChangeLog

+2016-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/69423
+	* trans-decl.c (create_function_arglist): Deferred character
+	length functions, with and without declared results, address
+	the passed reference type as '.result' and the local string
+	length as '..result'.
+	(gfc_null_and_pass_deferred_len): Helper function to null and
+	return deferred string lengths, as needed.
+	(gfc_trans_deferred_vars): Call it, thereby reducing repeated
+	code, add call for deferred arrays and reroute pointer function
+	results. Avoid using 'tmp' for anything other that a temporary
+	tree by introducing 'type_of_array' for the arrayspec type.
+
 2015-02-16  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/69742

gcc/fortran/trans-decl.c

@@ -2234,7 +2234,12 @@ create_function_arglist (gfc_symbol * sym)
 			       PARM_DECL,
 			       get_identifier (".__result"),
 			       len_type);
-	  if (!sym->ts.u.cl->length)
+	  if (POINTER_TYPE_P (len_type))
+	    {
+	      sym->ts.u.cl->passed_length = length;
+	      TREE_USED (length) = 1;
+	    }
+	  else if (!sym->ts.u.cl->length)
 	    {
 	      sym->ts.u.cl->backend_decl = length;
 	      TREE_USED (length) = 1;
@@ -2271,13 +2276,6 @@ create_function_arglist (gfc_symbol * sym)
 	      type = gfc_sym_type (arg);
 	      arg->backend_decl = backend_decl;
 	      type = build_reference_type (type);
-
-	      if (POINTER_TYPE_P (len_type))
-		{
-		  sym->ts.u.cl->passed_length = length;
-		  sym->ts.u.cl->backend_decl =
-		    build_fold_indirect_ref_loc (input_location, length);
-		}
 	    }
 	}
 
@@ -3917,6 +3915,62 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 }
 
 
+/* Helper function to manage deferred string lengths.  */
+
+static tree
+gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
+			        locus *loc)
+{
+  tree tmp;
+
+  /* Character length passed by reference.  */
+  tmp = sym->ts.u.cl->passed_length;
+  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  tmp = fold_convert (gfc_charlen_type_node, tmp);
+
+  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+    /* Zero the string length when entering the scope.  */
+    gfc_add_modify (init, sym->ts.u.cl->backend_decl,
+		    build_int_cst (gfc_charlen_type_node, 0));
+  else
+    {
+      tree tmp2;
+
+      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+			      gfc_charlen_type_node,
+			      sym->ts.u.cl->backend_decl, tmp);
+      if (sym->attr.optional)
+	{
+	  tree present = gfc_conv_expr_present (sym);
+	  tmp2 = build3_loc (input_location, COND_EXPR,
+			     void_type_node, present, tmp2,
+			     build_empty_stmt (input_location));
+	}
+      gfc_add_expr_to_block (init, tmp2);
+    }
+
+  gfc_restore_backend_locus (loc);
+
+  /* Pass the final character length back.  */
+  if (sym->attr.intent != INTENT_IN)
+    {
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+			     gfc_charlen_type_node, tmp,
+			     sym->ts.u.cl->backend_decl);
+      if (sym->attr.optional)
+	{
+	  tree present = gfc_conv_expr_present (sym);
+	  tmp = build3_loc (input_location, COND_EXPR,
+			    void_type_node, present, tmp,
+			    build_empty_stmt (input_location));
+	}
+    }
+  else
+    tmp = NULL_TREE;
+
+  return tmp;
+}
+
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
     Allocation and initialization of array variables.
@@ -3966,7 +4020,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	  /* An automatic character length, pointer array result.  */
 	  if (proc_sym->ts.type == BT_CHARACTER
 		&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
-	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
+	    {
+	      tmp = NULL;
+	      if (proc_sym->ts.deferred)
+		{
+		  gfc_save_backend_locus (&loc);
+		  gfc_set_backend_locus (&proc_sym->declared_at);
+		  gfc_start_block (&init);
+		  tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
+		  gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+		}
+	      else
+		gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
+	    }
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
@@ -3993,7 +4059,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
 	      /* Pass back the string length on exit.  */
 	      tmp = proc_sym->ts.u.cl->backend_decl;
-	      if (TREE_CODE (tmp) != INDIRECT_REF)
+	      if (TREE_CODE (tmp) != INDIRECT_REF
+		  && proc_sym->ts.u.cl->passed_length)
 		{
 		  tmp = proc_sym->ts.u.cl->passed_length;
 		  tmp = build_fold_indirect_ref_loc (input_location, tmp);
@@ -4072,21 +4139,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
 	  TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
 	}
-      else if (sym->attr.dimension || sym->attr.codimension
-	       || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))
+      else if ((sym->attr.dimension || sym->attr.codimension
+	       || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
 	{
 	  bool is_classarray = IS_CLASS_ARRAY (sym);
 	  symbol_attribute *array_attr;
 	  gfc_array_spec *as;
-	  array_type tmp;
+	  array_type type_of_array;
 
 	  array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
 	  as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
 	  /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT.  */
-	  tmp = as->type;
-	  if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
-	    tmp = AS_EXPLICIT;
-	  switch (tmp)
+	  type_of_array = as->type;
+	  if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
+	    type_of_array = AS_EXPLICIT;
+	  switch (type_of_array)
 	    {
 	    case AS_EXPLICIT:
 	      if (sym->attr.dummy || sym->attr.result)
@@ -4169,6 +4236,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	    case AS_DEFERRED:
 	      seen_trans_deferred_array = true;
 	      gfc_trans_deferred_array (sym, block);
+	      if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
+		  && sym->attr.result)
+		{
+		  gfc_start_block (&init);
+		  gfc_save_backend_locus (&loc);
+		  gfc_set_backend_locus (&sym->declared_at);
+		  tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
+		  gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+		}
 	      break;
 
 	    default:
@@ -4183,6 +4259,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	continue;
       else if ((!sym->attr.dummy || sym->ts.deferred)
 		&& (sym->attr.allocatable
+		    || (sym->attr.pointer && sym->attr.result)
 		    || (sym->ts.type == BT_CLASS
 			&& CLASS_DATA (sym)->attr.allocatable)))
 	{
@@ -4190,96 +4267,50 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	    {
 	      tree descriptor = NULL_TREE;
 
-	      /* Nullify and automatic deallocation of allocatable
-		 scalars.  */
-	      e = gfc_lval_expr_from_sym (sym);
-	      if (sym->ts.type == BT_CLASS)
-		gfc_add_data_component (e);
-
-	      gfc_init_se (&se, NULL);
-	      if (sym->ts.type != BT_CLASS
-		  || sym->ts.u.derived->attr.dimension
-		  || sym->ts.u.derived->attr.codimension)
-		{
-		  se.want_pointer = 1;
-		  gfc_conv_expr (&se, e);
-		}
-	      else if (sym->ts.type == BT_CLASS
-		       && !CLASS_DATA (sym)->attr.dimension
-		       && !CLASS_DATA (sym)->attr.codimension)
-		{
-		  se.want_pointer = 1;
-		  gfc_conv_expr (&se, e);
-		}
-	      else
-		{
-		  se.descriptor_only = 1;
-		  gfc_conv_expr (&se, e);
-		  descriptor = se.expr;
-		  se.expr = gfc_conv_descriptor_data_addr (se.expr);
-		  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
-		}
-	      gfc_free_expr (e);
-
 	      gfc_save_backend_locus (&loc);
 	      gfc_set_backend_locus (&sym->declared_at);
 	      gfc_start_block (&init);
 
-	      if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+	      if (!sym->attr.pointer)
 		{
-		  /* Nullify when entering the scope.  */
-		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					 TREE_TYPE (se.expr), se.expr,
-					 fold_convert (TREE_TYPE (se.expr),
-						       null_pointer_node));
-		  if (sym->attr.optional)
+		  /* Nullify and automatic deallocation of allocatable
+		     scalars.  */
+		  e = gfc_lval_expr_from_sym (sym);
+		  if (sym->ts.type == BT_CLASS)
+		    gfc_add_data_component (e);
+
+		  gfc_init_se (&se, NULL);
+		  if (sym->ts.type != BT_CLASS
+		      || sym->ts.u.derived->attr.dimension
+		      || sym->ts.u.derived->attr.codimension)
 		    {
-		      tree present = gfc_conv_expr_present (sym);
-		      tmp = build3_loc (input_location, COND_EXPR,
-					void_type_node, present, tmp,
-					build_empty_stmt (input_location));
+		      se.want_pointer = 1;
+		      gfc_conv_expr (&se, e);
+		    }
+		  else if (sym->ts.type == BT_CLASS
+			   && !CLASS_DATA (sym)->attr.dimension
+			   && !CLASS_DATA (sym)->attr.codimension)
+		    {
+		      se.want_pointer = 1;
+		      gfc_conv_expr (&se, e);
 		    }
-		  gfc_add_expr_to_block (&init, tmp);
-		}
-
-	      if ((sym->attr.dummy || sym->attr.result)
-		    && sym->ts.type == BT_CHARACTER
-		    && sym->ts.deferred)
-		{
-		  /* Character length passed by reference.  */
-		  tmp = sym->ts.u.cl->passed_length;
-		  tmp = build_fold_indirect_ref_loc (input_location, tmp);
-		  tmp = fold_convert (gfc_charlen_type_node, tmp);
-
-		  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
-		    /* Zero the string length when entering the scope.  */
-		    gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
-				build_int_cst (gfc_charlen_type_node, 0));
 		  else
 		    {
-		      tree tmp2;
-
-		      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
-					      gfc_charlen_type_node,
-					      sym->ts.u.cl->backend_decl, tmp);
-		      if (sym->attr.optional)
-			{
-			  tree present = gfc_conv_expr_present (sym);
-			  tmp2 = build3_loc (input_location, COND_EXPR,
-					     void_type_node, present, tmp2,
-					     build_empty_stmt (input_location));
-			}
-		      gfc_add_expr_to_block (&init, tmp2);
+		      se.descriptor_only = 1;
+		      gfc_conv_expr (&se, e);
+		      descriptor = se.expr;
+		      se.expr = gfc_conv_descriptor_data_addr (se.expr);
+		      se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
 		    }
+		  gfc_free_expr (e);
 
-		  gfc_restore_backend_locus (&loc);
-
-		  /* Pass the final character length back.  */
-		  if (sym->attr.intent != INTENT_IN)
+		  if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
 		    {
+		      /* Nullify when entering the scope.  */
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					     gfc_charlen_type_node, tmp,
-					     sym->ts.u.cl->backend_decl);
+					     TREE_TYPE (se.expr), se.expr,
+					     fold_convert (TREE_TYPE (se.expr),
+							   null_pointer_node));
 		      if (sym->attr.optional)
 			{
 			  tree present = gfc_conv_expr_present (sym);
@@ -4287,16 +4318,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 					    void_type_node, present, tmp,
 					    build_empty_stmt (input_location));
 			}
+		      gfc_add_expr_to_block (&init, tmp);
 		    }
-		  else
-		    tmp = NULL_TREE;
 		}
+
+	      if ((sym->attr.dummy || sym->attr.result)
+		    && sym->ts.type == BT_CHARACTER
+		    && sym->ts.deferred
+		    && sym->ts.u.cl->passed_length)
+		tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
 	      else
 		gfc_restore_backend_locus (&loc);
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
-	      if (!sym->attr.result && !sym->attr.dummy
+	      if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
 		  && !sym->ns->proc_name->attr.is_main_program)
 		{
 		  if (sym->ts.type == BT_CLASS
@@ -4313,6 +4349,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		      gfc_free_expr (expr);
 		    }
 		}
+
 	      if (sym->ts.type == BT_CLASS)
 		{
 		  /* Initialize _vptr to declared type.  */
@@ -4353,19 +4390,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	  if (sym->attr.dummy)
 	    {
 	      gfc_start_block (&init);
-
-	      /* Character length passed by reference.  */
-	      tmp = sym->ts.u.cl->passed_length;
-	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
-	      tmp = fold_convert (gfc_charlen_type_node, tmp);
-	      gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
-	      /* Pass the final character length back.  */
-	      if (sym->attr.intent != INTENT_IN)
-		tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				       gfc_charlen_type_node, tmp,
-				       sym->ts.u.cl->backend_decl);
-	      else
-		tmp = NULL_TREE;
+	      gfc_save_backend_locus (&loc);
+	      gfc_set_backend_locus (&sym->declared_at);
+	      tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 	    }
 	}
@@ -4427,6 +4454,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
 }
 
+
 struct module_hasher : ggc_ptr_hash<module_htab_entry>
 {
   typedef const char *compare_type;

gcc/testsuite/ChangeLog

+2016-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/69423
+	* gfortran.dg/deferred_character_15.f90 : New test.
+
 2016-02-20  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
 	PR fortran/57365

gcc/testsuite/gfortran.dg/deferred_character_15.f90

+! { dg-do run }
+!
+! Test the fix for PR69423.
+!
+! Contributed by Antony Lewis  <antony@cosmologist.info>
+!
+program tester
+  character(LEN=:), allocatable :: S
+  S= test(2)
+  if (len(S) .ne. 4) call abort
+  if (S .ne. "test") call abort
+  if (allocated (S)) deallocate (S)
+
+  S= test2(2)
+  if (len(S) .ne. 4) call abort
+  if (S .ne. "test") call abort
+  if (allocated (S)) deallocate (S)
+contains
+  function test(alen)
+    character(LEN=:), allocatable :: test
+    integer alen, i
+    do i = alen, 1, -1
+      test = 'test'
+      exit
+    end do
+!       This line would print nothing when compiled with -O1 and higher.
+!       print *, len(test),test
+    if (len(test) .ne. 4) call abort
+    if (test .ne. "test") call abort
+  end function test
+
+  function test2(alen) result (test)
+    character(LEN=:), allocatable :: test
+    integer alen, i
+    do i = alen, 1, -1
+      test = 'test'
+      exit
+    end do
+!       This worked before the fix.
+!       print *, len(test),test
+    if (len(test) .ne. 4) call abort
+    if (test .ne. "test") call abort
+  end function test2
+end program tester