[Patch, Fortran] PR41629: [OOP] gimplification error on valid code

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

Hi all,

the attached patch fixes an issue with the current OOP implementation,
which looks harmless at first but turned out to be rather tricky. The
problem is that we call encapsulate_class_symbol too early. This
routine constructs a CLASS container type, which contains the declared
type as 'data' component and an integer 'vindex', and needs to know
all the attributes of the symbol to do that.

Currently we call it already when parsing. This is ok for CLASS-valued
components, but for plain CLASS variables one can have cases like
this:

 class(t1) :: x
 pointer :: x

Here we already construct the CLASS container after reading the first
line, and so the pointer attribute comes too late and mixes things up,
which ultimately leads to a gimplification error in the test case.

The only clean solution I can see is to construct the CLASS container
at resolution stage, where all attributes are known. However, this is
a bit tricky, as all CLASS variables then change their type at
resolution stage, and we have to take special care of this.

Example: gfc_type_compatible is called both at parsing and resolution
stage, and so I had to modify it a bit, so that it can work in both
situations (at first a class variable has its declared type, later it
is transformed into a class container type).

Another example: All component references of CLASS variables have the
wrong parent symbol (i.e. the type itself instead of the class
container), and this needs to be fixed at resolution stage (in
gfc_variable_attr).

I think I have managed to sort out all regressions by now (which was
not quite easy). I'm just running another regtest to make sure.

Ok for trunk? (I will add a ChangeLog and the test case from the PR)

Cheers,
Janus

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 152555)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -4579,13 +4579,15 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typesp
   if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
       && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
     {
-      if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived);
-      else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
-	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
-					 ts2->u.derived->components->ts.u.derived);
-      else if (ts2->type != BT_CLASS)
+      if (ts1->type == BT_CLASS)
+	{
+	  if (ts1->u.derived->attr.is_class)
+	    ts1 = &ts1->u.derived->components->ts;
+	  if (ts2->u.derived->attr.is_class)
+	    ts2 = &ts2->u.derived->components->ts;
+	  return gfc_type_is_extension_of (ts1->u.derived, ts2->u.derived);
+	}
+      else if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
 	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
       else
 	return 0;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 152555)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -1030,14 +1030,22 @@ verify_c_interop_param (gfc_symbol *sym)
    declared type as '$data' component, plus an integer component '$vindex'
    which determines the dynamic type.  */
 
-static gfc_try
+gfc_try
 encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-			  gfc_array_spec **as)
+			  gfc_array_spec **as, locus *where)
 {
   char name[GFC_MAX_SYMBOL_LEN + 5];
   gfc_symbol *fclass;
   gfc_component *c;
 
+  /* F03:C502.  */
+  if (!gfc_type_is_extensible (ts->u.derived))
+    {
+      gfc_error ("Type '%s' of CLASS variable at %L is not extensible",
+		 ts->u.derived->name, where);
+      return FAILURE;
+    }
+
   /* Determine the name of the encapsulating type.  */
   if ((*as) && (*as)->rank && attr->allocatable)
     sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
@@ -1170,9 +1178,6 @@ build_sym (const char *name, gfc_charlen *cl,
 
   sym->attr.implied_index = 0;
 
-  if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
-
   return SUCCESS;
 }
 
@@ -1545,8 +1550,20 @@ build_struct (const char *name, gfc_charlen *cl, g
     }
 
   if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+    {
+      /* C437.  */
+      if (!(c->attr.pointer || c->attr.allocatable))
+	{
+	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+		     "or pointer", c->name, &c->loc);
+	  return FAILURE;
+	}
 
+      if (encapsulate_class_symbol (&c->ts, &c->attr, &c->as, &c->loc)
+	  == FAILURE)
+	return FAILURE;
+    }
+
   /* Check array components.  */
   if (!c->attr.dimension)
     return SUCCESS;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 152555)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -2233,6 +2233,8 @@ gfc_finalizer;
 /* decl.c */
 bool gfc_in_match_data (void);
 match gfc_match_char_spec (gfc_typespec *);
+gfc_try encapsulate_class_symbol (gfc_typespec *, symbol_attribute *,
+				  gfc_array_spec **, locus *);
 
 /* scanner.c */
 void gfc_scanner_done_1 (void);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 152555)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -7558,11 +7558,10 @@ resolve_ordinary_assign (gfc_code *code, gfc_names
 static void
 resolve_class_assign (gfc_code *code)
 {
-  gfc_code *assign_code = gfc_get_code ();
-
   if (code->expr2->ts.type != BT_CLASS)
     {
       /* Insert an additional assignment which sets the vindex.  */
+      gfc_code *assign_code = gfc_get_code ();
       assign_code->next = code->next;
       code->next = assign_code;
       assign_code->op = EXEC_ASSIGN;
@@ -8551,7 +8550,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
      associated by the presence of another class I symbol in the same
      namespace.  14.6.1.3 of the standard and the discussion on
      comp.lang.fortran.  */
-  if (sym->ns != sym->ts.u.derived->ns
+  if (sym->ns != sym->ts.u.derived->ns && sym->ns->proc_name
       && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
     {
       gfc_symbol *s;
@@ -8587,27 +8586,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
       return FAILURE;
     }
 
-  if (sym->ts.type == BT_CLASS)
-    {
-      /* C502.  */
-      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
-	{
-	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
-		     sym->ts.u.derived->name, sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-
-      /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
-	      || sym->ts.u.derived->components->attr.allocatable
-	      || sym->ts.u.derived->components->attr.pointer))
-	{
-	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
-		     "or pointer", sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-    }
-
   /* Assign default initializer.  */
   if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
       && (!no_init_flag || sym->attr.intent == INTENT_OUT))
@@ -9678,6 +9656,9 @@ error:
 }
 
 
+static void resolve_symbol (gfc_symbol *sym);
+
+
 /* Resolve the type-bound procedures for a derived type.  */
 
 static void
@@ -9783,6 +9764,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
       /* Now check that the argument-type matches.  */
       gcc_assert (me_arg);
+      resolve_symbol (me_arg);
       if (me_arg->ts.type != BT_CLASS)
 	{
 	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
@@ -9957,9 +9939,6 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol*
 }
 
 
-static void resolve_symbol (gfc_symbol *sym);
-
-
 /* Resolve the components of a derived type.  */
 
 static gfc_try
@@ -10112,6 +10091,7 @@ resolve_fl_derived (gfc_symbol *sym)
 
 	  /* Now check that the argument-type matches.  */
 	  gcc_assert (me_arg);
+	  resolve_symbol (me_arg);
 	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
 	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
 	      || (me_arg->ts.type == BT_CLASS
@@ -10222,16 +10202,6 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
-      /* C437.  */
-      if (c->ts.type == BT_CLASS
-	  && !(c->ts.u.derived->components->attr.pointer
-	       || c->ts.u.derived->components->attr.allocatable))
-	{
-	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
-		     "or pointer", c->name, &c->loc);
-	  return FAILURE;
-	}
-
       /* Ensure that all the derived type components are put on the
 	 derived type list; even in formal namespaces, where derived type
 	 pointer components might not have been declared.  */
@@ -10834,6 +10804,21 @@ resolve_symbol (gfc_symbol *sym)
       break;
     }
 
+  if (sym->ts.type == BT_CLASS && !sym->ts.u.derived->attr.is_class)
+    {
+      /* F03:C509.  */
+      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+	{
+	  gfc_error ("CLASS variable at %L must be dummy, allocatable or "
+		     "pointer", &sym->declared_at);
+	  return;
+	}
+
+      if (encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as,
+				    &sym->declared_at) == FAILURE)
+	return;
+    }
+
   /* Resolve array specifier. Check as well some constraints
      on COMMON blocks.  */
 
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 152555)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -2538,12 +2538,8 @@ gfc_match_allocate (void)
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 		|| tail->expr->ref->type == REF_ARRAY));
-      if (sym && sym->ts.type == BT_CLASS)
-	b2 = !(sym->ts.u.derived->components->attr.allocatable
-	       || sym->ts.u.derived->components->attr.pointer);
-      else
-	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
-		      || sym->attr.proc_pointer);
+      b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		    || sym->attr.proc_pointer);
       b3 = sym && sym->ns && sym->ns->proc_name
 	   && (sym->ns->proc_name->attr.allocatable
 		|| sym->ns->proc_name->attr.pointer
@@ -2819,12 +2815,8 @@ gfc_match_deallocate (void)
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 	       || tail->expr->ref->type == REF_ARRAY));
-      if (sym && sym->ts.type == BT_CLASS)
-	b2 = !(sym->ts.u.derived->components->attr.allocatable
-	       || sym->ts.u.derived->components->attr.pointer);
-      else
-	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
-		      || sym->attr.proc_pointer);
+      b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		    || sym->attr.proc_pointer);
       if (b1 && b2)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
@@ -4066,7 +4058,7 @@ gfc_match_select_type (void)
     {
       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
 		 "use associate-name=>");
-      return MATCH_ERROR;
+      goto error;
     }
 
   /* Check for F03:C813.  */
@@ -4074,7 +4066,7 @@ gfc_match_select_type (void)
     {
       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
 		 "at %C");
-      return MATCH_ERROR;
+      goto error;
     }
 
   new_st.op = EXEC_SELECT_TYPE;
@@ -4085,6 +4077,10 @@ gfc_match_select_type (void)
   type_selector = expr1->symtree->n.sym;
 
   return MATCH_YES;
+
+error:
+  gfc_current_ns = gfc_current_ns->parent;
+  return MATCH_ERROR;
 }
 
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 152555)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -1733,9 +1733,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
       || (sym->attr.dimension && !sym->attr.proc_pointer
 	  && !gfc_is_proc_ptr_comp (primary, NULL)
 	  && !(gfc_matching_procptr_assignment
-	       && sym->attr.flavor == FL_PROCEDURE))
-      || (sym->ts.type == BT_CLASS
-	  && sym->ts.u.derived->components->attr.dimension))
+	       && sym->attr.flavor == FL_PROCEDURE)))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
@@ -1961,6 +1959,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   gfc_ref *ref;
   gfc_symbol *sym;
   gfc_component *comp;
+  gfc_typespec tmp_ts;
 
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
@@ -1986,9 +1985,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   if (pointer || attr.proc_pointer)
     target = 1;
 
-  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
+  if (ts != NULL && (expr->ts.type == BT_UNKNOWN || expr->ts.type == BT_CLASS))
     *ts = sym->ts;
 
+  tmp_ts = sym->ts;
+
   for (; ref; ref = ref->next)
     switch (ref->type)
       {
@@ -2018,6 +2019,10 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
       case REF_COMPONENT:
 	comp = ref->u.c.component;
 	attr = comp->attr;
+	/* CLASS variables changes their type at resolution stage.
+	   Update the reference.  */
+	if (tmp_ts.type == BT_CLASS)
+	  ref->u.c.sym = tmp_ts.u.derived;
 	if (ts != NULL)
 	  {
 	    *ts = comp->ts;