Message ID | CAGkQGi+WokBZPh9hw=70640UqGo4cKkWyRS8MMJVf9-Z36r-_Q@mail.gmail.com |
---|---|
State | New |
Headers | show |
Dear All, I noticed last night that the component array version of Michael's testcase doesn't even get past resolution. The attached is an updated version of the patch that fixes that. Although the additional bits of the patch do not fix a regression, I think that it is worth having the extra functionality; especially since it is somewhat clearer than using allocate with a source expression. A ChangeLog will follow later on. Please note that I changed the name of the original testcase because it had class and type the wrong way round :-) Bootstraps and regtests on x86_64 - OK for trunk? Best regards Paul On 28 January 2015 at 21:09, Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote: > Dear All, > > This regression was caused by the patch for PR60357. The fix is > straightforward. Please note however, that I have not checked for > other fallout yet - I have merely addressed the reported failure. I > will check around the reported testcase tomorrow night. > > Dominique, thanks for the rapid feedback. > > class_to_type_4.f90 is reserved for the patch for PR63205. > > Bootstrapped and regtested on x86_64/FC21 - OK for trunk? > > Michael, many thanks for a prompt report. Please come back to us with > any more bugs that you find! > > Cheers > > Paul > > 2015-01-28 Paul Thomas <pault@gcc.gnu.org> > > PR fortran/640757 > * trans-expr.c > (alloc_scalar_allocatable_for_subcomponent_assignment): If comp > is a class component, get the data pointer. > (gfc_trans_subcomponent_assign): If a class component with a > derived type expression get the data pointer for the assignment > and set the vptr. > > 2015-01-28 Paul Thomas <pault@gcc.gnu.org> > > PR fortran/640757 > * gfortran.dg/class_to_type_5.f90: New test
Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 220083) +++ gcc/fortran/trans-expr.c (working copy) @@ -6335,6 +6335,7 @@ gfc_symbol *sym) { tree tmp; + tree ptr; tree size; tree size_in_bytes; tree lhs_cl_size = NULL_TREE; @@ -6400,8 +6401,12 @@ tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MALLOC), 1, size_in_bytes); - tmp = fold_convert (TREE_TYPE (comp), tmp); - gfc_add_modify (block, comp, tmp); + if (GFC_CLASS_TYPE_P (TREE_TYPE (comp))) + ptr = gfc_class_data_get (comp); + else + ptr = comp; + tmp = fold_convert (TREE_TYPE (ptr), tmp); + gfc_add_modify (block, ptr, tmp); } if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) @@ -6504,7 +6509,21 @@ if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer && expr->symtree->n.sym->attr.dummy) se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - tmp = build_fold_indirect_ref_loc (input_location, dest); + + if (GFC_CLASS_TYPE_P (TREE_TYPE (dest)) && expr->ts.type == BT_DERIVED) + { + tree vtab; + tmp = gfc_class_data_get (dest); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts)); + vtab = gfc_build_addr_expr (NULL_TREE, vtab); + gfc_add_modify (&block, gfc_class_vptr_get (dest), + fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab)); + } + else + tmp = build_fold_indirect_ref_loc (input_location, dest); + + /* For deferred strings insert a memcpy. */ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { Index: gcc/testsuite/gfortran.dg/class_to_type_5.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_to_type_5.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/class_to_type_5.f03 (working copy) @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Test the fix for PR64757. +! +! Contributed by Michael Lee Rilee <mike@rilee.net> +! + type :: Test + integer :: i + end type + + type :: TestReference + class(Test), allocatable :: test + end type + + type(TestReference) :: testList + type(test) :: x + + testList = TestReference(Test(99)) ! ICE in fold_convert_loc was here + + x = testList%test + + select type (y => testList%test) ! Check vptr set + type is (Test) + if (x%i .ne. y%i) call abort + class default + call abort + end select +end + +