Dear All,
This is not quite an 'obvious' patch but it does speak for itself. If
there are no objections in the meantime, I will commit it tomorrow
evening.
Bootstraps and regtests on FC23/x86_64 - OK for trunk? What about 7-branch?
Cheers
Paul
2017-11-18 Paul Thomas <pa...@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-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/79072
* gfortran.dg/class_result_5.f90: New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 254626)
--- gcc/fortran/trans-expr.c (working copy)
*************** trans_class_vptr_len_assignment (stmtblo
*** 8115,8120 ****
--- 8115,8122 ----
{
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
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 254626)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1827,1832 ****
--- 1827,1839 ----
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);
Index: gcc/testsuite/gfortran.dg/class_result_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/class_result_5.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/class_result_5.f90 (working copy)
***************
*** 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.carl...@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
