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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5cf25a476938eb95eef4ad1ef20a219dbc72db90..99d13666804ba5065a646d0707be4e6a1827b290 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 21d0ba866bb91f41c2fc269396916796a0444ee9..4e7129e150a92f9a3c254764a02f63b54fa3883a 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 77a4c01dec64853d3163642986a2a8e5fcda48d8..6c730519121a066a06baf3364a83a239e18d3a7c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/deferred_character_15.f90 b/gcc/testsuite/gfortran.dg/deferred_character_15.f90
new file mode 100644 (file)
index 0000000..c641c1f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_character_15.f90
@@ -0,0 +1,44 @@
+! { 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