From: Janus Weil Date: Mon, 26 Nov 2012 10:30:12 +0000 (+0100) Subject: re PR fortran/54881 ([OOP] ICE in fold_convert_loc, at fold-const.c:2016) X-Git-Tag: upstream/12.2.0~72589 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=fca04db3357621cd2e2d09a6836966b485b34f90;p=platform%2Fupstream%2Fgcc.git re PR fortran/54881 ([OOP] ICE in fold_convert_loc, at fold-const.c:2016) 2012-11-26 Janus Weil 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 PR fortran/54881 * gfortran.dg/associated_6.f90: New. * gfortran.dg/select_type_30.f03: New. From-SVN: r193809 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bf5f8fb..1223dcb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2012-11-26 Janus Weil + + 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 PR fortran/30146 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 06585af..39da62f 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5207,103 +5207,56 @@ select_type_push (gfc_symbol *sel) } -/* Set the temporary for the current derived type SELECT TYPE selector. */ +/* Set up a temporary for the current TYPE IS / CLASS IS branch . */ -static gfc_symtree * -select_derived_set_tmp (gfc_typespec *ts) +static void +select_type_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)) + if (!ts) { - 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); + select_type_stack->tmp = NULL; + return; } - - 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; + if (!gfc_type_is_extensible (ts->u.derived)) + return; - sprintf (name, "__tmp_class_%s", ts->u.derived->name); + if (ts->type == BT_CLASS) + sprintf (name, "__tmp_class_%s", ts->u.derived->name); + else + 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 - && (CLASS_DATA (select_type_stack->selector)->attr.dimension - || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + && select_type_stack->selector->attr.class_ok) { - 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); + 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; - gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, - &tmp->n.sym->as, false); - - return tmp; -} - - -static void -select_type_set_tmp (gfc_typespec *ts) -{ - gfc_symtree *tmp; - if (!ts) - { - select_type_stack->tmp = NULL; - return; - } - - 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); - else - tmp = select_derived_set_tmp (ts); - - if (tmp == NULL) - return; + 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. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 5d9ce5c..e9eb307 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c8b4b6b..f59ff29 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-11-26 Janus Weil + + PR fortran/54881 + * gfortran.dg/associated_6.f90: New. + * gfortran.dg/select_type_30.f03: New. + 2012-11-26 Jakub Jelinek PR tree-optimization/54471 diff --git a/gcc/testsuite/gfortran.dg/associated_6.f90 b/gcc/testsuite/gfortran.dg/associated_6.f90 new file mode 100644 index 0000000..b31c5bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_6.f90 @@ -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 + + 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 diff --git a/gcc/testsuite/gfortran.dg/select_type_30.f03 b/gcc/testsuite/gfortran.dg/select_type_30.f03 new file mode 100644 index 0000000..f467b83 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_30.f03 @@ -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 + + 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