Re: [Fortran-dev] Merged trunk into branch

[Janus Weil <janus at gcc dot gnu dot org>]

Dominique,

> Tested [branch fortran-dev revision 152269] on i686-apple-darwin9.
> It passed my tests, NIST ones and regtested fine. The only glitches
> I saw have already reported to Janus, except the ICE is now
>
> [ibook-dhum] f90/bug% gfcd poly_list.f90
> poly_list.f90: In function 'MAIN__':
> poly_list.f90:136:0: internal compiler error: in fold_convert_loc, at fold-const.c:2667
>
> instead of previously
>
> [ibook-dhum] f90/bug% gfcd poly_list.f90
> f951: internal compiler error: in resolve_class_assign, at fortran/resolve.c:7267
>
> Thanks for the great work.

your test case compiles with the attached patch, and it should even
run correctly (at least the previous version that you sent me). Can
you confirm this?

I would like to commit this patch to the branch, before we merge to
trunk. Would this be ok? Or how should we proceed?

Cheers,
Janus

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 152323)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -4851,7 +4851,8 @@ check_typebound_baseobject (gfc_expr* e)
     return FAILURE;
 
   gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
-  if (base->ts.u.derived->attr.abstract)
+
+  if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
     {
       gfc_error ("Base object for type-bound procedure call at %L is of"
 		 " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
@@ -7298,30 +7299,34 @@ resolve_class_assign (gfc_code *code)
 {
   gfc_code *assign_code = gfc_get_code ();
 
-  /* Insert an additional assignment which sets the vindex.  */
-  assign_code->next = code->next;
-  code->next = assign_code;
-  assign_code->op = EXEC_ASSIGN;
-  assign_code->expr1 = gfc_copy_expr (code->expr1);
-  gfc_add_component_ref (assign_code->expr1, "$vindex");
-  if (code->expr2->ts.type == BT_DERIVED)
-    /* vindex is constant, determined at compile time.  */
-    assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
-  else if (code->expr2->ts.type == BT_CLASS)
+  if (code->expr2->ts.type != BT_CLASS)
     {
-      /* vindex must be determined at run time.  */
-      assign_code->expr2 = gfc_copy_expr (code->expr2);
-      gfc_add_component_ref (assign_code->expr2, "$vindex");
+      /* Insert an additional assignment which sets the vindex.  */
+      assign_code->next = code->next;
+      code->next = assign_code;
+      assign_code->op = EXEC_ASSIGN;
+      assign_code->expr1 = gfc_copy_expr (code->expr1);
+      gfc_add_component_ref (assign_code->expr1, "$vindex");
+      if (code->expr2->ts.type == BT_DERIVED)
+	/* vindex is constant, determined at compile time.  */
+	assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
+      else if (code->expr2->ts.type == BT_CLASS)
+	{
+	  /* vindex must be determined at run time.  */
+	  assign_code->expr2 = gfc_copy_expr (code->expr2);
+	  gfc_add_component_ref (assign_code->expr2, "$vindex");
+	}
+      else if (code->expr2->expr_type == EXPR_NULL)
+	assign_code->expr2 = gfc_int_expr (0);
+      else
+	gcc_unreachable ();
     }
-  else if (code->expr2->expr_type == EXPR_NULL)
-    assign_code->expr2 = gfc_int_expr (0);
-  else
-    gcc_unreachable ();
 
   /* Modify the actual pointer assignment.  */
-  gfc_add_component_ref (code->expr1, "$data");
   if (code->expr2->ts.type == BT_CLASS)
-    gfc_add_component_ref (code->expr2, "$data");
+    code->op = EXEC_ASSIGN;
+  else
+    gfc_add_component_ref (code->expr1, "$data");
 }
 
 
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(Revision 152323)
+++ gcc/fortran/trans-intrinsic.c	(Arbeitskopie)
@@ -4608,6 +4608,8 @@ 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_component_ref (arg1->expr, "$data");
   arg2 = arg1->next;
   ss1 = gfc_walk_expr (arg1->expr);