Patchwork [Fortran] PR 42051,43896: [OOP] ICE in gfc_conv_variable, at fortran/trans-expr.c:551

login
register
mail settings
Submitter Paul Richard Thomas
Date June 11, 2010, 6:02 a.m.
Message ID <AANLkTinPBlEh69AKm3dU0bhL9eTFBjXrWTdPD8kS8sUV@mail.gmail.com>
Download mbox | patch
Permalink /patch/55292/
State New
Headers show

Comments

Paul Richard Thomas - June 11, 2010, 6:02 a.m.
Dear Janus,

Please find attached a development of a fix for pr41539, which touches
the same place as the patch that you have forwarded this morning.  I
seem to recall that it fixes PR42051 as well.  I'll check at
lunchtime.

Cheers

Paul

>> b) it has been lying around for a while
>
> Indeed, I have been trying to get back to completing the incorporation
> of arrays....
>
>> c) it fixes two bugs (both of which have been reported by real-world
>> users. In fact they are duplicates.)
>> d) Paul seems to have little time for gfortran lately :(
>
> ...but, as you say, I have little time for gfortran of late.
>
>> e) I simply want to get this baby in finally :)
>>
>> [Btw, the original test case in PR 42051 still does not work, but this
>> is apparently due to some other bug, possibly related or equal to PR
>> 44064.]
>>
>> The patch has been regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>>
>> Actually, since it's Paul's patch, I guess I could just approve it
>> myself (I do indeed think it's fine). Therefore I'll just commit it
>> tomorrow on behalf of Paul if no one objects by then.
>
> I think that approach would be appropriate.
>
> Thanks
>
> Paul
>

Patch

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 157307)
+++ gcc/fortran/interface.c	(working copy)
@@ -1447,6 +1447,23 @@ 
   if (symbol_rank (formal) == actual->rank)
     return 1;
 
+  if (formal->ts.type == BT_CLASS)
+    {
+      int formal_rank;
+      formal_rank = formal->ts.u.derived->components->as
+			? formal->ts.u.derived->components->as->rank : 0;
+      if (formal_rank == actual->rank)
+   	return 1;
+      else
+	{
+	  if (where)
+	    gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
+		       formal->name, &actual->where, formal_rank,
+		       actual->rank);
+	  return 0;
+	}
+    }
+
   rank_check = where != NULL && !is_elemental && formal->as
 	       && (formal->as->type == AS_ASSUMED_SHAPE
 		   || formal->as->type == AS_DEFERRED)
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 157307)
+++ gcc/fortran/match.c	(working copy)
@@ -2394,7 +2394,7 @@ 
 gfc_match_allocate (void)
 {
   gfc_alloc *head, *tail;
-  gfc_expr *stat, *errmsg, *tmp, *source;
+  gfc_expr *stat, *errmsg, *tmp, *source, *e;
   gfc_typespec ts;
   gfc_symbol *sym;
   match m;
@@ -2455,6 +2455,18 @@ 
 	  goto cleanup;
 	}
 
+      /* A class object's array reference changes the expression type to that
+	 of the declared type. Change it back to the class type for allocate
+	 expressions.  */
+      e = tail->expr;
+      if (e->symtree->n.sym->ts.type == BT_CLASS
+	    && e->ts.type == BT_DERIVED
+	    && e->ref && e->ref->type == REF_COMPONENT
+	    && strcmp (e->ref->u.c.component->name, "$data") == 0
+	    && (!e->ref->next
+		   || (e->ref->next->type == REF_ARRAY && !e->ref->next->next)))
+	e->ts = e->symtree->n.sym->ts;
+
       /* The ALLOCATE statement had an optional typespec.  Check the
 	 constraints.  */
       if (ts.type != BT_UNKNOWN)
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 157307)
+++ gcc/fortran/primary.c	(working copy)
@@ -1738,7 +1738,7 @@ 
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_ref *substring, *tail;
-  gfc_component *component;
+  gfc_component *component = NULL;
   gfc_symbol *sym = primary->symtree->n.sym;
   match m;
   bool unknown;
@@ -1754,14 +1754,30 @@ 
       || (sym->ts.type == BT_CLASS
 	  && sym->ts.u.derived->components->attr.dimension))
     {
+      if (sym->ts.type == BT_CLASS && gfc_peek_ascii_char () == '(')
+	{
+	  component = gfc_find_component (sym->ts.u.derived, "$data",
+					  true, true);
+	  tail = extend_ref (primary, tail);
+	  tail->type = REF_COMPONENT;
+	  tail->u.c.component = component;
+	  tail->u.c.sym = sym;
+	}
+
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
 	 variables.  We'll leave the decision till resolve time.  */
       tail = extend_ref (primary, tail);
       tail->type = REF_ARRAY;
 
-      m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
-			       equiv_flag);
+      if (sym->ts.type == BT_CLASS)
+	m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL :
+				 sym->ts.u.derived->components->as,
+				 equiv_flag);
+      else
+	m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL :
+				 sym->as, equiv_flag);
+
       if (m != MATCH_YES)
 	return m;
 
@@ -1777,7 +1793,10 @@ 
 	}
     }
 
-  primary->ts = sym->ts;
+  if (sym->ts.type == BT_CLASS && component)
+    primary->ts = component->ts;
+  else
+    primary->ts = sym->ts;
 
   if (equiv_flag)
     return MATCH_YES;
@@ -2757,7 +2776,8 @@ 
       /* If the symbol has a dimension attribute, the expression is a
 	 variable.  */
 
-      if (sym->attr.dimension)
+      if (sym->attr.dimension
+	    || (sym->ts.type == BT_CLASS && sym->ts.u.derived->components->attr.dimension))
 	{
 	  if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
 			      sym->name, NULL) == FAILURE)
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 157307)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2596,14 +2596,28 @@ 
 
   /* Set the vptr.  */
   cmp = gfc_find_component (declared, "$vptr", true, true);
-  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
-		       var, cmp->backend_decl, NULL_TREE);
 
-  /* Remember the vtab corresponds to the derived type
-    not to the class declared type.  */
-  vtab = gfc_find_derived_vtab (e->ts.u.derived);
-  gcc_assert (vtab);
-  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  /* Remember the vtab corresponds to the derived type not to the
+     class declared type, unless this is an array reference to a
+     class object.  */
+  if (((e->expr_type == EXPR_VARIABLE) || (e->expr_type == EXPR_FUNCTION))
+	 && e->symtree->n.sym->ts.type == BT_CLASS)
+    {
+      tmp = gfc_get_symbol_decl (e->symtree->n.sym);
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			   tmp, cmp->backend_decl, NULL_TREE);
+      tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			 tmp, cmp->backend_decl, NULL_TREE);    
+    }
+  else
+    {
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			   var, cmp->backend_decl, NULL_TREE);
+      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      gcc_assert (vtab);
+      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+    }
+
   gfc_add_modify (&parmse->pre, ctree,
 		  fold_convert (TREE_TYPE (ctree), tmp));
 
@@ -2620,7 +2634,7 @@ 
     }
   else
     {
-      gfc_conv_expr (parmse, e);
+      gfc_conv_expr_descriptor (parmse, e, ss);
       gfc_add_modify (&parmse->pre, ctree, parmse->expr);
     }