OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45586 (ICE non-trivial conversion at assignment) 

PR fortran/45586
	* gfortran.h (struct gfc_component): Add norestrict_decl member.
	* trans.h (struct lang_type): Add nonrestricted_type member.
	* trans-expr.c (gfc_conv_component_ref): Search fields with correct
	parent type.
	* trans-types.c (mirror_fields, gfc_nonrestricted_type): New.
	(gfc_sym_type): Use it.

testsuite/
	PR fortran/45586
	* gfortran.dg/lto/pr45586_0.f90: New test.
	* gfortran.dg/typebound_proc_20.f90: Ditto.
	* gfortran.dg/typebound_proc_21.f90: Ditto.

From-SVN: r170284
This commit is contained in:
Michael Matz 2011-02-18 19:52:16 +00:00 committed by Michael Matz
parent 430aa86819
commit b3c1b8a1d6
8 changed files with 327 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
2011-02-18 Michael Matz <matz@suse.de>
PR fortran/45586
* gfortran.h (struct gfc_component): Add norestrict_decl member.
* trans.h (struct lang_type): Add nonrestricted_type member.
* trans-expr.c (gfc_conv_component_ref): Search fields with correct
parent type.
* trans-types.c (mirror_fields, gfc_nonrestricted_type): New.
(gfc_sym_type): Use it.
2011-02-18 Janus Weil <janus@gcc.gnu.org>
PR fortran/47768

4
gcc/fortran/gfortran.h
View File

@ -934,6 +934,10 @@ typedef struct gfc_component
gfc_array_spec *as;
tree backend_decl;
/* Used to cache a FIELD_DECL matching this same component
but applied to a different backend containing type that was
generated by gfc_nonrestricted_type. */
tree norestrict_decl;
locus loc;
struct gfc_expr *initializer;
struct gfc_component *next;

20
gcc/fortran/trans-expr.c
View File

@ -504,6 +504,26 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
field = c->backend_decl;
gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
/* Components can correspond to fields of different containing
types, as components are created without context, whereas
a concrete use of a component has the type of decl as context.
So, if the type doesn't match, we search the corresponding
FIELD_DECL in the parent type. To not waste too much time
we cache this result in norestrict_decl. */
if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
{
tree f2 = c->norestrict_decl;
if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
if (TREE_CODE (f2) == FIELD_DECL
&& DECL_NAME (f2) == DECL_NAME (field))
break;
gcc_assert (f2);
c->norestrict_decl = f2;
field = f2;
}
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);

168
gcc/fortran/trans-types.c
View File

@ -1746,6 +1746,171 @@ gfc_build_pointer_type (gfc_symbol * sym, tree type)
else
return build_pointer_type (type);
}
static tree gfc_nonrestricted_type (tree t);
/* Given two record or union type nodes TO and FROM, ensure
that all fields in FROM have a corresponding field in TO,
their type being nonrestrict variants. This accepts a TO
node that already has a prefix of the fields in FROM. */
static void
mirror_fields (tree to, tree from)
{
tree fto, ffrom;
tree *chain;
/* Forward to the end of TOs fields. */
fto = TYPE_FIELDS (to);
ffrom = TYPE_FIELDS (from);
chain = &TYPE_FIELDS (to);
while (fto)
{
gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
chain = &DECL_CHAIN (fto);
fto = DECL_CHAIN (fto);
ffrom = DECL_CHAIN (ffrom);
}
/* Now add all fields remaining in FROM (starting with ffrom). */
for (; ffrom; ffrom = DECL_CHAIN (ffrom))
{
tree newfield = copy_node (ffrom);
DECL_CONTEXT (newfield) = to;
/* The store to DECL_CHAIN might seem redundant with the
stores to *chain, but not clearing it here would mean
leaving a chain into the old fields. If ever
our called functions would look at them confusion
will arise. */
DECL_CHAIN (newfield) = NULL_TREE;
*chain = newfield;
chain = &DECL_CHAIN (newfield);
if (TREE_CODE (ffrom) == FIELD_DECL)
{
tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
TREE_TYPE (newfield) = elemtype;
}
}
*chain = NULL_TREE;
}
/* Given a type T, returns a different type of the same structure,
except that all types it refers to (recursively) are always
non-restrict qualified types. */
static tree
gfc_nonrestricted_type (tree t)
{
tree ret = t;
/* If the type isn't layed out yet, don't copy it. If something
needs it for real it should wait until the type got finished. */
if (!TYPE_SIZE (t))
return t;
if (!TYPE_LANG_SPECIFIC (t))
TYPE_LANG_SPECIFIC (t)
= ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
/* If we're dealing with this very node already further up
the call chain (recursion via pointers and struct members)
we haven't yet determined if we really need a new type node.
Assume we don't, return T itself. */
if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
return t;
/* If we have calculated this all already, just return it. */
if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
/* Mark this type. */
TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
switch (TREE_CODE (t))
{
default:
break;
case POINTER_TYPE:
case REFERENCE_TYPE:
{
tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
if (totype == TREE_TYPE (t))
ret = t;
else if (TREE_CODE (t) == POINTER_TYPE)
ret = build_pointer_type (totype);
else
ret = build_reference_type (totype);
ret = build_qualified_type (ret,
TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
}
break;
case ARRAY_TYPE:
{
tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
if (elemtype == TREE_TYPE (t))
ret = t;
else
{
ret = build_variant_type_copy (t);
TREE_TYPE (ret) = elemtype;
if (TYPE_LANG_SPECIFIC (t)
&& GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
{
tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
dataptr_type = gfc_nonrestricted_type (dataptr_type);
if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
{
TYPE_LANG_SPECIFIC (ret)
= ggc_alloc_cleared_lang_type (sizeof (struct
lang_type));
*TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
}
}
}
}
break;
case RECORD_TYPE:
case UNION_TYPE:
case QUAL_UNION_TYPE:
{
tree field;
/* First determine if we need a new type at all.
Careful, the two calls to gfc_nonrestricted_type per field
might return different values. That happens exactly when
one of the fields reaches back to this very record type
(via pointers). The first calls will assume that we don't
need to copy T (see the error_mark_node marking). If there
are any reasons for copying T apart from having to copy T,
we'll indeed copy it, and the second calls to
gfc_nonrestricted_type will use that new node if they
reach back to T. */
for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
if (TREE_CODE (field) == FIELD_DECL)
{
tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
if (elemtype != TREE_TYPE (field))
break;
}
if (!field)
break;
ret = build_variant_type_copy (t);
TYPE_FIELDS (ret) = NULL_TREE;
/* Here we make sure that as soon as we know we have to copy
T, that also fields reaching back to us will use the new
copy. It's okay if that copy still contains the old fields,
we won't look at them. */
TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
mirror_fields (ret, t);
}
break;
}
TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
return ret;
}
/* Return the type for a symbol. Special handling is required for character
types to get the correct level of indirection.
@ -1796,6 +1961,9 @@ gfc_sym_type (gfc_symbol * sym)
restricted = !sym->attr.target && !sym->attr.pointer
&& !sym->attr.proc_pointer && !sym->attr.cray_pointee;
if (!restricted)
type = gfc_nonrestricted_type (type);
if (sym->attr.dimension)
{
if (gfc_is_nodesc_array (sym))

1
gcc/fortran/trans.h
View File

@ -700,6 +700,7 @@ struct GTY((variable_size)) lang_type {
tree dataptr_type;
tree span;
tree base_decl[2];
tree nonrestricted_type;
};
struct GTY((variable_size)) lang_decl {

29
gcc/testsuite/gfortran.dg/lto/pr45586_0.f90 Normal file
View File

@ -0,0 +1,29 @@
! { dg-lto-do link }
MODULE M1
INTEGER, PARAMETER :: dp=8
TYPE realspace_grid_type
REAL(KIND=dp), DIMENSION ( :, :, : ), ALLOCATABLE :: r
END TYPE realspace_grid_type
END MODULE
MODULE M2
USE m1
CONTAINS
SUBROUTINE S1(x)
TYPE(realspace_grid_type), POINTER :: x
REAL(dp), DIMENSION(:, :, :), POINTER :: y
y=>x%r
y=0
END SUBROUTINE
END MODULE
USE M2
TYPE(realspace_grid_type), POINTER :: x
ALLOCATE(x)
ALLOCATE(x%r(10,10,10))
CALL S1(x)
write(6,*) x%r
END

68
gcc/testsuite/gfortran.dg/typebound_proc_20.f90 Normal file
View File

@ -0,0 +1,68 @@
! { dg-do compile }
! TODO: make runtime testcase once bug is fixed
!
! PR fortran/47455
!
! Based on an example by Thomas Henlich
!
module class_t
type :: tx
integer, dimension(:), allocatable :: i
end type tx
type :: t
type(tx), pointer :: x
type(tx) :: y
contains
procedure :: calc
procedure :: find_x
procedure :: find_y
end type t
contains
subroutine calc(this)
class(t), target :: this
type(tx), target :: that
that%i = [1,2]
this%x => this%find_x(that, .true.)
if (associated (this%x)) call abort()
this%x => this%find_x(that, .false.)
if(any (this%x%i /= [5, 7])) call abort()
if (.not.associated (this%x,that)) call abort()
allocate(this%x)
if (associated (this%x,that)) call abort()
if (allocated(this%x%i)) call abort()
this%x = this%find_x(that, .false.)
that%i = [3,4]
if(any (this%x%i /= [5, 7])) call abort() ! FAILS
if (allocated (this%y%i)) call abort()
this%y = this%find_y() ! FAILS
if (.not.allocated (this%y%i)) call abort()
if(any (this%y%i /= [6, 8])) call abort()
end subroutine calc
function find_x(this, that, l_null)
class(t), intent(in) :: this
type(tx), target :: that
type(tx), pointer :: find_x
logical :: l_null
if (l_null) then
find_x => null()
else
find_x => that
that%i = [5, 7]
end if
end function find_x
function find_y(this) result(res)
class(t), intent(in) :: this
type(tx), allocatable :: res
allocate(res)
res%i = [6, 8]
end function find_y
end module class_t
use class_t
type(t) :: x
call x%calc()
end
! { dg-final { cleanup-modules "class_t" } }

27
gcc/testsuite/gfortran.dg/typebound_proc_21.f90 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do compile }
!
! PR fortran/47455
!
module class_t
type :: tx
integer, dimension(:), allocatable :: i
end type tx
type :: t
type(tx), pointer :: x
contains
procedure :: calc
procedure :: find_x
end type t
contains
subroutine calc(this)
class(t), target :: this
this%x = this%find_x()
end subroutine calc
function find_x(this)
class(t), intent(in) :: this
type(tx), pointer :: find_x
find_x => null()
end function find_x
end module class_t
! { dg-final { cleanup-modules "class_t" } }