re PR fortran/44549 ([OOP][F2008] Type-bound procedure: bogus error from list after PROCEDURE)

2010-06-16  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44549
	* gfortran.h (gfc_get_typebound_proc): Modified Prototype.
	* decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc
	structure to each procedure in a procedure list.
	* module.c (mio_typebound_proc): Add NULL argument to
	'gfc_get_typebound_proc'.
	* symbol.c (gfc_get_typebound_proc): Add a new argument, which is used
	to initialize the new structure.


2010-06-16  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44549
	* gfortran.dg/typebound_proc_16.f03: New.

From-SVN: r160834

gcc/fortran/ChangeLog

+2010-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44549
+	* gfortran.h (gfc_get_typebound_proc): Modified Prototype.
+	* decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc
+	structure to each procedure in a procedure list.
+	* module.c (mio_typebound_proc): Add NULL argument to
+	'gfc_get_typebound_proc'.
+	* symbol.c (gfc_get_typebound_proc): Add a new argument, which is used
+	to initialize the new structure.
+
 2010-06-15  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/43388

gcc/fortran/decl.c

@@ -7543,7 +7543,7 @@ match_procedure_in_type (void)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char target_buf[GFC_MAX_SYMBOL_LEN + 1];
   char* target = NULL, *ifc = NULL;
-  gfc_typebound_proc* tb;
+  gfc_typebound_proc tb;
   bool seen_colons;
   bool seen_attrs;
   match m;
@@ -7579,23 +7579,22 @@ match_procedure_in_type (void)
     }
 
   /* Construct the data structure.  */
-  tb = gfc_get_typebound_proc ();
-  tb->where = gfc_current_locus;
-  tb->is_generic = 0;
+  tb.where = gfc_current_locus;
+  tb.is_generic = 0;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb, false, false);
+  m = match_binding_attributes (&tb, false, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
 
   /* Check that attribute DEFERRED is given if an interface is specified.  */
-  if (tb->deferred && !ifc)
+  if (tb.deferred && !ifc)
     {
       gfc_error ("Interface must be specified for DEFERRED binding at %C");
       return MATCH_ERROR;
     }
-  if (ifc && !tb->deferred)
+  if (ifc && !tb.deferred)
     {
       gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
       return MATCH_ERROR;
@@ -7635,7 +7634,7 @@ match_procedure_in_type (void)
 	return m;
       if (m == MATCH_YES)
 	{
-	  if (tb->deferred)
+	  if (tb.deferred)
 	    {
 	      gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
 	      return MATCH_ERROR;
@@ -7668,7 +7667,7 @@ match_procedure_in_type (void)
       gcc_assert (ns);
 
       /* If the binding is DEFERRED, check that the containing type is ABSTRACT.  */
-      if (tb->deferred && !block->attr.abstract)
+      if (tb.deferred && !block->attr.abstract)
 	{
 	  gfc_error ("Type '%s' containing DEFERRED binding at %C "
 		     "is not ABSTRACT", block->name);
@@ -7693,11 +7692,12 @@ match_procedure_in_type (void)
 	  stree = gfc_new_symtree (&ns->tb_sym_root, name);
 	  gcc_assert (stree);
 	}
-      stree->n.tb = tb;
+      stree->n.tb = gfc_get_typebound_proc (&tb);
 
-      if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
+      if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
+			    false))
 	return MATCH_ERROR;
-      gfc_set_sym_referenced (tb->u.specific->n.sym);
+      gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
   
       if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
@@ -7841,7 +7841,7 @@ gfc_match_generic (void)
     }
   else
     {
-      tb = gfc_get_typebound_proc ();
+      tb = gfc_get_typebound_proc (NULL);
       tb->where = gfc_current_locus;
       tb->access = tbattr.access;
       tb->is_generic = 1;

gcc/fortran/gfortran.h

@@ -2545,7 +2545,7 @@ void gfc_free_dt_list (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
-gfc_typebound_proc* gfc_get_typebound_proc (void);
+gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
 bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);

gcc/fortran/module.c

@@ -3324,7 +3324,7 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 
   if (iomode == IO_INPUT)
     {
-      *proc = gfc_get_typebound_proc ();
+      *proc = gfc_get_typebound_proc (NULL);
       (*proc)->where = gfc_current_locus;
     }
   gcc_assert (*proc);

gcc/fortran/symbol.c

@@ -4591,12 +4591,14 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
    list and marked `error' until symbols are committed.  */
 
 gfc_typebound_proc*
-gfc_get_typebound_proc (void)
+gfc_get_typebound_proc (gfc_typebound_proc *tb0)
 {
   gfc_typebound_proc *result;
   tentative_tbp *list_node;
 
   result = XCNEW (gfc_typebound_proc);
+  if (tb0)
+    *result = *tb0;
   result->error = 1;
 
   list_node = XCNEW (tentative_tbp);

gcc/testsuite/ChangeLog

+2010-06-16  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44549
+	* gfortran.dg/typebound_proc_16.f03: New.
+
 2010-06-16  Martin Jambor  <mjambor@suse.cz>
 
 	* g++.dg/torture/pr43905.C: New test.

gcc/testsuite/gfortran.dg/typebound_proc_16.f03

+! { dg-do compile }
+!
+! PR 44549: [OOP][F2008] Type-bound procedure: bogus error from list after PROCEDURE
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+
+MODULE rational_numbers
+  IMPLICIT NONE
+  PRIVATE
+  TYPE,PUBLIC :: rational
+    PRIVATE
+    INTEGER n,d
+
+    CONTAINS
+    ! ordinary type-bound procedure
+    PROCEDURE :: real => rat_to_real
+    ! specific type-bound procedures for generic support
+    PROCEDURE,PRIVATE :: rat_asgn_i, rat_plus_rat, rat_plus_i
+    PROCEDURE,PRIVATE,PASS(b) :: i_plus_rat
+    ! generic type-bound procedures
+    GENERIC :: ASSIGNMENT(=) => rat_asgn_i
+    GENERIC :: OPERATOR(+) => rat_plus_rat, rat_plus_i, i_plus_rat
+  END TYPE
+  CONTAINS
+    ELEMENTAL REAL FUNCTION rat_to_real(this) RESULT(r)
+      CLASS(rational),INTENT(IN) :: this
+      r = REAL(this%n)/this%d
+    END FUNCTION
+
+    ELEMENTAL SUBROUTINE rat_asgn_i(a,b)
+      CLASS(rational),INTENT(OUT) :: a
+      INTEGER,INTENT(IN) :: b
+      a%n = b
+      a%d = 1
+    END SUBROUTINE
+
+    ELEMENTAL TYPE(rational) FUNCTION rat_plus_i(a,b) RESULT(r)
+      CLASS(rational),INTENT(IN) :: a
+      INTEGER,INTENT(IN) :: b
+      r%n = a%n + b*a%d
+      r%d = a%d
+    END FUNCTION
+
+    ELEMENTAL TYPE(rational) FUNCTION i_plus_rat(a,b) RESULT(r)
+      INTEGER,INTENT(IN) :: a
+      CLASS(rational),INTENT(IN) :: b
+      r%n = b%n + a*b%d
+      r%d = b%d
+    END FUNCTION
+
+    ELEMENTAL TYPE(rational) FUNCTION rat_plus_rat(a,b) RESULT(r)
+      CLASS(rational),INTENT(IN) :: a,b
+      r%n = a%n*b%d + b%n*a%d
+      r%d = a%d*b%d
+    END FUNCTION
+END
+
+! { dg-final { cleanup-modules "rational_numbers" } }