This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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

Dear Janus,

> That said, I will try to rise to your challenge tonight!

Please find attached my attempt(s) to deal with PR's41629, 41587 &
41618.  In fact, there are two versions; the first explicitly checks
use associated class objects, whereas the second assumes that this has
been done in the module.

I prefer the second version as it is simpler.

I cannot do anything with this for some days, so please chose between
yours (which is OK BTW!) or mine and commit with appropriate testcase
(I suggest to expand class_4.f03 to include the lot.).

Cheers

Paul

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 152620)
+++ gcc/fortran/decl.c	(working copy)
@@ -1172,7 +1172,12 @@
   sym->attr.implied_index = 0;
 
   if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    {
+      sym->attr.class_ok = (sym->attr.dummy
+			      || sym->attr.pointer
+			      || sym->attr.allocatable) ? 1 : 0;
+      encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    }
 
   return SUCCESS;
 }
@@ -1463,6 +1468,7 @@
 	      gfc_array_spec **as)
 {
   gfc_component *c;
+  gfc_try t = SUCCESS;
 
   /* F03:C438/C439. If the current symbol is of the same derived type that we're
      constructing, it must have the pointer attribute.  */
@@ -1545,12 +1551,9 @@
 	}
     }
 
-  if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
   /* Check array components.  */
   if (!c->attr.dimension)
-    return SUCCESS;
+    goto scalar;
 
   if (c->attr.pointer)
     {
@@ -1558,7 +1561,7 @@
 	{
 	  gfc_error ("Pointer array component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else if (c->attr.allocatable)
@@ -1567,7 +1570,7 @@
 	{
 	  gfc_error ("Allocatable component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else
@@ -1576,11 +1579,15 @@
 	{
 	  gfc_error ("Array component of structure at %C must have an "
 		     "explicit shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
 
-  return SUCCESS;
+scalar:
+  if (c->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+  return t;
 }
 
 
@@ -5685,14 +5692,32 @@
 	}
     }
 
-  /* Update symbol table.  DIMENSION attribute is set
-     in gfc_set_array_spec().  */
-  if (current_attr.dimension == 0
-      && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+  /* Update symbol table.  DIMENSION attribute is set in
+     gfc_set_array_spec().  For CLASS variables, this must be applied
+     to the first component, or '$data' field.  */
+  if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
     {
-      m = MATCH_ERROR;
-      goto cleanup;
+      gfc_component *comp;
+      comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+      if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
+					 &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      sym->attr.class_ok = (sym->attr.class_ok
+			      || current_attr.allocatable
+			      || current_attr.pointer);
     }
+  else
+    {
+      if (current_attr.dimension == 0
+	    && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
 
   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
     {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 152620)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -672,6 +672,7 @@
   unsigned is_bind_c:1;		/* say if is bound to C.  */
   unsigned extension:1;		/* extends a derived type.  */
   unsigned is_class:1;		/* is a CLASS container.  */
+  unsigned class_ok:1;		/* is a CLASS object with correct attributes.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 152620)
+++ gcc/fortran/module.c	(working copy)
@@ -3504,6 +3504,21 @@
 }
 
 
+/* Check CLASS objects for being dummy, allocatable or pointer.  */
+static void
+check_class_object (gfc_symbol *sym)
+{
+  gfc_component *comp;
+  sym->attr.class_ok = sym->attr.dummy;
+
+  if (sym->attr.class_ok)
+    return;
+
+  comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+  sym->attr.class_ok = comp->attr.pointer || comp->attr.allocatable;
+}
+
+
 /* Unlike most other routines, the address of the symbol node is already
    fixed on input and the name/module has already been filled in.  */
 
@@ -3521,6 +3536,9 @@
     mio_namespace_ref (&sym->formal_ns);
   else
     {
+      if (sym->ts.type == BT_CLASS)
+	check_class_object (sym);
+
       mio_namespace_ref (&sym->formal_ns);
       if (sym->formal_ns)
 	{
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 152620)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8612,9 +8612,7 @@
 	}
 
       /* 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))
+      if (!sym->attr.class_ok)
 	{
 	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
 		     "or pointer", sym->name, &sym->declared_at);

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 152620)
+++ gcc/fortran/decl.c	(working copy)
@@ -1172,7 +1172,12 @@
   sym->attr.implied_index = 0;
 
   if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    {
+      sym->attr.class_ok = (sym->attr.dummy
+			      || sym->attr.pointer
+			      || sym->attr.allocatable) ? 1 : 0;
+      encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    }
 
   return SUCCESS;
 }
@@ -1463,6 +1468,7 @@
 	      gfc_array_spec **as)
 {
   gfc_component *c;
+  gfc_try t = SUCCESS;
 
   /* F03:C438/C439. If the current symbol is of the same derived type that we're
      constructing, it must have the pointer attribute.  */
@@ -1545,12 +1551,9 @@
 	}
     }
 
-  if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
   /* Check array components.  */
   if (!c->attr.dimension)
-    return SUCCESS;
+    goto scalar;
 
   if (c->attr.pointer)
     {
@@ -1558,7 +1561,7 @@
 	{
 	  gfc_error ("Pointer array component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else if (c->attr.allocatable)
@@ -1567,7 +1570,7 @@
 	{
 	  gfc_error ("Allocatable component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else
@@ -1576,11 +1579,15 @@
 	{
 	  gfc_error ("Array component of structure at %C must have an "
 		     "explicit shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
 
-  return SUCCESS;
+scalar:
+  if (c->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+  return t;
 }
 
 
@@ -5685,14 +5692,32 @@
 	}
     }
 
-  /* Update symbol table.  DIMENSION attribute is set
-     in gfc_set_array_spec().  */
-  if (current_attr.dimension == 0
-      && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+  /* Update symbol table.  DIMENSION attribute is set in
+     gfc_set_array_spec().  For CLASS variables, this must be applied
+     to the first component, or '$data' field.  */
+  if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
     {
-      m = MATCH_ERROR;
-      goto cleanup;
+      gfc_component *comp;
+      comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+      if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
+					 &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      sym->attr.class_ok = (sym->attr.class_ok
+			      || current_attr.allocatable
+			      || current_attr.pointer);
     }
+  else
+    {
+      if (current_attr.dimension == 0
+	    && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
 
   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
     {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 152620)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -672,6 +672,7 @@
   unsigned is_bind_c:1;		/* say if is bound to C.  */
   unsigned extension:1;		/* extends a derived type.  */
   unsigned is_class:1;		/* is a CLASS container.  */
+  unsigned class_ok:1;		/* is a CLASS object with correct attributes.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 152620)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8612,9 +8612,8 @@
 	}
 
       /* 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))
+      /* Assume that use associated symbols were checked in the module ns.  */ 
+      if (!sym->attr.class_ok && !sym->attr.use_assoc)
 	{
 	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
 		     "or pointer", sym->name, &sym->declared_at);
Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]