PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992
2013-01-06 Paul Thomas <pault@gcc.gnu.org> PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992 * trans-array.c (build_array_ref): Check the TYPE_CANONICAL to see if it is GFC_CLASS_TYPE_P. * trans-expr.c (gfc_get_vptr_from_expr): The same. (gfc_conv_class_to_class): If the types are not the same, cast parmese->expr to the type of ctree. * trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of CLASS components must be set. 2013-01-06 Paul Thomas <pault@gcc.gnu.org> PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992 * gfortran.dg/class_array_15.f03: New test. From-SVN: r194953
This commit is contained in:
Paul Thomas
parent
1ab05c31a0
commit
f04986a90b
6 changed files with 247 additions and 77 deletions
|
|
@ -1,3 +1,16 @@
|
|||
2013-01-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/PR53876
|
||||
PR fortran/PR54990
|
||||
PR fortran/PR54992
|
||||
* trans-array.c (build_array_ref): Check the TYPE_CANONICAL
|
||||
to see if it is GFC_CLASS_TYPE_P.
|
||||
* trans-expr.c (gfc_get_vptr_from_expr): The same.
|
||||
(gfc_conv_class_to_class): If the types are not the same,
|
||||
cast parmese->expr to the type of ctree.
|
||||
* trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of
|
||||
CLASS components must be set.
|
||||
|
||||
2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/42769
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Array translation routines
|
||||
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
||||
2011, 2012
|
||||
2011, 2012, 2013
|
||||
Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
||||
|
|
@ -3099,31 +3099,40 @@ static tree
|
|||
build_array_ref (tree desc, tree offset, tree decl)
|
||||
{
|
||||
tree tmp;
|
||||
tree type;
|
||||
|
||||
/* Class container types do not always have the GFC_CLASS_TYPE_P
|
||||
but the canonical type does. */
|
||||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
|
||||
&& TREE_CODE (desc) == COMPONENT_REF)
|
||||
{
|
||||
type = TREE_TYPE (TREE_OPERAND (desc, 0));
|
||||
if (TYPE_CANONICAL (type)
|
||||
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
|
||||
type = TYPE_CANONICAL (type);
|
||||
}
|
||||
else
|
||||
type = NULL;
|
||||
|
||||
/* Class array references need special treatment because the assigned
|
||||
type size needs to be used to point to the element. */
|
||||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
|
||||
&& TREE_CODE (desc) == COMPONENT_REF
|
||||
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
|
||||
if (type && GFC_CLASS_TYPE_P (type))
|
||||
{
|
||||
tree type = gfc_get_element_type (TREE_TYPE (desc));
|
||||
type = gfc_get_element_type (TREE_TYPE (desc));
|
||||
tmp = TREE_OPERAND (desc, 0);
|
||||
tmp = gfc_get_class_array_ref (offset, tmp);
|
||||
tmp = fold_convert (build_pointer_type (type), tmp);
|
||||
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
||||
return tmp;
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
tmp = gfc_conv_array_data (desc);
|
||||
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
||||
tmp = gfc_build_array_ref (tmp, offset, decl);
|
||||
}
|
||||
|
||||
return tmp;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Build an array reference. se->expr already holds the array descriptor.
|
||||
This should be either a variable, indirect variable reference or component
|
||||
reference. For arrays which do not have a descriptor, se->expr will be
|
||||
|
|
|
|||
|
|
@ -198,16 +198,31 @@ gfc_vtable_final_get (tree decl)
|
|||
#undef VTABLE_FINAL_FIELD
|
||||
|
||||
|
||||
/* Obtain the vptr of the last class reference in an expression. */
|
||||
/* Obtain the vptr of the last class reference in an expression.
|
||||
Return NULL_TREE if no class reference is found. */
|
||||
|
||||
tree
|
||||
gfc_get_vptr_from_expr (tree expr)
|
||||
{
|
||||
tree tmp = expr;
|
||||
while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|
||||
tmp = TREE_OPERAND (tmp, 0);
|
||||
tmp = gfc_class_vptr_get (tmp);
|
||||
return tmp;
|
||||
tree tmp;
|
||||
tree type;
|
||||
|
||||
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
|
||||
{
|
||||
type = TREE_TYPE (tmp);
|
||||
while (type)
|
||||
{
|
||||
if (GFC_CLASS_TYPE_P (type))
|
||||
return gfc_class_vptr_get (tmp);
|
||||
if (type != TYPE_CANONICAL (type))
|
||||
type = TYPE_CANONICAL (type);
|
||||
else
|
||||
type = NULL_TREE;
|
||||
}
|
||||
if (TREE_CODE (tmp) == VAR_DECL)
|
||||
break;
|
||||
}
|
||||
return NULL_TREE;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -594,7 +609,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
|
|||
}
|
||||
else
|
||||
{
|
||||
if (CLASS_DATA (e)->attr.codimension)
|
||||
if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
|
||||
parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
|
||||
TREE_TYPE (ctree), parmse->expr);
|
||||
gfc_add_modify (&block, ctree, parmse->expr);
|
||||
|
|
@ -1562,6 +1577,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
|
|||
c->norestrict_decl = f2;
|
||||
field = f2;
|
||||
}
|
||||
|
||||
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
|
||||
decl, field, NULL_TREE);
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Backend support for Fortran 95 basic types and derived types.
|
||||
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
|
||||
2010, 2011, 2012
|
||||
2010, 2011, 2012, 2013
|
||||
Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
||||
|
|
@ -2532,6 +2532,15 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
|
||||
ptr_mode, true);
|
||||
|
||||
/* Ensure that the CLASS language specific flag is set. */
|
||||
if (c->ts.type == BT_CLASS)
|
||||
{
|
||||
if (POINTER_TYPE_P (field_type))
|
||||
GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
|
||||
else
|
||||
GFC_CLASS_TYPE_P (field_type) = 1;
|
||||
}
|
||||
|
||||
field = gfc_add_field_to_struct (typenode,
|
||||
get_identifier (c->name),
|
||||
field_type, &chain);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2013-01-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/PR53876
|
||||
PR fortran/PR54990
|
||||
PR fortran/PR54992
|
||||
* gfortran.dg/class_array_15.f03: New test.
|
||||
|
||||
2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/42769
|
||||
|
|
|
|||
116
gcc/testsuite/gfortran.dg/class_array_15.f03
Normal file
116
gcc/testsuite/gfortran.dg/class_array_15.f03
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Tests the fixes for three bugs with the same underlying cause. All are regressions
|
||||
! that come about because class array elements end up with a different tree type
|
||||
! to the class array. In addition, the language specific flag that marks a class
|
||||
! container is not being set.
|
||||
!
|
||||
! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com>
|
||||
! PR54990 contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
||||
! The two latter bugs were reported by Andrew Benson
|
||||
! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
|
||||
!
|
||||
module G_Nodes
|
||||
type :: nc
|
||||
type(tn), pointer :: hostNode
|
||||
end type nc
|
||||
type, extends(nc) :: ncBh
|
||||
end type ncBh
|
||||
type, public, extends(ncBh) :: ncBhStd
|
||||
double precision :: massSeedData
|
||||
end type ncBhStd
|
||||
type, public :: tn
|
||||
class (ncBh), allocatable, dimension(:) :: cBh
|
||||
end type tn
|
||||
type(ncBhStd) :: defaultBhC
|
||||
contains
|
||||
subroutine Node_C_Bh_Move(targetNode)
|
||||
implicit none
|
||||
type (tn ), intent(inout) , target :: targetNode
|
||||
class(ncBh), allocatable , dimension(:) :: instancesTemporary
|
||||
! These two lines resulted in the wrong result:
|
||||
allocate(instancesTemporary(2),source=defaultBhC)
|
||||
call Move_Alloc(instancesTemporary,targetNode%cBh)
|
||||
! These two lines gave the correct result:
|
||||
!!deallocate(targetNode%cBh)
|
||||
!!allocate(targetNode%cBh(2))
|
||||
targetNode%cBh(1)%hostNode => targetNode
|
||||
targetNode%cBh(2)%hostNode => targetNode
|
||||
return
|
||||
end subroutine Node_C_Bh_Move
|
||||
function bhGet(self,instance)
|
||||
implicit none
|
||||
class (ncBh), pointer :: bhGet
|
||||
class (tn ), intent(inout), target :: self
|
||||
integer , intent(in ) :: instance
|
||||
bhGet => self%cBh(instance)
|
||||
return
|
||||
end function bhGet
|
||||
end module G_Nodes
|
||||
|
||||
call pr53876
|
||||
call pr54990
|
||||
call pr54992
|
||||
end
|
||||
|
||||
subroutine pr53876
|
||||
IMPLICIT NONE
|
||||
TYPE :: individual
|
||||
integer :: icomp ! Add an extra component to test offset
|
||||
REAL, DIMENSION(:), ALLOCATABLE :: genes
|
||||
END TYPE
|
||||
CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
|
||||
allocate (indv(2), source = [individual(1, [99,999]), &
|
||||
individual(2, [999,9999])])
|
||||
CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
|
||||
CONTAINS
|
||||
SUBROUTINE display_indv(self)
|
||||
CLASS(individual), INTENT(IN) :: self
|
||||
if (any(self%genes .ne. [999,9999]) )call abort
|
||||
END SUBROUTINE
|
||||
END
|
||||
|
||||
subroutine pr54990
|
||||
implicit none
|
||||
type :: ncBhStd
|
||||
integer :: i
|
||||
end type
|
||||
type, extends(ncBhStd) :: ncBhStde
|
||||
integer :: i2(2)
|
||||
end type
|
||||
type :: tn
|
||||
integer :: i ! Add an extra component to test offset
|
||||
class (ncBhStd), allocatable, dimension(:) :: cBh
|
||||
end type
|
||||
integer :: i
|
||||
type(tn), target :: a
|
||||
allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
|
||||
select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
|
||||
type is (ncBhStd)
|
||||
call abort
|
||||
type is (ncBhStde)
|
||||
if (q%i .ne. 198) call abort ! This tests that the component really gets the
|
||||
end select ! language specific flag denoting a class type
|
||||
end
|
||||
|
||||
subroutine pr54992 ! This test remains as the original.
|
||||
use G_Nodes
|
||||
implicit none
|
||||
type (tn), target :: b
|
||||
class(ncBh), pointer :: bh
|
||||
class(ncBh), allocatable, dimension(:) :: t
|
||||
allocate(b%cBh(1),source=defaultBhC)
|
||||
b%cBh(1)%hostNode => b
|
||||
! #1 this worked
|
||||
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
|
||||
call Node_C_Bh_Move(b)
|
||||
! #2 this worked
|
||||
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
|
||||
if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
|
||||
! #3 this did not
|
||||
bh => bhGet(b,instance=1)
|
||||
if (loc (b) .ne. loc(bh%hostNode)) call abort
|
||||
bh => bhGet(b,instance=2)
|
||||
if (loc (b) .ne. loc(bh%hostNode)) call abort
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue