re PR fortran/40940 ([F03] CLASS statement)

2009-08-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40940
	* decl.c (gfc_match_type_spec): Match CLASS statement and warn about
	missing polymorphism.
	* gfortran.h (gfc_typespec): Add field 'is_class'.
	* misc.c (gfc_clear_ts): Initialize 'is_class' to zero.
	* resolve.c (type_is_extensible): New function to check if a derived
	type is extensible.
	(resolve_fl_variable_derived): Add error checks for CLASS variables.
	(resolve_typebound_procedure): Disallow non-polymorphic passed-object
	dummy arguments, turning warning into error.
	(resolve_fl_derived): Use 'type_is_extensible'. Disallow non-polymorphic
	passed-object dummy arguments for procedure pointer components,
	turning warning into error. Add error check for CLASS components.

2009-08-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40940
	* gfortran.dg/class_1.f03: New.
	* gfortran.dg/class_2.f03: New.
	* gfortran.dg/proc_ptr_comp_pass_1.f90: Use CLASS instead of TYPE.
	* gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto.
	* gfortran.dg/typebound_call_10.f03: Ditto.
	* gfortran.dg/typebound_call_2.f03: Ditto.
	* gfortran.dg/typebound_call_3.f03: Ditto.
	* gfortran.dg/typebound_call_4.f03: Ditto.
	* gfortran.dg/typebound_generic_3.f03: Ditto.
	* gfortran.dg/typebound_generic_4.f03: Ditto.
	* gfortran.dg/typebound_proc_1.f08: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Ditto.
	* gfortran.dg/typebound_proc_6.f03: Ditto.

From-SVN: r150620

1 files changed, 47 insertions, 9 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 39f3cdc..81c8ccd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7916,6 +7916,15 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 }
 
 
+/* Check if a derived type is extensible.  */
+
+static bool
+type_is_extensible (gfc_symbol *sym)
+{
+  return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
 /* Additional checks for symbols with flavor variable and derived
    type.  To be called from resolve_fl_variable.  */
 
@@ -7964,6 +7973,25 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
       return FAILURE;
     }
 
+  if (sym->ts.is_class)
+    {
+      /* C502.  */
+      if (!type_is_extensible (sym->ts.derived))
+	{
+	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
+		     sym->ts.derived->name, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
+      /* C509.  */
+      if (!(sym->attr.dummy || sym->attr.allocatable || sym->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))
@@ -9000,9 +9028,12 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	  goto error;
 	}
 
-      gfc_warning ("Polymorphic entities are not yet implemented,"
-		   " non-polymorphic passed-object dummy argument of '%s'"
-		   " at %L accepted", proc->name, &where);
+      if (!me_arg->ts.is_class)
+	{
+	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+		     " at %L", proc->name, &where);
+	  goto error;
+	}
     }
 
   /* If we are extending some type, check that we don't override a procedure
@@ -9164,7 +9195,7 @@ resolve_fl_derived (gfc_symbol *sym)
     return FAILURE;
 
   /* An ABSTRACT type must be extensible.  */
-  if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
+  if (sym->attr.abstract && !type_is_extensible (sym))
     {
       gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
 		 sym->name, &sym->declared_at);
@@ -9340,11 +9371,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	      return FAILURE;
 	    }
 
-	  /* TODO: Make this an error once CLASS is implemented.  */
-	  if (!sym->attr.sequence)
-	    gfc_warning ("Polymorphic entities are not yet implemented,"
-			 " non-polymorphic passed-object dummy argument of '%s'"
-			 " at %L accepted", c->name, &c->loc);
+	  if (type_is_extensible (sym) && !me_arg->ts.is_class)
+	    gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+			 " at %L", c->name, &c->loc);
 
 	}
 
@@ -9412,6 +9441,15 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
+      /* C437.  */
+      if (c->ts.type == BT_DERIVED && c->ts.is_class
+	  && !(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;
+	}
+
       /* 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.  */