aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog10
-rw-r--r--gcc/fortran/match.c105
-rw-r--r--gcc/fortran/trans-intrinsic.c9
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/associated_6.f9028
-rw-r--r--gcc/testsuite/gfortran.dg/select_type_30.f0329
6 files changed, 108 insertions, 79 deletions
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 <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
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 <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
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 <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
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 <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
generated by cgit v1.1 at 2025-05-31 10:37:02 +0000