re PR fortran/37423 (Fortran 2003: DEFERRED bindings not yet implemented)

2009-03-29  Daniel Kraft  <d@domob.eu>

	PR fortran/37423
	* gfortran.h (struct gfc_typebound_proc): Added new flag `deferred' and
	added a comment explaining DEFERRED binding handling.
	* decl.c (match_binding_attributes): Really match DEFERRED attribute.
	(match_procedure_in_type): Really match PROCEDURE(interface) syntax
	and do some validity checks for DEFERRED and this construct.
	* module.c (binding_overriding): New string constant for DEFERRED.
	(mio_typebound_proc): Module-IO DEFERRED flag.
	* resolve.c (check_typebound_override): Ensure that a non-DEFERRED
	binding is not overridden by a DEFERRED one.
	(resolve_typebound_procedure): Allow abstract interfaces as targets
	for DEFERRED bindings.
	(ensure_not_abstract_walker), (ensure_not_abstract): New methods.
	(resolve_fl_derived): Use new `ensure_not_abstract' method for
	non-ABSTRACT types extending ABSTRACT ones to ensure each DEFERRED
	binding is overridden.
	(check_typebound_baseobject): New method.
	(resolve_compcall), (resolve_typebound_call): Check base-object of
	the type-bound procedure call.
	* gfc-internals.texi (Type-bound procedures): Document a little bit
	about internal handling of DEFERRED bindings.

2009-03-29  Daniel Kraft  <d@domob.eu>

	PR fortran/37423
	* gfortran.dg/typebound_proc_4.f03: Remove not-implemented check for
	DEFERRED bindings.
	* gfortran.dg/typebound_proc_9.f03: New test.
	* gfortran.dg/typebound_proc_10.f03: New test.
	* gfortran.dg/typebound_proc_11.f03: New test.
	* gfortran.dg/abstract_type_5.f03: New test.

From-SVN: r145248

1 files changed, 61 insertions, 8 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f6677fe..54a32f1 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -6732,6 +6732,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
   ba->pass_arg_num = 0;
   ba->nopass = 0;
   ba->non_overridable = 0;
+  ba->deferred = 0;
 
   /* If we find a comma, we believe there are binding attributes.  */
   if (gfc_match_char (',') == MATCH_NO)
@@ -6813,14 +6814,19 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
 	    }
 
 	  /* DEFERRED flag.  */
-	  /* TODO: Handle really once implemented.  */
 	  m = gfc_match (" deferred");
 	  if (m == MATCH_ERROR)
 	    goto error;
 	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("DEFERRED not yet implemented at %C");
-	      goto error;
+	      if (ba->deferred)
+		{
+		  gfc_error ("Duplicate DEFERRED at %C");
+		  goto error;
+		}
+
+	      ba->deferred = 1;
+	      continue;
 	    }
 
 	  /* PASS possibly including argument.  */
@@ -6861,6 +6867,13 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
     }
   while (gfc_match_char (',') == MATCH_YES);
 
+  /* NON_OVERRIDABLE and DEFERRED exclude themselves.  */
+  if (ba->non_overridable && ba->deferred)
+    {
+      gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
+      goto error;
+    }
+
   if (ba->access == ACCESS_UNKNOWN)
     ba->access = gfc_typebound_default_access;
 
@@ -6879,7 +6892,7 @@ match_procedure_in_type (void)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char target_buf[GFC_MAX_SYMBOL_LEN + 1];
-  char* target;
+  char* target = NULL;
   gfc_typebound_proc* tb;
   bool seen_colons;
   bool seen_attrs;
@@ -6893,11 +6906,25 @@ match_procedure_in_type (void)
   block = gfc_state_stack->previous->sym;
   gcc_assert (block);
 
-  /* TODO: Really implement PROCEDURE(interface).  */
+  /* Try to match PROCEDURE(interface).  */
   if (gfc_match (" (") == MATCH_YES)
     {
-      gfc_error ("PROCEDURE(interface) at %C is not yet implemented");
-      return MATCH_ERROR;
+      m = gfc_match_name (target_buf);
+      if (m == MATCH_ERROR)
+	return m;
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Interface-name expected after '(' at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (gfc_match (" )") != MATCH_YES)
+	{
+	  gfc_error ("')' expected at %C");
+	  return MATCH_ERROR;
+	}
+
+      target = target_buf;
     }
 
   /* Construct the data structure.  */
@@ -6911,6 +6938,19 @@ match_procedure_in_type (void)
     return m;
   seen_attrs = (m == MATCH_YES);
 
+  /* Check that attribute DEFERRED is given iff an interface is specified, which
+     means target != NULL.  */
+  if (tb->deferred && !target)
+    {
+      gfc_error ("Interface must be specified for DEFERRED binding at %C");
+      return MATCH_ERROR;
+    }
+  if (target && !tb->deferred)
+    {
+      gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
+      return MATCH_ERROR;
+    }
+
   /* Match the colons.  */
   m = gfc_match (" ::");
   if (m == MATCH_ERROR)
@@ -6933,12 +6973,17 @@ match_procedure_in_type (void)
     }
 
   /* Try to match the '=> target', if it's there.  */
-  target = NULL;
   m = gfc_match (" =>");
   if (m == MATCH_ERROR)
     return m;
   if (m == MATCH_YES)
     {
+      if (tb->deferred)
+	{
+	  gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+	  return MATCH_ERROR;
+	}
+
       if (!seen_colons)
 	{
 	  gfc_error ("'::' needed in PROCEDURE binding with explicit target"
@@ -6975,6 +7020,14 @@ match_procedure_in_type (void)
   ns = block->f2k_derived;
   gcc_assert (ns);
 
+  /* If the binding is DEFERRED, check that the containing type is ABSTRACT.  */
+  if (tb->deferred && !block->attr.abstract)
+    {
+      gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
+		 block->name);
+      return MATCH_ERROR;
+    }
+
   /* See if we already have a binding with this name in the symtree which would
      be an error.  If a GENERIC already targetted this binding, it may be
      already there but then typebound is still NULL.  */