diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 16 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 | 76 |
4 files changed, 102 insertions, 2 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index eeb79d9..668a043 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2015-12-29 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/69011 + * trans-stmt.c (gfc_trans_allocate): Unwrap a NOP_EXPR to make sure + the actual type of the source=-expr is used when it is of class type. + Furthermore prevent an ICE. + 2015-12-18 Paul Thomas <pault@gcc.gnu.org> PR fortran/68196 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 72416d4..3c6fae1 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5377,7 +5377,20 @@ gfc_trans_allocate (gfc_code * code) if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else - gfc_conv_expr_reference (&se, code->expr3); + { + gfc_conv_expr_reference (&se, code->expr3); + + /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a + NOP_EXPR, which prevents gfortran from getting the vptr + from the source=-expression. Remove the NOP_EXPR and go + with the POINTER_PLUS_EXPR in this case. */ + if (code->expr3->ts.type == BT_CLASS + && TREE_CODE (se.expr) == NOP_EXPR + && TREE_CODE (TREE_OPERAND (se.expr, 0)) + == POINTER_PLUS_EXPR) + //&& ! GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) + se.expr = TREE_OPERAND (se.expr, 0); + } /* Create a temp variable only for component refs to prevent having to go through the full deref-chain each time and to simplfy computation of array properties. */ @@ -5494,7 +5507,6 @@ gfc_trans_allocate (gfc_code * code) expr3 may be a temporary array declaration, therefore check for GFC_CLASS_TYPE_P before trying to get the _vptr component. */ if (tmp != NULL_TREE - && TREE_CODE (tmp) != POINTER_PLUS_EXPR && (e3_is == E3_DESC || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) && (VAR_P (tmp) || !code->expr3->ref)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0cc0603..65ec5c5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-12-29 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/69011 + * gfortran.dg/allocate_with_source_16.f90: New test. + 2015-12-28 Uros Bizjak <ubizjak@gmail.com> * gcc.target/i386/*.c: Remove extra braces from target selectors. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 new file mode 100644 index 0000000..cb5f16f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! Test the fix for pr69011, preventing an ICE and making sure +! that the correct dynamic type is used. +! +! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> +! Andre Vehreschild <vehre@gcc.gnu.org> +! + +module m1 +implicit none +private +public :: basetype + +type:: basetype + integer :: i + contains +endtype basetype + +abstract interface +endinterface + +endmodule m1 + +module m2 +use m1, only : basetype +implicit none +integer, parameter :: I_P = 4 + +private +public :: factory, exttype + +type, extends(basetype) :: exttype + integer :: i2 + contains +endtype exttype + +type :: factory + integer(I_P) :: steps=-1 + contains + procedure, pass(self), public :: construct +endtype factory +contains + + function construct(self, previous) + class(basetype), intent(INOUT) :: previous(1:) + class(factory), intent(IN) :: self + class(basetype), pointer :: construct + allocate(construct, source=previous(self%steps)) + endfunction construct +endmodule m2 + + use m2 + use m1 + class(factory), allocatable :: c1 + class(exttype), allocatable :: prev(:) + class(basetype), pointer :: d + + allocate(c1) + allocate(prev(2)) + prev(:)%i = [ 2, 3] + prev(:)%i2 = [ 5, 6] + c1%steps= 1 + d=> c1%construct(prev) + + if (.not. associated(d) ) call abort() + select type (d) + class is (exttype) + if (d%i2 /= 5) call abort() + class default + call abort() + end select + if (d%i /= 2) call abort() + deallocate(c1) + deallocate(prev) + deallocate(d) +end |