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

5 files changed, 75 insertions, 10 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a064c8a..6158a72 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+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-05  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40955
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 67ccfda..6b6203e 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2369,7 +2369,16 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
 
   m = gfc_match (" type ( %n )", name);
   if (m != MATCH_YES)
-    return m;
+    {
+      m = gfc_match (" class ( %n )", name);
+      if (m != MATCH_YES)
+	return m;
+      ts->is_class = 1;
+
+      /* TODO: Implement Polymorphism.  */
+      gfc_warning ("Polymorphic entities are not yet implemented. "
+		   "CLASS will be treated like TYPE at %C");
+    }
 
   ts->type = BT_DERIVED;
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cefe3ec..3d95d217 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -841,6 +841,7 @@ typedef struct
   struct gfc_symbol *derived;
   gfc_charlen *cl;	/* For character types only.  */
   struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
+  unsigned int is_class:1;
   int is_c_interop;
   int is_iso_c;
   bt f90_type; 
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 94d61c9..7e4b481 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -71,6 +71,7 @@ gfc_clear_ts (gfc_typespec *ts)
   ts->kind = 0;
   ts->cl = NULL;
   ts->interface = NULL;
+  ts->is_class = 0;
   /* flag that says if the type is C interoperable */
   ts->is_c_interop = 0;
   /* says what f90 type the C kind interops with */
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.  */