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

re PR fortran/54881 ([OOP] ICE in fold_convert_loc, at fold-const.c:2016) 

2012-11-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54881
	* match.c (select_derived_set_tmp,select_class_set_tmp): Removed and
	unified into ...
	(select_type_set_tmp): ... this one. Set POINTER argument according to
	selector.
	* trans-intrinsic.c (gfc_conv_associated): Use 'gfc_class_data_get'
	instead of 'gfc_add_data_component'.

2012-11-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54881
	* gfortran.dg/associated_6.f90: New.
	* gfortran.dg/select_type_30.f03: New.

From-SVN: r193809
This commit is contained in:
Janus Weil 2012-11-26 11:30:12 +01:00
parent 412dc84237
commit fca04db335
6 changed files with 111 additions and 82 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 @@
2012-11-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/54881
* match.c (select_derived_set_tmp,select_class_set_tmp): Removed and
unified into ...
(select_type_set_tmp): ... this one. Set POINTER argument according to
selector.
* trans-intrinsic.c (gfc_conv_associated): Use 'gfc_class_data_get'
instead of 'gfc_add_data_component'.
2012-11-25 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/30146

111
gcc/fortran/match.c
View File

@ -5207,83 +5207,12 @@ select_type_push (gfc_symbol *sel)
}
/* Set the temporary for the current derived type SELECT TYPE selector. */
static gfc_symtree *
select_derived_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
return tmp;
}
/* Set the temporary for the current class SELECT TYPE selector. */
static gfc_symtree *
select_class_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
if (select_type_stack->selector->ts.type == BT_CLASS
&& !select_type_stack->selector->attr.class_ok)
return NULL;
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
tmp->n.sym->attr.pointer = 1;
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
return tmp;
}
/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
static void
select_type_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
if (!ts)
@ -5295,15 +5224,39 @@ select_type_set_tmp (gfc_typespec *ts)
if (!gfc_type_is_extensible (ts->u.derived))
return;
/* Logic is a LOT clearer with separate functions for class and derived
type temporaries! There are not many more lines of code either. */
if (ts->type == BT_CLASS)
tmp = select_class_set_tmp (ts);
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
else
tmp = select_derived_set_tmp (ts);
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
if (tmp == NULL)
return;
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok)
{
tmp->n.sym->attr.pointer
= CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
/* Copy across the array spec to the selector. */
if ((CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
{
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
}
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */

9
gcc/fortran/trans-intrinsic.c
View File

@ -5777,8 +5777,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
if (arg1->expr->ts.type == BT_CLASS)
gfc_add_data_component (arg1->expr);
arg2 = arg1->next;
/* Check whether the expression is a scalar or not; we cannot use
@ -5800,7 +5798,10 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
&& arg1->expr->symtree->n.sym->attr.dummy)
arg1se.expr = build_fold_indirect_ref_loc (input_location,
arg1se.expr);
tmp2 = arg1se.expr;
if (arg1->expr->ts.type == BT_CLASS)
tmp2 = gfc_class_data_get (arg1se.expr);
else
tmp2 = arg1se.expr;
}
else
{
@ -5835,6 +5836,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
&& arg1->expr->symtree->n.sym->attr.dummy)
arg1se.expr = build_fold_indirect_ref_loc (input_location,
arg1se.expr);
if (arg1->expr->ts.type == BT_CLASS)
arg1se.expr = gfc_class_data_get (arg1se.expr);
arg2se.want_pointer = 1;
gfc_conv_expr (&arg2se, arg2->expr);

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2012-11-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/54881
* gfortran.dg/associated_6.f90: New.
* gfortran.dg/select_type_30.f03: New.
2012-11-26 Jakub Jelinek <jakub@redhat.com>
PR tree-optimization/54471

28
gcc/testsuite/gfortran.dg/associated_6.f90 Normal file
View File

@ -0,0 +1,28 @@
! { dg-do run }
!
! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016
!
! Contributed by Richard L Lozes <richard@lozestech.com>
implicit none
type treeNode
type(treeNode), pointer :: right => null()
end type
type(treeNode) :: n
if (associated(RightOf(n))) call abort()
allocate(n%right)
if (.not.associated(RightOf(n))) call abort()
deallocate(n%right)
contains
function RightOf (theNode)
class(treeNode), pointer :: RightOf
type(treeNode), intent(in) :: theNode
RightOf => theNode%right
end function
end

29
gcc/testsuite/gfortran.dg/select_type_30.f03 Normal file
View File

@ -0,0 +1,29 @@
! { dg-do compile }
!
! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016
!
! Contributed by Richard L Lozes <richard@lozestech.com>
implicit none
type treeNode
end type
class(treeNode), pointer :: theNode
logical :: lstatus
select type( theNode )
type is (treeNode)
call DestroyNode (theNode, lstatus )
class is (treeNode)
call DestroyNode (theNode, lstatus )
end select
contains
subroutine DestroyNode( theNode, lstatus )
type(treeNode), pointer :: theNode
logical, intent(out) :: lstatus
end subroutine
end