re PR fortran/79072 (ICE with class(*) pointer function result and character value)

2017-11-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/79072
	* trans-expr.c (trans_class_vptr_len_assignment): Set from_len
	if the temporary is unlimited polymorphic.
	* trans-stmt.c (trans_associate_var): Use the fake result decl
	to obtain the 'len' field from an explicit function result when
	in that function scope.

2017-11-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/79072
	* gfortran.dg/class_result_5.f90: New test.

From-SVN: r254966

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5dea20437e24b9484257b57df67889d495b978f0..4ba7327be33e5b912dc8489d8cdb597cdc234d94 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2017-11-20  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/79072
+       * trans-expr.c (trans_class_vptr_len_assignment): Set from_len
+       if the temporary is unlimited polymorphic.
+       * trans-stmt.c (trans_associate_var): Use the fake result decl
+       to obtain the 'len' field from an explicit function result when
+       in that function scope.
+
 2017-11-19  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/78990

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 92d37ec090199c90246ff044a5e658de3dda870e..2ca0ad6f6f0560ae6b0ef3f8836702a07291c135 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -8131,6 +8131,8 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
            {
              vptr_expr = NULL;
              se.expr = gfc_class_vptr_get (rse->expr);
+             if (UNLIMITED_POLY (re))
+               from_len = gfc_class_len_get (rse->expr);
            }
          else if (re->expr_type != EXPR_NULL)
            /* Only when rhs is non-NULL use its declared type for vptr

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a89751bfd79aaecee5073886f44d9b04049af110..6cf798160997d55688717b619892af36249f37ba 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1827,6 +1827,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
          gcc_assert (!e->symtree->n.sym->ts.deferred);
          tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
        }
+      else if (e->symtree->n.sym->attr.function
+              && e->symtree->n.sym == e->symtree->n.sym->result
+              && e->symtree->n.sym == e->symtree->n.sym->ns->proc_name)
+       {
+         tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+         tmp = gfc_class_len_get (tmp);
+       }
       else
        tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
       gfc_get_symbol_decl (sym);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c8f4f498852ab68319cf8ea3fcb6be90bce2a92c..949eb1946a3c5d8efaa5b70fb082a9a809b132a0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-11-20  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/79072
+       * gfortran.dg/class_result_5.f90: New test.
+
 2017-11-20  Jakub Jelinek  <jakub@redhat.com>
 
        P0329R4: Designated Initialization

diff --git a/gcc/testsuite/gfortran.dg/class_result_5.f90 b/gcc/testsuite/gfortran.dg/class_result_5.f90
new file mode 100644 (file)
index 0000000..c557ed3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_result_5.f90
@@ -0,0 +1,38 @@
+! { dg-do run }
+!
+! Test the fix for PR79072. The original problem was that an ICE
+! would occur in the select type construct. On fixing that, it was
+! found that the string length was not being transferred in the
+! pointer assignment in the main program.
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+function foo(string)
+  class(*), pointer :: foo
+  character(3), target :: string
+  foo => string
+  select type (foo)
+    type is (character(*))
+      if (foo .ne. 'foo') call abort
+      foo = 'bar'
+  end select
+end function
+
+  interface
+    function foo(string)
+      class(*), pointer :: foo
+      character(3), target :: string
+    end function
+  end interface
+
+  class(*), pointer :: res
+  character(3), target :: string = 'foo'
+
+  res => foo (string)
+
+  select type (res)
+    type is (character(*))
+      if (res .ne. 'bar') call abort
+  end select
+  if (string .ne. 'bar') call abort
+end