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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bf5f8fb..1223dcb 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
index 0000000..b31c5bb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associated_6.f90
@@ -0,0 +1,28 @@
+! { dg-do run }\r
+!\r
+! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016\r
+!\r
+! Contributed by Richard L Lozes <richard@lozestech.com>\r
+\r
+  implicit none\r
+\r
+  type treeNode\r
+    type(treeNode), pointer :: right => null()\r
+  end type\r
+\r
+  type(treeNode) :: n\r
+\r
+  if (associated(RightOf(n))) call abort()\r
+  allocate(n%right)\r
+  if (.not.associated(RightOf(n))) call abort()\r
+  deallocate(n%right)\r
+  \r
+contains\r
+\r
+  function RightOf (theNode)\r
+    class(treeNode), pointer :: RightOf\r
+    type(treeNode), intent(in) :: theNode\r
+    RightOf => theNode%right\r
+  end function\r
+  \r
+end\r

diff --git a/gcc/testsuite/gfortran.dg/select_type_30.f03 b/gcc/testsuite/gfortran.dg/select_type_30.f03
new file mode 100644 (file)
index 0000000..f467b83
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_30.f03
@@ -0,0 +1,29 @@
+! { dg-do compile }\r
+!\r
+! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016\r
+!\r
+! Contributed by Richard L Lozes <richard@lozestech.com>\r
+\r
+  implicit none\r
+\r
+  type treeNode\r
+  end type\r
+\r
+  class(treeNode), pointer :: theNode\r
+  logical :: lstatus\r
+  \r
+  select type( theNode )\r
+  type is (treeNode)\r
+    call DestroyNode (theNode, lstatus )\r
+  class is (treeNode)\r
+    call DestroyNode (theNode, lstatus )\r
+  end select\r
+  \r
+contains\r
+\r
+  subroutine DestroyNode( theNode, lstatus )\r
+    type(treeNode), pointer :: theNode\r
+    logical, intent(out) :: lstatus\r
+  end subroutine\r
+  \r
+end \r