gfortran.h (gfc_typebound_proc): New struct.

2008-08-24  Daniel Kraft  <d@domob.eu>

	* gfortran.h (gfc_typebound_proc):  New struct.
	(gfc_symtree):  New member typebound.
	(gfc_find_typebound_proc):  Prototype for new method.
	(gfc_get_derived_super_type):  Prototype for new method.
	* parse.h (gfc_compile_state):  New state COMP_DERIVED_CONTAINS.
	* decl.c (gfc_match_procedure):  Handle PROCEDURE inside derived-type
	CONTAINS section.
	(gfc_match_end):  Handle new context COMP_DERIVED_CONTAINS.
	(gfc_match_private):  Ditto.
	(match_binding_attributes), (match_procedure_in_type):  New methods.
	(gfc_match_final_decl):  Rewrote to make use of new
	COMP_DERIVED_CONTAINS parser state.
	* parse.c (typebound_default_access):  New global helper variable.
	(set_typebound_default_access):  New callback method.
	(parse_derived_contains):  New method.
	(parse_derived):  Extracted handling of CONTAINS to new parser state
	and parse_derived_contains.
	* resolve.c (resolve_bindings_derived), (resolve_bindings_result):  New.
	(check_typebound_override), (resolve_typebound_procedure):  New methods.
	(resolve_typebound_procedures):  New method.
	(resolve_fl_derived):  Call new resolving method for typebound procs.
	* symbol.c (gfc_new_symtree):  Initialize new member typebound to NULL.
	(gfc_find_typebound_proc):  New method.
	(gfc_get_derived_super_type):  New method.

2008-08-24  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/finalize_5.f03:  Adapted expected error message to changes
	to handling of CONTAINS in derived-type declarations.
	* gfortran.dg/typebound_proc_1.f08:  New test.
	* gfortran.dg/typebound_proc_2.f90:  New test.
	* gfortran.dg/typebound_proc_3.f03:  New test.
	* gfortran.dg/typebound_proc_4.f03:  New test.
	* gfortran.dg/typebound_proc_5.f03:  New test.
	* gfortran.dg/typebound_proc_6.f03:  New test.

From-SVN: r139534

1 files changed, 290 insertions, 15 deletions

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ab4a64f..7ccee8b 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4320,6 +4320,8 @@ syntax:
 
 /* General matcher for PROCEDURE declarations.  */
 
+static match match_procedure_in_type (void);
+
 match
 gfc_match_procedure (void)
 {
@@ -4338,9 +4340,12 @@ gfc_match_procedure (void)
       m = match_procedure_in_interface ();
       break;
     case COMP_DERIVED:
-      gfc_error ("Fortran 2003: Procedure components at %C are "
-		"not yet implemented in gfortran");
+      gfc_error ("Fortran 2003: Procedure components at %C are not yet"
+		 " implemented in gfortran");
       return MATCH_ERROR;
+    case COMP_DERIVED_CONTAINS:
+      m = match_procedure_in_type ();
+      break;
     default:
       return MATCH_NO;
     }
@@ -5099,7 +5104,7 @@ gfc_match_end (gfc_statement *st)
   block_name = gfc_current_block () == NULL
 	     ? NULL : gfc_current_block ()->name;
 
-  if (state == COMP_CONTAINS)
+  if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
     {
       state = gfc_state_stack->previous->state;
       block_name = gfc_state_stack->previous->sym == NULL
@@ -5146,6 +5151,7 @@ gfc_match_end (gfc_statement *st)
       break;
 
     case COMP_DERIVED:
+    case COMP_DERIVED_CONTAINS:
       *st = ST_END_TYPE;
       target = " type";
       eos_ok = 0;
@@ -5823,9 +5829,12 @@ gfc_match_private (gfc_statement *st)
     return MATCH_NO;
 
   if (gfc_current_state () != COMP_MODULE
-      && (gfc_current_state () != COMP_DERIVED
-          || !gfc_state_stack->previous
-          || gfc_state_stack->previous->state != COMP_MODULE))
+      && !(gfc_current_state () == COMP_DERIVED
+	   && gfc_state_stack->previous
+	   && gfc_state_stack->previous->state == COMP_MODULE)
+      && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+	   && gfc_state_stack->previous && gfc_state_stack->previous->previous
+	   && gfc_state_stack->previous->previous->state == COMP_MODULE))
     {
       gfc_error ("PRIVATE statement at %C is only allowed in the "
 		 "specification part of a module");
@@ -6704,6 +6713,270 @@ cleanup:
 }
 
 
+/* Match binding attributes.  */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba)
+{
+  bool found_passing = false;
+  match m;
+
+  /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
+     this case the defaults are in there.  */
+  ba->access = ACCESS_UNKNOWN;
+  ba->pass_arg = NULL;
+  ba->pass_arg_num = 0;
+  ba->nopass = 0;
+  ba->non_overridable = 0;
+
+  /* If we find a comma, we believe there are binding attributes.  */
+  if (gfc_match_char (',') == MATCH_NO)
+    return MATCH_NO;
+
+  do
+    {
+      /* NOPASS flag.  */
+      m = gfc_match (" nopass");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (found_passing)
+	    {
+	      gfc_error ("Binding attributes already specify passing, illegal"
+			 " NOPASS at %C");
+	      goto error;
+	    }
+
+	  found_passing = true;
+	  ba->nopass = 1;
+	  continue;
+	}
+
+      /* NON_OVERRIDABLE flag.  */
+      m = gfc_match (" non_overridable");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->non_overridable)
+	    {
+	      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+	      goto error;
+	    }
+
+	  ba->non_overridable = 1;
+	  continue;
+	}
+
+      /* 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;
+	}
+
+      /* PASS possibly including argument.  */
+      m = gfc_match (" pass");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+	  if (found_passing)
+	    {
+	      gfc_error ("Binding attributes already specify passing, illegal"
+			 " PASS at %C");
+	      goto error;
+	    }
+
+	  m = gfc_match (" ( %n )", arg);
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
+	    ba->pass_arg = xstrdup (arg);
+	  gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+	  found_passing = true;
+	  ba->nopass = 0;
+	  continue;
+	}
+
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PUBLIC;
+	  continue;
+	}
+
+      m = gfc_match (" private");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PRIVATE;
+	  continue;
+	}
+
+      /* Nothing matching found.  */
+      gfc_error ("Expected binding attribute at %C");
+      goto error;
+    }
+  while (gfc_match_char (',') == MATCH_YES);
+
+  return MATCH_YES;
+
+error:
+  gfc_free (ba->pass_arg);
+  return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type.  */
+
+static match
+match_procedure_in_type (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+  char* target;
+  gfc_typebound_proc* tb;
+  bool seen_colons;
+  bool seen_attrs;
+  match m;
+  gfc_symtree* stree;
+  gfc_namespace* ns;
+  gfc_symbol* block;
+
+  /* Check current state.  */
+  gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
+
+  /* TODO: Really implement PROCEDURE(interface).  */
+  if (gfc_match (" (") == MATCH_YES)
+    {
+      gfc_error ("Procedure with interface only allowed in abstract types at"
+		 " %C");
+      return MATCH_ERROR;
+    }
+
+  /* Construct the data structure.  */
+  tb = XCNEW (gfc_typebound_proc);
+  tb->where = gfc_current_locus;
+
+  /* Match binding attributes.  */
+  m = match_binding_attributes (tb);
+  if (m == MATCH_ERROR)
+    return m;
+  seen_attrs = (m == MATCH_YES);
+
+  /* Match the colons.  */
+  m = gfc_match (" ::");
+  if (m == MATCH_ERROR)
+    return m;
+  seen_colons = (m == MATCH_YES);
+  if (seen_attrs && !seen_colons)
+    {
+      gfc_error ("Expected '::' after binding-attributes at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Match the binding name.  */ 
+  m = gfc_match_name (name);
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected binding name at %C");
+      return MATCH_ERROR;
+    }
+
+  /* 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 (!seen_colons)
+	{
+	  gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+		     " at %C");
+	  return MATCH_ERROR;
+	}
+
+      m = gfc_match_name (target_buf);
+      if (m == MATCH_ERROR)
+	return m;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected binding target after '=>' at %C");
+	  return MATCH_ERROR;
+	}
+      target = target_buf;
+    }
+
+  /* Now we should have the end.  */
+  m = gfc_match_eos ();
+  if (m == MATCH_ERROR)
+    return m;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Junk after PROCEDURE declaration at %C");
+      return MATCH_ERROR;
+    }
+
+  /* If no target was found, it has the same name as the binding.  */
+  if (!target)
+    target = name;
+
+  /* Get the namespace to insert the symbols into.  */
+  ns = block->f2k_derived;
+  gcc_assert (ns);
+
+  /* See if we already have a binding with this name in the symtree which would
+     be an error.  */
+  stree = gfc_find_symtree (ns->sym_root, name);
+  if (stree)
+    {
+      gfc_error ("There's already a procedure with binding name '%s' for the"
+		 " derived type '%s' at %C", name, block->name);
+      return MATCH_ERROR;
+    }
+
+  /* Insert it and set attributes.  */
+  if (gfc_get_sym_tree (name, ns, &stree))
+    return MATCH_ERROR;
+  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target))
+    return MATCH_ERROR;
+  stree->typebound = tb;
+
+  return MATCH_YES;
+}
+
+
 /* Match a FINAL declaration inside a derived type.  */
 
 match
@@ -6714,18 +6987,20 @@ gfc_match_final_decl (void)
   match m;
   gfc_namespace* module_ns;
   bool first, last;
+  gfc_symbol* block;
 
-  if (gfc_state_stack->state != COMP_DERIVED)
+  if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
     {
       gfc_error ("FINAL declaration at %C must be inside a derived type "
-		 "definition!");
+		 "CONTAINS section");
       return MATCH_ERROR;
     }
 
-  gcc_assert (gfc_current_block ());
+  block = gfc_state_stack->previous->sym;
+  gcc_assert (block);
 
-  if (!gfc_state_stack->previous
-      || gfc_state_stack->previous->state != COMP_MODULE)
+  if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+      || gfc_state_stack->previous->previous->state != COMP_MODULE)
     {
       gfc_error ("Derived type declaration with FINAL at %C must be in the"
 		 " specification part of a MODULE");
@@ -6783,7 +7058,7 @@ gfc_match_final_decl (void)
 	return MATCH_ERROR;
 
       /* Check if we already have this symbol in the list, this is an error.  */
-      for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
+      for (f = block->f2k_derived->finalizers; f; f = f->next)
 	if (f->proc_sym == sym)
 	  {
 	    gfc_error ("'%s' at %C is already defined as FINAL procedure!",
@@ -6792,14 +7067,14 @@ gfc_match_final_decl (void)
 	  }
 
       /* Add this symbol to the list of finalizers.  */
-      gcc_assert (gfc_current_block ()->f2k_derived);
+      gcc_assert (block->f2k_derived);
       ++sym->refs;
       f = XCNEW (gfc_finalizer);
       f->proc_sym = sym;
       f->proc_tree = NULL;
       f->where = gfc_current_locus;
-      f->next = gfc_current_block ()->f2k_derived->finalizers;
-      gfc_current_block ()->f2k_derived->finalizers = f;
+      f->next = block->f2k_derived->finalizers;
+      block->f2k_derived->finalizers = f;
 
       first = false;
     }