From eee4a6d85d3a9f24b48a26fe6455807c53bad76b Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sat, 4 Jul 2009 12:28:43 +0000
Subject: 2009-07-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40593
	* interface.c (compare_actual_formal): Take care of proc-pointer-valued
	functions as actual arguments.
	* trans-expr.c (gfc_conv_procedure_call): Ditto.
	* resolve.c (resolve_specific_f0): Use the correct ts.


2009-07-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40593
	* gfortran.dg/proc_ptr_result_6.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149227 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index c03c06e364c..ca500f582d9 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1911,7 +1911,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
 	 is provided for a procedure pointer formal argument.  */
       if (f->sym->attr.proc_pointer
-	  && !(a->expr->symtree->n.sym->attr.proc_pointer
+	  && !((a->expr->expr_type == EXPR_VARIABLE
+		&& a->expr->symtree->n.sym->attr.proc_pointer)
+	       || (a->expr->expr_type == EXPR_FUNCTION
+		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
 	       || is_proc_ptr_comp (a->expr, NULL)))
 	{
 	  if (where)
-- 
cgit v1.2.1


From ff70e44325c390560120b8ab5a8e0043d0403aef Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 9 Jul 2009 14:07:03 +0000
Subject: 2009-07-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40646
	* dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'.
	* expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
	(gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'.
	(replace_comp,gfc_expr_replace_comp): New functions, analogous
	to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
	instead of symbols.
	* gfortran.h (gfc_expr_replace_comp): New prototype.
	(is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
	* interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'.
	* match.c (gfc_match_pointer_assignment): Ditto.
	* primary.c (gfc_match_varspec): Handle array-valued procedure pointers
	and procedure pointer components. Renamed 'is_proc_ptr_comp'.
	* resolve.c (resolve_fl_derived): Correctly handle interfaces with
	RESULT statement, and handle array-valued procedure pointer components.
	(resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed
	'is_proc_ptr_comp'.
	* trans-array.c (gfc_walk_function_expr): Ditto.
	* trans-decl.c (gfc_get_symbol_decl): Security check for presence of
	ns->proc_name.
	* trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
	pointer components. Renamed 'is_proc_ptr_comp'.
	(conv_function_val,gfc_trans_arrayfunc_assign): Renamed
	'is_proc_ptr_comp'.
	(gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
	make a copy of it.
	* trans-io.c (gfc_trans_transfer): Handle array-valued procedure
	pointer components.


2009-07-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40646
	* gfortran.dg/proc_ptr_22.f90: New.
	* gfortran.dg/proc_ptr_comp_12.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149419 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ca500f582d9..cedca457f0c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1915,7 +1915,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		&& a->expr->symtree->n.sym->attr.proc_pointer)
 	       || (a->expr->expr_type == EXPR_FUNCTION
 		   && a->expr->symtree->n.sym->result->attr.proc_pointer)
-	       || is_proc_ptr_comp (a->expr, NULL)))
+	       || gfc_is_proc_ptr_comp (a->expr, NULL)))
 	{
 	  if (where)
 	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@@ -1925,7 +1925,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
-      if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
+      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
-- 
cgit v1.2.1


From 1c07b063c5dd7be4f220ffd1135f4ddc2034c238 Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 27 Jul 2009 18:26:34 +0000
Subject: 2009-07-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40848
	* interface.c (gfc_compare_interfaces): Call 'count_types_test' before
	'generic_correspondence', and only if checking a generic interface.


2009-07-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40848
	* gfortran.dg/altreturn_7.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150134 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 9 ++-------
 1 file changed, 2 insertions(+), 7 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index cedca457f0c..982aa290e22 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -983,6 +983,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 
   if (generic_flag)
     {
+      if (count_types_test (f1, f2) || count_types_test (f2, f1))
+	return 0;
       if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
 	return 0;
     }
@@ -1034,13 +1036,6 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 	f2 = f2->next;
       }
 
-  if (count_types_test (f1, f2) || count_types_test (f2, f1))
-    {
-      if (errmsg != NULL)
-	snprintf (errmsg, err_len, "Interface not matching");
-      return 0;
-    }
-
   return 1;
 }
 
-- 
cgit v1.2.1


From a36eb9ee1253552fcabdb8a9c578e0b68652f126 Mon Sep 17 00:00:00 2001
From: domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 10 Aug 2009 10:51:46 +0000
Subject: 2009-08-10  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/typebound_operator_1.f03: New test.
	* gfortran.dg/typebound_operator_2.f03: New test.

2009-08-10  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op.
	(gfc_find_typebound_user_op): New routine.
	(gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_check_operator_interface): Now public routine.
	* decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=).
	* interface.c (check_operator_interface): Made public, renamed to
	`gfc_check_operator_interface' accordingly and hand in the interface
	as gfc_symbol rather than gfc_interface so it is useful for type-bound
	operators, too.  Return boolean result.
	(gfc_check_interfaces): Adapt call to `check_operator_interface'.
	* symbol.c (gfc_get_namespace): Initialize new field `tb_op'.
	(gfc_free_namespace): Free `tb_uop_root'-based tree.
	(find_typebound_proc_uop): New helper function.
	(gfc_find_typebound_proc): Use it.
	(gfc_find_typebound_user_op): New method.
	(gfc_find_typebound_intrinsic_op): Ditto.
	* resolve.c (resolve_tb_generic_targets): New helper function.
	(resolve_typebound_generic): Use it.
	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New.
	(resolve_typebound_procedures): Resolve operators, too.
	(check_uop_procedure): New, code from gfc_resolve_uops.
	(gfc_resolve_uops): Moved main code to new `check_uop_procedure'.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150622 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 109 ++++++++++++++++++++++++++----------------------
 1 file changed, 60 insertions(+), 49 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 982aa290e22..daa46d88619 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -544,17 +544,16 @@ find_keyword_arg (const char *name, gfc_formal_arglist *f)
 /* Given an operator interface and the operator, make sure that all
    interfaces for that operator are legal.  */
 
-static void
-check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+			      locus opwhere)
 {
   gfc_formal_arglist *formal;
   sym_intent i1, i2;
-  gfc_symbol *sym;
   bt t1, t2;
   int args, r1, r2, k1, k2;
 
-  if (intr == NULL)
-    return;
+  gcc_assert (sym);
 
   args = 0;
   t1 = t2 = BT_UNKNOWN;
@@ -562,34 +561,32 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
   r1 = r2 = -1;
   k1 = k2 = -1;
 
-  for (formal = intr->sym->formal; formal; formal = formal->next)
+  for (formal = sym->formal; formal; formal = formal->next)
     {
-      sym = formal->sym;
-      if (sym == NULL)
+      gfc_symbol *fsym = formal->sym;
+      if (fsym == NULL)
 	{
 	  gfc_error ("Alternate return cannot appear in operator "
-		     "interface at %L", &intr->sym->declared_at);
-	  return;
+		     "interface at %L", &sym->declared_at);
+	  return false;
 	}
       if (args == 0)
 	{
-	  t1 = sym->ts.type;
-	  i1 = sym->attr.intent;
-	  r1 = (sym->as != NULL) ? sym->as->rank : 0;
-	  k1 = sym->ts.kind;
+	  t1 = fsym->ts.type;
+	  i1 = fsym->attr.intent;
+	  r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k1 = fsym->ts.kind;
 	}
       if (args == 1)
 	{
-	  t2 = sym->ts.type;
-	  i2 = sym->attr.intent;
-	  r2 = (sym->as != NULL) ? sym->as->rank : 0;
-	  k2 = sym->ts.kind;
+	  t2 = fsym->ts.type;
+	  i2 = fsym->attr.intent;
+	  r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+	  k2 = fsym->ts.kind;
 	}
       args++;
     }
 
-  sym = intr->sym;
-
   /* Only +, - and .not. can be unary operators.
      .not. cannot be a binary operator.  */
   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
@@ -598,8 +595,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       || (args == 2 && op == INTRINSIC_NOT))
     {
       gfc_error ("Operator interface at %L has the wrong number of arguments",
-		 &intr->sym->declared_at);
-      return;
+		 &sym->declared_at);
+      return false;
     }
 
   /* Check that intrinsics are mapped to functions, except
@@ -609,20 +606,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (!sym->attr.subroutine)
 	{
 	  gfc_error ("Assignment operator interface at %L must be "
-		     "a SUBROUTINE", &intr->sym->declared_at);
-	  return;
+		     "a SUBROUTINE", &sym->declared_at);
+	  return false;
 	}
       if (args != 2)
 	{
 	  gfc_error ("Assignment operator interface at %L must have "
-		     "two arguments", &intr->sym->declared_at);
-	  return;
+		     "two arguments", &sym->declared_at);
+	  return false;
 	}
 
       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
-         - First argument an array with different rank than second,
-         - Types and kinds do not conform, and
-         - First argument is of derived type.  */
+	 - First argument an array with different rank than second,
+	 - Types and kinds do not conform, and
+	 - First argument is of derived type.  */
       if (sym->formal->sym->ts.type != BT_DERIVED
 	  && (r1 == 0 || r1 == r2)
 	  && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
@@ -630,8 +627,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
 		  && gfc_numeric_ts (&sym->formal->next->sym->ts))))
 	{
 	  gfc_error ("Assignment operator interface at %L must not redefine "
-		     "an INTRINSIC type assignment", &intr->sym->declared_at);
-	  return;
+		     "an INTRINSIC type assignment", &sym->declared_at);
+	  return false;
 	}
     }
   else
@@ -639,8 +636,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (!sym->attr.function)
 	{
 	  gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
-		     &intr->sym->declared_at);
-	  return;
+		     &sym->declared_at);
+	  return false;
 	}
     }
 
@@ -648,22 +645,34 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
   if (op == INTRINSIC_ASSIGN)
     {
       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
-	gfc_error ("First argument of defined assignment at %L must be "
-		   "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
+	{
+	  gfc_error ("First argument of defined assignment at %L must be "
+		     "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+	  return false;
+	}
 
       if (i2 != INTENT_IN)
-	gfc_error ("Second argument of defined assignment at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("Second argument of defined assignment at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
     }
   else
     {
       if (i1 != INTENT_IN)
-	gfc_error ("First argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("First argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
 
       if (args == 2 && i2 != INTENT_IN)
-	gfc_error ("Second argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->sym->declared_at);
+	{
+	  gfc_error ("Second argument of operator interface at %L must be "
+		     "INTENT(IN)", &sym->declared_at);
+	  return false;
+	}
     }
 
   /* From now on, all we have to do is check that the operator definition
@@ -686,7 +695,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (t1 == BT_LOGICAL)
 	goto bad_repl;
       else
-	return;
+	return true;
     }
 
   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
@@ -694,20 +703,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       if (IS_NUMERIC_TYPE (t1))
 	goto bad_repl;
       else
-	return;
+	return true;
     }
 
   /* Character intrinsic operators have same character kind, thus
      operator definitions with operands of different character kinds
      are always safe.  */
   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
-    return;
+    return true;
 
   /* Intrinsic operators always perform on arguments of same rank,
      so different ranks is also always safe.  (rank == 0) is an exception
      to that, because all intrinsic operators are elemental.  */
   if (r1 != r2 && r1 != 0 && r2 != 0)
-    return;
+    return true;
 
   switch (op)
   {
@@ -760,14 +769,14 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
       break;
   }
 
-  return;
+  return true;
 
 #undef IS_NUMERIC_TYPE
 
 bad_repl:
   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
-	     &intr->where);
-  return;
+	     &opwhere);
+  return false;
 }
 
 
@@ -1229,7 +1238,9 @@ gfc_check_interfaces (gfc_namespace *ns)
       if (check_interface0 (ns->op[i], interface_name))
 	continue;
 
-      check_operator_interface (ns->op[i], (gfc_intrinsic_op) i);
+      if (ns->op[i])
+	gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+				      ns->op[i]->where);
 
       for (ns2 = ns; ns2; ns2 = ns2->parent)
 	{
-- 
cgit v1.2.1


From eeebe20ba63ca092de5e2d4575b5765dd88a7ce6 Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 13 Aug 2009 19:46:46 +0000
Subject: 2009-08-13  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40941
	* gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union.
	* decl.c (build_struct): Make sure 'cl' is only used
	if type is BT_CHARACTER.
	* symbol.c (gfc_set_default_type): Ditto.
	* resolve.c (resolve_symbol, resolve_fl_derived): Ditto.
	(resolve_equivalence,resolve_equivalence_derived): Make sure 'derived'
	is only used if type is BT_DERIVED.
	* trans-io.c (transfer_expr): Make sure 'derived' is only used if type
	is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR).
	* array.c: Mechanical replacements to accomodate union in gfc_typespec.
	* check.c: Ditto.
	* data.c: Ditto.
	* decl.c: Ditto.
	* dump-parse-tree.c: Ditto.
	* expr.c: Ditto.
	* interface.c: Ditto.
	* iresolve.c: Ditto.
	* match.c: Ditto.
	* misc.c: Ditto.
	* module.c: Ditto.
	* openmp.c: Ditto.
	* parse.c: Ditto.
	* primary.c: Ditto.
	* resolve.c: Ditto.
	* simplify.c: Ditto.
	* symbol.c: Ditto.
	* target-memory.c: Ditto.
	* trans-array.c: Ditto.
	* trans-common.c: Ditto.
	* trans-const.c: Ditto.
	* trans-decl.c: Ditto.
	* trans-expr.c: Ditto.
	* trans-intrinsic.c: Ditto.
	* trans-io.c: Ditto.
	* trans-stmt.c: Ditto.
	* trans-types.c: Ditto.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150725 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 54 ++++++++++++++++++++++++-------------------------
 1 file changed, 27 insertions(+), 27 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index daa46d88619..60096e20828 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -410,17 +410,17 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
 
       /* Make sure that link lists do not put this function into an 
 	 endless recursive loop!  */
-      if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-	    && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+      if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+	    && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 	    && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
 	return 0;
 
-      else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-		&& !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+      else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+		&& !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 	return 0;
 
-      else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
-		&& (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+      else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+		&& (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
 	return 0;
 
       dt1 = dt1->next;
@@ -454,10 +454,10 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
     return (ts1->kind == ts2->kind);
 
   /* Compare derived types.  */
-  if (ts1->derived == ts2->derived)
+  if (ts1->u.derived == ts2->u.derived)
     return 1;
 
-  return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+  return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
 }
 
 
@@ -1386,9 +1386,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     return 1;
 
   if (formal->ts.type == BT_DERIVED
-      && formal->ts.derived && formal->ts.derived->ts.is_iso_c
+      && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
       && actual->ts.type == BT_DERIVED
-      && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
+      && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
     return 1;
 
   if (actual->ts.type == BT_PROCEDURE)
@@ -1551,9 +1551,9 @@ get_sym_storage_size (gfc_symbol *sym)
 
   if (sym->ts.type == BT_CHARACTER)
     {
-      if (sym->ts.cl && sym->ts.cl->length
-          && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
-	strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+      if (sym->ts.u.cl && sym->ts.u.cl->length
+          && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
       else
 	return 0;
     }
@@ -1599,11 +1599,11 @@ get_expr_storage_size (gfc_expr *e)
   
   if (e->ts.type == BT_CHARACTER)
     {
-      if (e->ts.cl && e->ts.cl->length
-          && e->ts.cl->length->expr_type == EXPR_CONSTANT)
-	strlen = mpz_get_si (e->ts.cl->length->value.integer);
+      if (e->ts.u.cl && e->ts.u.cl->length
+          && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
       else if (e->expr_type == EXPR_CONSTANT
-	       && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+	       && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
 	strlen = e->value.character.length;
       else
 	return 0;
@@ -1869,28 +1869,28 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	 and assumed-shape dummies, the string length needs to match
 	 exactly.  */
       if (a->expr->ts.type == BT_CHARACTER
-	   && a->expr->ts.cl && a->expr->ts.cl->length
-	   && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
-	   && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
-	   && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
+	   && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+	   && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+	   && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
+	   && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
 	   && (f->sym->attr.pointer || f->sym->attr.allocatable
 	       || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
-	   && (mpz_cmp (a->expr->ts.cl->length->value.integer,
-			f->sym->ts.cl->length->value.integer) != 0))
+	   && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
+			f->sym->ts.u.cl->length->value.integer) != 0))
 	 {
 	   if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
 	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
 			  "argument and pointer or allocatable dummy argument "
 			  "'%s' at %L",
-			  mpz_get_si (a->expr->ts.cl->length->value.integer),
-			  mpz_get_si (f->sym->ts.cl->length->value.integer),
+			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.u.cl->length->value.integer),
 			  f->sym->name, &a->expr->where);
 	   else if (where)
 	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
 			  "argument and assumed-shape dummy argument '%s' "
 			  "at %L",
-			  mpz_get_si (a->expr->ts.cl->length->value.integer),
-			  mpz_get_si (f->sym->ts.cl->length->value.integer),
+			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.u.cl->length->value.integer),
 			  f->sym->name, &a->expr->where);
 	   return 0;
 	 }
-- 
cgit v1.2.1


From 7d034542867cddd55dc133813dae02338fdb9cf2 Mon Sep 17 00:00:00 2001
From: domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 27 Aug 2009 11:42:56 +0000
Subject: 2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.h (gfc_expr): Optionally store base-object in compcall value
	and add a new flag to distinguish assign-calls generated.
	(gfc_find_typebound_proc): Add locus argument.
	(gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_extend_expr): Return if failure was by a real error.
	* interface.c (matching_typebound_op): New routine.
	(build_compcall_for_operator): New routine.
	(gfc_extend_expr): Handle type-bound operators, some clean-up and
	return if failure was by a real error or just by not finding an
	appropriate operator definition.
	(gfc_extend_assign): Handle type-bound assignments.
	* module.c (MOD_VERSION): Incremented.
	(mio_intrinsic_op): New routine.
	(mio_full_typebound_tree): New routine to make typebound-procedures IO
	code reusable for type-bound user operators.
	(mio_f2k_derived): IO of type-bound operators.
	* primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and
	pass locus to gfc_find_typebound_proc.
	* resolve.c (resolve_operator): Only output error about no matching
	interface if gfc_extend_expr did not already fail with an error.
	(extract_compcall_passed_object): Use specified base-object if present.
	(update_compcall_arglist): Handle ignore_pass field.
	(resolve_ordinary_assign): Update to handle extended code for
	type-bound assignments, too.
	(resolve_code): Handle EXEC_ASSIGN_CALL statement code.
	(resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc.
	(resolve_typebound_generic), (resolve_typebound_procedure): Ditto.
	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto.
	(ensure_not_abstract_walker), (resolve_fl_derived): Ditto.
	(resolve_typebound_procedures): Remove not-implemented error.
	(resolve_typebound_call): Handle assign-call flag.
	* symbol.c (find_typebound_proc_uop): New argument to pass locus for
	error message about PRIVATE, verify that a found procedure is not marked
	as erraneous.
	(gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg.

2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/impure_assignment_1.f90: Change expected error message.
	* gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented
	error and fix problem with recursive assignment.
	* gfortran.dg/typebound_operator_2.f03: No not-implemented check.
	* gfortran.dg/typebound_operator_3.f03: New test.
	* gfortran.dg/typebound_operator_4.f03: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151140 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 248 ++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 199 insertions(+), 49 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 60096e20828..6d16fe10f42 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2554,16 +2554,119 @@ gfc_find_sym_in_symtree (gfc_symbol *sym)
 }
 
 
+/* See if the arglist to an operator-call contains a derived-type argument
+   with a matching type-bound operator.  If so, return the matching specific
+   procedure defined as operator-target as well as the base-object to use
+   (which is the found derived-type argument with operator).  */
+
+static gfc_typebound_proc*
+matching_typebound_op (gfc_expr** tb_base,
+		       gfc_actual_arglist* args,
+		       gfc_intrinsic_op op, const char* uop)
+{
+  gfc_actual_arglist* base;
+
+  for (base = args; base; base = base->next)
+    if (base->expr->ts.type == BT_DERIVED)
+      {
+	gfc_typebound_proc* tb;
+	gfc_symbol* derived;
+	gfc_try result;
+
+	derived = base->expr->ts.u.derived;
+
+	if (op == INTRINSIC_USER)
+	  {
+	    gfc_symtree* tb_uop;
+
+	    gcc_assert (uop);
+	    tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
+						 false, NULL);
+
+	    if (tb_uop)
+	      tb = tb_uop->n.tb;
+	    else
+	      tb = NULL;
+	  }
+	else
+	  tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
+						false, NULL);
+
+	/* This means we hit a PRIVATE operator which is use-associated and
+	   should thus not be seen.  */
+	if (result == FAILURE)
+	  tb = NULL;
+
+	/* Look through the super-type hierarchy for a matching specific
+	   binding.  */
+	for (; tb; tb = tb->overridden)
+	  {
+	    gfc_tbp_generic* g;
+
+	    gcc_assert (tb->is_generic);
+	    for (g = tb->u.generic; g; g = g->next)
+	      {
+		gfc_symbol* target;
+		gfc_actual_arglist* argcopy;
+		bool matches;
+
+		gcc_assert (g->specific);
+		if (g->specific->error)
+		  continue;
+
+		target = g->specific->u.specific->n.sym;
+
+		/* Check if this arglist matches the formal.  */
+		argcopy = gfc_copy_actual_arglist (args);
+		matches = gfc_arglist_matches_symbol (&argcopy, target);
+		gfc_free_actual_arglist (argcopy);
+
+		/* Return if we found a match.  */
+		if (matches)
+		  {
+		    *tb_base = base->expr;
+		    return g->specific;
+		  }
+	      }
+	  }
+      }
+
+  return NULL;
+}
+
+
+/* For the 'actual arglist' of an operator call and a specific typebound
+   procedure that has been found the target of a type-bound operator, build the
+   appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
+   type-bound procedures rather than resolving type-bound operators 'directly'
+   so that we can reuse the existing logic.  */
+
+static void
+build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
+			     gfc_expr* base, gfc_typebound_proc* target)
+{
+  e->expr_type = EXPR_COMPCALL;
+  e->value.compcall.tbp = target;
+  e->value.compcall.name = "operator"; /* Should not matter.  */
+  e->value.compcall.actual = actual;
+  e->value.compcall.base_object = base;
+  e->value.compcall.ignore_pass = 1;
+  e->value.compcall.assign = 0;
+}
+
+
 /* This subroutine is called when an expression is being resolved.
    The expression node in question is either a user defined operator
    or an intrinsic operator with arguments that aren't compatible
    with the operator.  This subroutine builds an actual argument list
    corresponding to the operands, then searches for a compatible
    interface.  If one is found, the expression node is replaced with
-   the appropriate function call.  */
+   the appropriate function call.
+   real_error is an additional output argument that specifies if FAILURE
+   is because of some real error and not because no match was found.  */
 
 gfc_try
-gfc_extend_expr (gfc_expr *e)
+gfc_extend_expr (gfc_expr *e, bool *real_error)
 {
   gfc_actual_arglist *actual;
   gfc_symbol *sym;
@@ -2576,6 +2679,8 @@ gfc_extend_expr (gfc_expr *e)
   actual = gfc_get_actual_arglist ();
   actual->expr = e->value.op.op1;
 
+  *real_error = false;
+
   if (e->value.op.op2 != NULL)
     {
       actual->next = gfc_get_actual_arglist ();
@@ -2605,47 +2710,20 @@ gfc_extend_expr (gfc_expr *e)
 	     to check if either is defined.  */
 	  switch (i)
 	    {
-	      case INTRINSIC_EQ:
-	      case INTRINSIC_EQ_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_EQ], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_EQ_OS], 0, &actual);
-		break;
-
-	      case INTRINSIC_NE:
-	      case INTRINSIC_NE_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_NE], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_NE_OS], 0, &actual);
-		break;
-
-	      case INTRINSIC_GT:
-	      case INTRINSIC_GT_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_GT], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_GT_OS], 0, &actual);
-		break;
-
-	      case INTRINSIC_GE:
-	      case INTRINSIC_GE_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_GE], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_GE_OS], 0, &actual);
-		break;
-
-	      case INTRINSIC_LT:
-	      case INTRINSIC_LT_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_LT], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_LT_OS], 0, &actual);
-		break;
-
-	      case INTRINSIC_LE:
-	      case INTRINSIC_LE_OS:
-		sym = gfc_search_interface (ns->op[INTRINSIC_LE], 0, &actual);
-		if (sym == NULL)
-		  sym = gfc_search_interface (ns->op[INTRINSIC_LE_OS], 0, &actual);
-		break;
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
+    if (!sym) \
+      sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
+    break;
+	      CHECK_OS_COMPARISON(EQ)
+	      CHECK_OS_COMPARISON(NE)
+	      CHECK_OS_COMPARISON(GT)
+	      CHECK_OS_COMPARISON(GE)
+	      CHECK_OS_COMPARISON(LT)
+	      CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
 
 	      default:
 		sym = gfc_search_interface (ns->op[i], 0, &actual);
@@ -2656,8 +2734,59 @@ gfc_extend_expr (gfc_expr *e)
 	}
     }
 
+  /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
+     found rather than just taking the first one and not checking further.  */
+
   if (sym == NULL)
     {
+      gfc_typebound_proc* tbo;
+      gfc_expr* tb_base;
+
+      /* See if we find a matching type-bound operator.  */
+      if (i == INTRINSIC_USER)
+	tbo = matching_typebound_op (&tb_base, actual,
+				     i, e->value.op.uop->name);
+      else
+	switch (i)
+	  {
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    tbo = matching_typebound_op (&tb_base, actual, \
+				 INTRINSIC_##comp, NULL); \
+    if (!tbo) \
+      tbo = matching_typebound_op (&tb_base, actual, \
+				   INTRINSIC_##comp##_OS, NULL); \
+    break;
+	    CHECK_OS_COMPARISON(EQ)
+	    CHECK_OS_COMPARISON(NE)
+	    CHECK_OS_COMPARISON(GT)
+	    CHECK_OS_COMPARISON(GE)
+	    CHECK_OS_COMPARISON(LT)
+	    CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+	    default:
+	      tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+	      break;
+	  }
+	      
+      /* If there is a matching typebound-operator, replace the expression with
+	 a call to it and succeed.  */
+      if (tbo)
+	{
+	  gfc_try result;
+
+	  gcc_assert (tb_base);
+	  build_compcall_for_operator (e, actual, tb_base, tbo);
+
+	  result = gfc_resolve_expr (e);
+	  if (result == FAILURE)
+	    *real_error = true;
+
+	  return result;
+	}
+
       /* Don't use gfc_free_actual_arglist().  */
       if (actual->next != NULL)
 	gfc_free (actual->next);
@@ -2675,16 +2804,12 @@ gfc_extend_expr (gfc_expr *e)
   e->value.function.name = NULL;
   e->user_operator = 1;
 
-  if (gfc_pure (NULL) && !gfc_pure (sym))
+  if (gfc_resolve_expr (e) == FAILURE)
     {
-      gfc_error ("Function '%s' called in lieu of an operator at %L must "
-		 "be PURE", sym->name, &e->where);
+      *real_error = true;
       return FAILURE;
     }
 
-  if (gfc_resolve_expr (e) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -2726,8 +2851,33 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 	break;
     }
 
+  /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
+
   if (sym == NULL)
     {
+      gfc_typebound_proc* tbo;
+      gfc_expr* tb_base;
+
+      /* See if we find a matching type-bound assignment.  */
+      tbo = matching_typebound_op (&tb_base, actual,
+				   INTRINSIC_ASSIGN, NULL);
+	      
+      /* If there is one, replace the expression with a call to it and
+	 succeed.  */
+      if (tbo)
+	{
+	  gcc_assert (tb_base);
+	  c->expr1 = gfc_get_expr ();
+	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+	  c->expr1->value.compcall.assign = 1;
+	  c->expr2 = NULL;
+	  c->op = EXEC_COMPCALL;
+
+	  /* c is resolved from the caller, so no need to do it here.  */
+
+	  return SUCCESS;
+	}
+
       gfc_free (actual->next);
       gfc_free (actual);
       return FAILURE;
-- 
cgit v1.2.1


From 10e9d5ee9cdd7a24dead20d3db2702644e5b580f Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 27 Aug 2009 19:48:46 +0000
Subject: 2009-08-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40869
	* expr.c (gfc_check_pointer_assign): Enable interface check for
	pointer assignments involving procedure pointer components.
	* gfortran.h (gfc_compare_interfaces): Modified prototype.
	* interface.c (gfc_compare_interfaces): Add argument 'name2', to be
	used instead of s2->name. Don't rely on the proc_pointer attribute,
	but instead on the flags handed to this function.
	(check_interface1,compare_parameter): Add argument for
	gfc_compare_interfaces.
	* resolve.c (check_generic_tbp_ambiguity): Ditto.

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

	PR fortran/40869
	* gfortran.dg/proc_ptr_comp_20.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151147 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 23 ++++++++++++-----------
 1 file changed, 12 insertions(+), 11 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6d16fe10f42..132f10a47c7 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
    required to match, which is not the case for ambiguity checks.*/
 
 int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
-			int intent_flag, char *errmsg, int err_len)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+			int generic_flag, int intent_flag,
+			char *errmsg, int err_len)
 {
   gfc_formal_arglist *f1, *f2;
 
   if (s1->attr.function && (s2->attr.subroutine
       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
-	  && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
+	  && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
     {
       if (errmsg != NULL)
-	snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+	snprintf (errmsg, err_len, "'%s' is not a function", name2);
       return 0;
     }
 
   if (s1->attr.subroutine && s2->attr.function)
     {
       if (errmsg != NULL)
-	snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+	snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
       return 0;
     }
 
   /* If the arguments are functions, check type and kind
      (only for dummy procedures and procedure pointer assignments).  */
-  if ((s1->attr.dummy || s1->attr.proc_pointer)
-      && s1->attr.function && s2->attr.function)
+  if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
     {
       if (s1->ts.type == BT_UNKNOWN)
 	return 1;
@@ -975,7 +975,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 	{
 	  if (errmsg != NULL)
 	    snprintf (errmsg, err_len, "Type/kind mismatch in return value "
-		      "of '%s'", s2->name);
+		      "of '%s'", name2);
 	  return 0;
 	}
     }
@@ -1012,7 +1012,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
 	  {
 	    if (errmsg != NULL)
 	      snprintf (errmsg, err_len, "'%s' has the wrong number of "
-			"arguments", s2->name);
+			"arguments", name2);
 	    return 0;
 	  }
 
@@ -1120,7 +1120,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
+	if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
+				    NULL, 0))
 	  {
 	    if (referenced)
 	      {
@@ -1403,7 +1404,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
-      if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
+      if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
 				   sizeof(err)))
 	{
 	  if (where)
-- 
cgit v1.2.1


From 1de1b1a9e40b5aa064d5e3d032dd43ce14f6d2ad Mon Sep 17 00:00:00 2001
From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Wed, 30 Sep 2009 19:55:45 +0000
Subject: fortran/ 2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* check.c (gfc_check_same_type_as): New function for checking
	SAME_TYPE_AS and EXTENDS_TYPE_OF.
	* decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class
	container, if the contained type has it. Add an initializer for the
	class container.
	(add_init_expr_to_sym): Handle BT_CLASS.
	(vindex_counter): New counter for setting vindices.
	(gfc_match_derived_decl): Set vindex for all derived types, not only
	those which are being extended.
	* expr.c (gfc_check_assign_symbol): Handle NULL initialization of class
	pointers.
	* gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and
	GFC_ISYM_EXTENDS_TYPE_OF.
	(gfc_type_is_extensible): New prototype.
	* intrinsic.h (gfc_check_same_type_as): New prototype.
	* intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF.
	* primary.c (gfc_expr_attr): Handle CLASS-valued functions.
	* resolve.c (resolve_structure_cons): Handle BT_CLASS.
	(type_is_extensible): Make non-static and rename to
	'gfc_type_is_extensible.
	(resolve_select_type): Renamed type_is_extensible.
	(resolve_class_assign): Handle NULL pointers.
	(resolve_fl_variable_derived): Renamed type_is_extensible.
	(resolve_fl_derived): Ditto.
	* trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL
	initialization of class pointer components.
	(gfc_conv_structure): Handle BT_CLASS.
	* trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of):
	New functions.
	(gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.h (type_selector, select_type_tmp): New global variables.
	* match.c (type_selector, select_type_tmp): New global variables,
	used for SELECT TYPE statements.
	(gfc_match_select_type): Better error handling. Remember selector.
	(gfc_match_type_is): Create temporary variable.
	* module.c (ab_attribute): New value 'AB_IS_CLASS'.
	(attr_bits): New string.
	(mio_symbol_attribute): Handle 'is_class'.
	* resolve.c (resolve_select_type): Insert pointer assignment statement,
	to assign temporary to selector.
	* symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary
	in SELECT TYPE statements.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* dump-parse-tree.c (show_code_node): Renamed 'alloc_list'.
	* gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'.
	(gfc_expr_to_initialize): New prototype.
	* match.c (alloc_opt_list): Correctly check type compatibility.
	Renamed 'alloc_list'.
	(dealloc_opt_list): Renamed 'alloc_list'.
	* resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize'
	and make it non-static.
	(resolve_allocate_expr): Set vindex for CLASS variables correctly.
	Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'.
	(resolve_allocate_deallocate): Renamed 'alloc_list'.
	(check_class_pointer_assign): Rename to 'resolve_class_assign'. Change
	argument type. Adjust to work with ordinary assignments.
	(resolve_code): Call 'resolve_class_assign' for ordinary assignments.
	Renamed 'check_class_pointer_assign'.
	* st.c (gfc_free_statement): Renamed 'alloc_list'.
	* trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle
	size determination and initialization of CLASS variables. Bugfix for
	ALLOCATE statements with default initialization and SOURCE block.
	(gfc_trans_deallocate): Renamed 'alloc_list'.

2009-09-30  Paul Thomas  <pault@gcc.gnu.org>

	* trans-expr.c (gfc_conv_procedure_call): Convert a derived
	type actual to a class object if the formal argument is a
	class.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40996
	* decl.c (build_struct): Handle allocatable scalar components.
	* expr.c (gfc_add_component_ref): Correctly set typespec of expression,
	after inserting component reference.
	* match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no
	variables are being used uninitialized.
	* primary.c (gfc_match_varspec): Handle CLASS array components.
	* resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to
	EXEC_SELECT.
	* trans-array.c (structure_alloc_comps,gfc_trans_deferred_array):
	Handle allocatable scalar components.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	* trans-types.c (gfc_get_derived_type): Ditto.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* decl.c (encapsulate_class_symbol): Modify names of class container
	components by prefixing with '$'.
	(gfc_match_end): Handle COMP_SELECT_TYPE.
	* expr.c (gfc_add_component_ref): Modify names of class container
	components by prefixing with '$'.
	* gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and
	ST_CLASS_IS.
	(gfc_case): New field 'ts'.
	(gfc_exec_op): Add EXEC_SELECT_TYPE.
	(gfc_type_is_extension_of): New prototype.
	* match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is):
	New prototypes.
	* match.c (match_derived_type_spec): New function.
	(match_type_spec): Use 'match_derived_type_spec'.
	(match_case_eos): Modify error message.
	(gfc_match_select_type): New function.
	(gfc_match_case): Modify error message.
	(gfc_match_type_is): New function.
	(gfc_match_class_is): Ditto.
	* parse.h (gfc_compile_state): Add COMP_SELECT_TYPE.
	* parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS
	statements.
	(next_statement): Handle ST_SELECT_TYPE.
	(gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS.
	(parse_select_type_block): New function.
	(parse_executable): Handle ST_SELECT_TYPE.
	* resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of
	class container components by prefixing with '$'.
	(resolve_allocate_expr): Ditto.
	(resolve_select_type): New function.
	(gfc_resolve_blocks): Handle EXEC_SELECT_TYPE.
	(check_class_pointer_assign): Modify names of class container
	components by prefixing with '$'.
	(resolve_code): Ditto.
	* st.c (gfc_free_statement): Ditto.
	* symbol.c (gfc_type_is_extension_of): New function.
	(gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix.
	* trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas <pault@gcc.gnu.org>

	* check.c (gfc_check_move_alloc): Arguments don't have to be arrays.
	The second argument needs to be type-compatible with the first (not the
	other way around, which makes a difference for CLASS entities).
	* decl.c (encapsulate_class_symbol): New function.
	(build_sym,build_struct): Handle BT_CLASS, call
	'encapsulate_class_symbol'.
	(gfc_match_decl_type_spec): Remove warning, use BT_CLASS.
	(gfc_match_derived_decl): Set vindex;
	* expr.c (gfc_add_component_ref): New function.
	(gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol):
	Handle BT_CLASS.
	* dump-parse-tree.c (show_symbol): Print vindex.
	* gfortran.h (bt): New basic type BT_CLASS.
	(symbol_attribute): New field 'is_class'.
	(gfc_typespec): Remove field 'is_class'.
	(gfc_symbol): New field 'vindex'.
	(gfc_get_ultimate_derived_super_type): New prototype.
	(gfc_add_component_ref): Ditto.
	* interface.c (gfc_compare_derived_types): Pointer equality check
	moved here from gfc_compare_types.
	(gfc_compare_types): Handle BT_CLASS and use
	gfc_type_compatible.
	* match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call):
	Handle BT_CLASS.
	* misc.c (gfc_clear_ts): Removed is_class.
	(gfc_basic_typename,gfc_typename): Handle BT_CLASS.
	* module.c (bt_types,mio_typespec): Handle BT_CLASS.
	(mio_symbol): Handle vindex.
	* primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS.
	* resolve.c (find_array_spec,check_typebound_baseobject):
	Handle BT_CLASS.
	(resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp'
	inside 'gcc_assert'.
	(resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS.
	(check_class_pointer_assign): New function.
	(resolve_code): Handle BT_CLASS, call check_class_pointer_assign.
	(resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived,
	resolve_fl_variable): Handle BT_CLASS.
	(check_generic_tbp_ambiguity): Add special case.
	(resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS.
	* symbol.c (gfc_get_ultimate_derived_super_type): New function.
	(gfc_type_compatible): Handle BT_CLASS.
	* trans-expr.c (conv_parent_component_references): Handle CLASS
	containers.
	(gfc_conv_initializer): Handle BT_CLASS.
	* trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type):
	Handle BT_CLASS.

testsuite/
2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/same_type_as_1.f03: New test.
	* gfortran.dg/same_type_as_2.f03: Ditto.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/select_type_1.f03: Extended.
	* gfortran.dg/select_type_3.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/class_allocate_1.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40996
	* gfortran.dg/allocatable_scalar_3.f90: New test.
	* gfortran.dg/select_type_2.f03: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Changed error messages.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/block_name_2.f90: Modified error message.
	* gfortran.dg/select_6.f90: Ditto.
	* gfortran.dg/select_type_1.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/allocate_derived_1.f90: Remove -w option.
	* gfortran.dg/class_1.f03: Ditto.
	* gfortran.dg/class_2.f03: Ditto.
	* gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto.
	* 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_call_9.f03: Ditto.
	* gfortran.dg/typebound_generic_3.f03: Ditto.
	* gfortran.dg/typebound_generic_4.f03: Ditto.
	* gfortran.dg/typebound_operator_1.f03: Ditto.
	* gfortran.dg/typebound_operator_2.f03: Ditto.
	* gfortran.dg/typebound_operator_3.f03: Ditto.
	* gfortran.dg/typebound_operator_4.f03: Ditto.
	* gfortran.dg/typebound_proc_1.f08: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Ditto.
	* gfortran.dg/typebound_proc_6.f03: Ditto.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 132f10a47c7..0fd4742a1de 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -360,6 +360,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
 {
   gfc_component *dt1, *dt2;
 
+  if (derived1 == derived2)
+    return 1;
+
   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */
@@ -448,13 +451,15 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     return 1;
    
-  if (ts1->type != ts2->type)
+  if (ts1->type != ts2->type
+      && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+	  || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
     return 0;
-  if (ts1->type != BT_DERIVED)
+  if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
     return (ts1->kind == ts2->kind);
 
   /* Compare derived types.  */
-  if (ts1->u.derived == ts2->u.derived)
+  if (gfc_type_compatible (ts1, ts2))
     return 1;
 
   return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
-- 
cgit v1.2.1


From 449db53c97557c939e81061836e6b7fd3de4566d Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Wed, 4 Nov 2009 19:41:07 +0000
Subject: 2009-11-04  Tobias Burnus <burnus@gcc.gnu.org> 	    Janus Weil
  <janus@gcc.gnu.org>

	PR fortran/41556
	PR fortran/41937
	* interface.c (gfc_check_operator_interface): Handle CLASS arguments.
	* resolve.c (resolve_allocate_expr): Handle allocatable components of
	CLASS variables.


2009-11-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41556
	PR fortran/41937
	* gfortran.dg/class_11.f03: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153911 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 1 +
 1 file changed, 1 insertion(+)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 0fd4742a1de..05e5d2d8a1f 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -626,6 +626,7 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
 	 - Types and kinds do not conform, and
 	 - First argument is of derived type.  */
       if (sym->formal->sym->ts.type != BT_DERIVED
+	  && sym->formal->sym->ts.type != BT_CLASS
 	  && (r1 == 0 || r1 == r2)
 	  && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
 	      || (gfc_numeric_ts (&sym->formal->sym->ts)
-- 
cgit v1.2.1


From 517699968be879d8931ae62dec33b865eb6f2ca4 Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 5 Nov 2009 15:31:07 +0000
Subject: 2009-11-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41556
	* interface.c (matching_typebound_op,gfc_extend_assign): Handle CLASS
	variables.

2009-11-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41556
	* gfortran.dg/class_12.f03: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153946 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 05e5d2d8a1f..866a81ca1d8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2574,13 +2574,16 @@ matching_typebound_op (gfc_expr** tb_base,
   gfc_actual_arglist* base;
 
   for (base = args; base; base = base->next)
-    if (base->expr->ts.type == BT_DERIVED)
+    if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
       {
 	gfc_typebound_proc* tb;
 	gfc_symbol* derived;
 	gfc_try result;
 
-	derived = base->expr->ts.u.derived;
+	if (base->expr->ts.type == BT_CLASS)
+	  derived = base->expr->ts.u.derived->components->ts.u.derived;
+	else
+	  derived = base->expr->ts.u.derived;
 
 	if (op == INTRINSIC_USER)
 	  {
@@ -2837,7 +2840,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   rhs = c->expr2;
 
   /* Don't allow an intrinsic assignment to be replaced.  */
-  if (lhs->ts.type != BT_DERIVED
+  if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
       && (rhs->rank == 0 || rhs->rank == lhs->rank)
       && (lhs->ts.type == rhs->ts.type
 	  || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
-- 
cgit v1.2.1


From e6bbcce0b12982d0df0058104392e6a71e02caee Mon Sep 17 00:00:00 2001
From: domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sun, 27 Dec 2009 09:30:57 +0000
Subject: 2009-12-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org> 	   
 Daniel Kraft  <d@domob.eu>

	PR fortran/22552
	* lang.opt (Wimplicit-procedure): New option.
	* gfortran.h (struct gfc_option_t): New member `warn_implicit_procedure'
	* options.c (gfc_handle_option): Handle -Wimplicit-procedure.
	* interface.c (gfc_procedure_use): Warn about procedure never
	explicitly declared if requested by the new flag.
	* invoke.texi: Document new flag -Wimplicit-procedure.

2009-12-27  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
	    Daniel Kraft  <d@domob.eu>

	PR fortran/22552
	* gfortran.dg/warn_implicit_procedure_1.f90: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155479 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 866a81ca1d8..0034f75b92e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2380,12 +2380,18 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 
   /* Warn about calls with an implicit interface.  Special case
      for calling a ISO_C_BINDING becase c_loc and c_funloc
-     are pseudo-unknown.  */
-  if (gfc_option.warn_implicit_interface
-      && sym->attr.if_source == IFSRC_UNKNOWN
-      && ! sym->attr.is_iso_c)
-    gfc_warning ("Procedure '%s' called with an implicit interface at %L",
-		 sym->name, where);
+     are pseudo-unknown.  Additionally, warn about procedures not
+     explicitly declared at all if requested.  */
+  if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
+    {
+      if (gfc_option.warn_implicit_interface)
+	gfc_warning ("Procedure '%s' called with an implicit interface at %L",
+		     sym->name, where);
+      else if (gfc_option.warn_implicit_procedure
+	       && sym->attr.proc == PROC_UNKNOWN)
+	gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
+		     sym->name, where);
+    }
 
   if (sym->attr.if_source == IFSRC_UNKNOWN)
     {
-- 
cgit v1.2.1


From ea3155041c21f1a7aad4e61e4a4705e2d53e264e Mon Sep 17 00:00:00 2001
From: jvdelisle <jvdelisle@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 15 Jan 2010 01:47:43 +0000
Subject: 2010-01-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>

	PR fortran/42684
	* interface.c (check_interface1): Pass symbol name rather than NULL to
	gfc_compare_interfaces.	(gfc_compare_interfaces): Add assert to
	trap MULL.
	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
	than NULL to gfc_compare_interfaces.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155930 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 0034f75b92e..2a5ece1c465 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -955,6 +955,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 {
   gfc_formal_arglist *f1, *f2;
 
+  gcc_assert (name2 != NULL);
+
   if (s1->attr.function && (s2->attr.subroutine
       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
 	  && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
@@ -1126,7 +1128,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
+	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
 				    NULL, 0))
 	  {
 	    if (referenced)
-- 
cgit v1.2.1


From b4d11551549cf7c5dab1c580142872a782ebd8ac Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sun, 17 Jan 2010 13:33:11 +0000
Subject: gcc/fortran/ 2010-01-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42677
	* gfortran.h (symbol_attribute): Remove 'ambiguous_interfaces'.
	* interface.c (check_interface1): Move a warning message here from
	resolve_fl_procedure.
	(check_sym_interfaces): Removed 'attr.ambiguous_interfaces'.
	* module.c (read_module): Remove call to gfc_check_interfaces, since
	this comes too early here.
	* resolve.c (resolve_fl_procedure): Move warning message to
	check_interface1.

gcc/testsuite/
2010-01-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42677
	* gfortran.dg/interface_assignment_5.f90: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155979 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 20 +++++++++-----------
 1 file changed, 9 insertions(+), 11 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2a5ece1c465..f27d75c333f 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1132,16 +1132,16 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 				    NULL, 0))
 	  {
 	    if (referenced)
-	      {
-		gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
-			   p->sym->name, q->sym->name, interface_name,
-			   &p->where);
-	      }
-
-	    if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
+	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+			 p->sym->name, q->sym->name, interface_name,
+			 &p->where);
+	    else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
 	      gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
 			   p->sym->name, q->sym->name, interface_name,
 			   &p->where);
+	    else
+	      gfc_warning ("Although not referenced, '%s' has ambiguous "
+			   "interfaces at %L", interface_name, &p->where);
 	    return 1;
 	  }
       }
@@ -1157,7 +1157,6 @@ static void
 check_sym_interfaces (gfc_symbol *sym)
 {
   char interface_name[100];
-  bool k;
   gfc_interface *p;
 
   if (sym->ns != gfc_current_ns)
@@ -1184,9 +1183,8 @@ check_sym_interfaces (gfc_symbol *sym)
       /* Originally, this test was applied to host interfaces too;
 	 this is incorrect since host associated symbols, from any
 	 source, cannot be ambiguous with local symbols.  */
-      k = sym->attr.referenced || !sym->attr.use_assoc;
-      if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
-	sym->attr.ambiguous_interfaces = 1;
+      check_interface1 (sym->generic, sym->generic, 1, interface_name,
+			sym->attr.referenced || !sym->attr.use_assoc);
     }
 }
 
-- 
cgit v1.2.1


From 27635231f058eebc201d5fd7cf67ca6b7d8530ee Mon Sep 17 00:00:00 2001
From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Wed, 3 Feb 2010 08:26:08 +0000
Subject: 2010-02-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/42936
        * interface.c (compare_parameter): Disable rank-checking
        for NULL().

2010-02-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/42936
        * gfortran.dg/null_4.f90: New test.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156461 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f27d75c333f..7bccaa6fffe 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1449,9 +1449,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   rank_check = where != NULL && !is_elemental && formal->as
 	       && (formal->as->type == AS_ASSUMED_SHAPE
-		   || formal->as->type == AS_DEFERRED);
+		   || formal->as->type == AS_DEFERRED)
+	       && actual->expr_type != EXPR_NULL;
 
-  if (rank_check || ranks_must_agree || formal->attr.pointer
+  if (rank_check || ranks_must_agree
+      || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
       || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
     {
@@ -1493,7 +1495,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       else
 	return 1;
     }
-  else if (ref == NULL)
+  else if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
       if (where)
 	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
-- 
cgit v1.2.1


From 1384ae99ee84aa34f559ffb29468099e22d88dd2 Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 1 Apr 2010 18:06:05 +0000
Subject: 2010-04-01  Paul Thomas  <pault@gcc.gnu.org>

	* ioparm.def : Update copyright.
	* lang.opt : ditto
	* trans-array.c : ditto
	* trans-array.h : ditto
	* expr.c: ditto
	* trans-types.c: ditto
	* dependency.c : ditto
	* gfortran.h : ditto
	* options.c : ditto
	* trans-io.c : ditto
	* trans-intrinsic.c : ditto
	* libgfortran.h : ditto
	* invoke.texi : ditto
	* intrinsic.texi : ditto
	* trans.c : ditto
	* trans.h : ditto
	* intrinsic.c : ditto
	* interface.c : ditto
	* iresolve.c : ditto
	* trans-stmt.c : ditto
	* trans-stmt.h : ditto
	* parse,c : ditto
	* match.h : ditto
	* error.c : ditto


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157923 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7bccaa6fffe..5b01af91f98 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1,5 +1,6 @@
 /* Deal with interfaces.
-   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
-- 
cgit v1.2.1


From e97ac7c06c53487872b7d9d11148725317ef5588 Mon Sep 17 00:00:00 2001
From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 9 Apr 2010 05:54:29 +0000
Subject: 2010-04-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * decl.c (variable_decl, match_attr_spec): Fix setting the array
        spec.
        * array.c (match_subscript,gfc_match_array_ref): Add coarray
        * support.
        * data.c (gfc_assign_data_value): Ditto.
        * expr.c (gfc_check_pointer_assign): Add check for coarray
        * constraint.
        (gfc_traverse_expr): Traverse also through codimension expressions.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): New functions.
        * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for
        * coarrays.
        (gfc_array_ref): Add codimen.
        (gfc_array_ref): Add in_allocate.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): Add prototypes.
        * interface.c (compare_parameter, compare_actual_formal,
        check_intents): Add coarray constraints.
        * match.c (gfc_match_iterator): Add coarray constraint.
        * match.h (gfc_match_array_ref): Update interface.
        * primary.c (gfc_match_varspec): Handle codimensions.
        * resolve.c (coarray_alloc, inquiry_argument): New static
        * variables.
        (check_class_members): Return gfc_try instead for error recovery.
        (resolve_typebound_function,resolve_typebound_subroutine,
        check_members): Handle return value of check_class_members.
        (resolve_structure_cons, resolve_actual_arglist, resolve_function,
        check_dimension, compare_spec_to_ref, resolve_array_ref,
        resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
        resolve_allocate_expr, resolve_ordinary_assign): Add coarray
        support.
        * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
        Skip over coarray refs.
        (gfc_array_allocate) Add support for references containing coindexes.
        * trans-expr.c (gfc_add_interface_mapping): Copy coarray
        * attribute.
        (gfc_map_intrinsic_function): Ignore codimensions.

2010-04-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_7.f90: New test.
        * gfortran.dg/coarray_8.f90: New test.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158149 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 148 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 146 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 5b01af91f98..9dd797be8cd 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1445,6 +1445,65 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 0;
     }
 
+  if (formal->attr.codimension)
+    {
+      gfc_ref *last = NULL;
+
+      if (actual->expr_type != EXPR_VARIABLE
+	  || (actual->ref == NULL
+	      && !actual->symtree->n.sym->attr.codimension))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+
+      for (ref = actual->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to '%s' at %L must be a coarray "
+			   "and not coindexed", formal->name, &ref->u.ar.where);
+	      return 0;
+	    }
+	  if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+	      && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to '%s' at %L must be a coarray "
+			   "and thus shall not have an array designator",
+			   formal->name, &ref->u.ar.where);
+	      return 0;
+	    }
+	  if (ref->type == REF_COMPONENT)
+	    last = ref;
+	}
+
+      if (last && !last->u.c.component->attr.codimension)
+      	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+
+      /* F2008, 12.5.2.6.  */
+      if (formal->attr.allocatable &&
+	  ((last && last->u.c.component->as->corank != formal->as->corank)
+	   || (!last
+	       && actual->symtree->n.sym->as->corank != formal->as->corank)))
+	{
+	  if (where)
+	    gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+		   formal->name, &actual->where, formal->as->corank,
+		   last ? last->u.c.component->as->corank
+			: actual->symtree->n.sym->as->corank);
+	  return 0;
+	}
+    }
+
   if (symbol_rank (formal) == actual->rank)
     return 1;
 
@@ -1453,10 +1512,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		   || formal->as->type == AS_DEFERRED)
 	       && actual->expr_type != EXPR_NULL;
 
+  /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
   if (rank_check || ranks_must_agree
       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
-      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+      || (actual->rank == 0 && formal->attr.dimension
+	  && gfc_is_coindexed (actual)))
     {
       if (where)
 	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
@@ -1474,7 +1536,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
      - (F2003) if the actual argument is of type character.  */
 
   for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+	&& ref->u.ar.dimen > 0)
       break;
 
   /* Not an array element.  */
@@ -1984,6 +2047,57 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
+      /* Fortran 2008, C1242.  */
+      if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to pointer "
+		       "dummy '%s'",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.5 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN
+	  && f->sym->attr.allocatable
+	  && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to allocatable "
+		       "dummy '%s' requires INTENT(IN)",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, C1237.  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+	  && gfc_is_coindexed (a->expr)
+	  && (a->expr->symtree->n.sym->attr.volatile_
+	      || a->expr->symtree->n.sym->attr.asynchronous))
+	{
+	  if (where)
+	    gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+		       "at %L requires that dummy %s' has neither "
+		       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+		       f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.4 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+	  && gfc_is_coindexed (a->expr)
+	  && gfc_has_ultimate_allocatable (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L with allocatable "
+		       "ultimate component to dummy '%s' requires either VALUE "
+		       "or INTENT(IN)", &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_allocatable (f->sym, a->expr) == 0)
 	{
@@ -2367,6 +2481,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 	      return FAILURE;
 	    }
 	}
+
+       /* Fortran 2008, C1283.  */
+       if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+	{
+	  if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to an INTENT(%s) argument",
+			 &a->expr->where, gfc_intent_string (f_intent));
+	      return FAILURE;
+	    }
+
+	  if (f->sym->attr.pointer)
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to a POINTER dummy argument",
+			 &a->expr->where);
+	      return FAILURE;
+	    }
+	}
+
+       /* F2008, Section 12.5.2.4.  */
+       if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+	   && gfc_is_coindexed (a->expr))
+	 {
+	   gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+		      "polymorphic dummy argument '%s'",
+			 &a->expr->where, f->sym->name);
+	   return FAILURE;
+	 }
     }
 
   return SUCCESS;
-- 
cgit v1.2.1


From 09c509edcc2f6e6859f02de43ce0fe10a941a8d7 Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 29 Apr 2010 19:10:48 +0000
Subject: 2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43896
	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
	initializers for PPC members of the vtabs.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
	attribute for all PPC members of the vtypes.
	(copy_vtab_proc_comps): Copy the correct interface.
	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
	a dummy argument and make sure all PPC members of the vtab are
	initialized correctly.
	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
	in call to gfc_trans_assign_vtab_procs.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* resolve.c (resolve_typebound_function): Renamed
	resolve_class_compcall.Do all the detection of class references
	here.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* resolve.c (resolve_typebound_generic_call): For CLASS methods
	pass back the specific symtree name, rather than the target
	name.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* resolve.c (resolve_structure_cons): Make the initializer of
	the vtab component 'extends' the same type as the component.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* interface.c (check_interface1): Pass symbol name rather than NULL to
	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
	trap MULL. (gfc_compare_derived_types): Revert previous change
	incorporated incorrectly during merge from trunk, r155778.
	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
	than NULL to gfc_compare_interfaces.
	* symbol.c (add_generic_specifics): Likewise.

2010-02-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42353
	* interface.c (gfc_compare_derived_types): Add condition for vtype.
	* symbol.c (gfc_find_derived_vtab): Sey access to private.
	(gfc_find_derived_vtab): Likewise.
	* module.c (ab_attribute): Add enumerator AB_VTAB.
	(mio_symbol_attribute): Use new attribute, AB_VTAB.
	(check_for_ambiguous): Likewise.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* trans-expr.c (select_class_proc): Remove function.
	(conv_function_val): Delete reference to previous.
	(gfc_conv_derived_to_class): Add second argument to the call to
	gfc_find_derived_vtab.
	(gfc_conv_structure): Exclude proc_pointer components when
	accessing $data field of class objects.
	(gfc_trans_assign_vtab_procs): New function.
	(gfc_trans_class_assign): Add second argument to the call to
	gfc_find_derived_vtab.
	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
	implement holding off searching for the vptr derived type.
	(add_proc_component): New function.
	(add_proc_comps): New function.
	(add_procs_to_declared_vtab1): New function.
	(copy_vtab_proc_comps): New function.
	(add_procs_to_declared_vtab): New function.
	(void add_generic_specifics): New function.
	(add_generics_to_declared_vtab): New function.
	(gfc_find_derived_vtab): Add second argument to the call to
	gfc_find_derived_vtab. Add the calls to
	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
	* decl.c (build_sym, build_struct): Use new arg in calls to
	gfc_build_class_symbol.
	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
	definition of struct gfc_class_esym_list. Modify prototypes
	of gfc_build_class_symbol and gfc_find_derived_vtab.
	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
	call to gfc_find_derived_vtab.
	* module.c : Add the vtype attribute.
	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
	* resolve.c (resolve_typebound_generic_call): Add second arg
	to pass along the generic name for class methods.
	(resolve_typebound_call): The same.
	(resolve_compcall): Use the second arg to carry the generic
	name from the above. Remove the reference to class_esym.
	(check_members, check_class_members, resolve_class_esym,
	hash_value_expr): Remove functions.
	(resolve_class_compcall, resolve_class_typebound_call): Modify
	to use vtable rather than member by member calls.
	(gfc_resolve_expr): Modify second arg in call to
	resolve_compcall.
	(resolve_select_type): Add second arg in call to
	gfc_find_derived_vtab.
	(resolve_code): Add second arg in call resolve_typebound_call.
	(resolve_fl_derived): Exclude vtypes from check for late
	procedure definitions. Likewise for checking of explicit
	interface and checking of pass arg.
	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
	calls to gfc_find_derived_vtab.
	* match.c (select_type_set_tmp): Use new arg in call to
	gfc_build_class_symbol.
	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
	necessary.
	* parse.c (endType): Finish incomplete classes.


2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_16.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_15.f03: New.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_9.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* gfortran.dg/generic_22.f03 : New test.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* gfortran.dg/class_14.f03: New test.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* gfortran.dg/interface_32.f90: New test.

2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
	* gfortran.dg/dynamic_dispatch_7.f03 : New test.
	* gfortran.dg/dynamic_dispatch_8.f03 : New test.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158910 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9dd797be8cd..38adf9b7393 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1129,8 +1129,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
-				    NULL, 0))
+	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
+				    0, NULL, 0))
 	  {
 	    if (referenced)
 	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
-- 
cgit v1.2.1


From 3e2de00f324e7813c1d1fd94512b5cb5575a8ff2 Mon Sep 17 00:00:00 2001
From: kargl <kargl@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 14 May 2010 21:02:26 +0000
Subject: 2010-05-14  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/44135
	* gfortran.dg/actual_array_interface_2.f90: New test.

2010-05-14  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/44135
	* fortran/interface.c (get_sym_storage_size): Use signed instead of
	unsigned mpz_get_?i routines.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159415 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 38adf9b7393..4bcc63e1963 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1645,8 +1645,8 @@ get_sym_storage_size (gfc_symbol *sym)
 	  || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
 	return 0;
 
-      elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
-		  - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+      elements *= mpz_get_si (sym->as->upper[i]->value.integer)
+		  - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
     }
 
   return strlen*elements;
-- 
cgit v1.2.1


From 50b4b37ba4128b5e02d6b8af5f872770063c1d2b Mon Sep 17 00:00:00 2001
From: janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sun, 30 May 2010 21:56:11 +0000
Subject: 2010-05-30  Janus Weil  <janus@gcc.gnu.org>

	* gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the
	$data component of a class container.
	* gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA.
	* gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol,
	gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto.
	* gcc/fortran/interface.c (matching_typebound_op): Ditto.
	* gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto.
	* gcc/fortran/parse.c (parse_derived): Ditto.
	* gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr,
	gfc_expr_attr): Ditto.
	* gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec,
	resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type,
	resolve_fl_var_and_proc, resolve_typebound_procedure,
	resolve_fl_derived): Ditto.
	* gcc/fortran/symbol.c (gfc_type_compatible): Restructured.
	* gcc/fortran/trans-array.c (structure_alloc_comps): Use macro
	CLASS_DATA.
	* gcc/fortran/trans-decl.c (gfc_get_symbol_decl,
	gfc_trans_deferred_vars): Ditto.
	* gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160060 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 4bcc63e1963..99ade9d273d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2734,7 +2734,7 @@ matching_typebound_op (gfc_expr** tb_base,
 	gfc_try result;
 
 	if (base->expr->ts.type == BT_CLASS)
-	  derived = base->expr->ts.u.derived->components->ts.u.derived;
+	  derived = CLASS_DATA (base->expr)->ts.u.derived;
 	else
 	  derived = base->expr->ts.u.derived;
 
-- 
cgit v1.2.1


From d18a512a42d8072efb8b9f2bb82ea97536b4cea3 Mon Sep 17 00:00:00 2001
From: domob <domob@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 10 Jun 2010 14:47:49 +0000
Subject: 2010-06-10  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE.
	(struct gfc_symbol): New field `assoc'.
	(struct gfc_association_list): New struct.
	(struct gfc_code): New struct `block' in union, move `ns' there
	and add association list.
	(gfc_free_association_list): New method.
	(gfc_has_vector_subscript): Made public;
	* match.h (gfc_match_associate): New method.
	* parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE.
	* decl.c (gfc_match_end): Handle ST_END_ASSOCIATE.
	* interface.c (gfc_has_vector_subscript): Made public.
	(compare_actual_formal): Rename `has_vector_subscript' accordingly.
	* match.c (gfc_match_associate): New method.
	(gfc_match_select_type): Change reference to gfc_code's `ns' field.
	* primary.c (match_variable): Don't allow names associated to expr here.
	* parse.c (decode_statement): Try matching ASSOCIATE statement.
	(case_exec_markers, case_end): Add ASSOCIATE statement.
	(gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE.
	(parse_associate): New method.
	(parse_executable): Handle ST_ASSOCIATE.
	(parse_block_construct): Change reference to gfc_code's `ns' field.
	* resolve.c (resolve_select_type): Ditto.
	(resolve_code): Ditto.
	(resolve_block_construct): Ditto and add comment.
	(resolve_select_type): Set association list in generated BLOCK to NULL.
	(resolve_symbol): Resolve associate names.
	* st.c (gfc_free_statement): Change reference to gfc_code's `ns' field
	and free association list.
	(gfc_free_association_list): New method.
	* symbol.c (gfc_new_symbol): NULL new field `assoc'.
	* trans-stmt.c (gfc_trans_block_construct): Change reference to
	gfc_code's `ns' field.

2010-06-10  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.dg/associate_1.f03: New test.
	* gfortran.dg/associate_2.f95: New test.
	* gfortran.dg/associate_3.f03: New test.
	* gfortran.dg/associate_4.f08: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160550 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 99ade9d273d..379c636d695 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1821,8 +1821,8 @@ get_expr_storage_size (gfc_expr *e)
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
 
-static int
-has_vector_subscript (gfc_expr *e)
+int
+gfc_has_vector_subscript (gfc_expr *e)
 {
   int i;
   gfc_ref *ref;
@@ -2134,7 +2134,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       if ((f->sym->attr.intent == INTENT_OUT
 	   || f->sym->attr.intent == INTENT_INOUT
 	   || f->sym->attr.volatile_)
-          && has_vector_subscript (a->expr))
+	  && gfc_has_vector_subscript (a->expr))
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument with vector subscripts "
-- 
cgit v1.2.1


From d1c662df00eb4568c99b0fa8e2307370ae01c615 Mon Sep 17 00:00:00 2001
From: dfranke <dfranke@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 10 Jun 2010 18:25:56 +0000
Subject: gcc/fortran/: 2010-06-10  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/44457
	* interface.c (compare_actual_formal): Reject actual arguments with
	array subscript passed to ASYNCHRONOUS dummys.

gcc/testsuite/:
2010-06-10  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/44457
	* gfortran.dg/asynchronous_3.f03



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160567 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 379c636d695..284622f05e0 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2133,13 +2133,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       if ((f->sym->attr.intent == INTENT_OUT
 	   || f->sym->attr.intent == INTENT_INOUT
-	   || f->sym->attr.volatile_)
+	   || f->sym->attr.volatile_
+	   || f->sym->attr.asynchronous)
 	  && gfc_has_vector_subscript (a->expr))
 	{
 	  if (where)
-	    gfc_error ("Array-section actual argument with vector subscripts "
-		       "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
-		       "or VOLATILE attribute of the dummy argument '%s'",
+	    gfc_error ("Array-section actual argument with vector "
+		       "subscripts at %L is incompatible with INTENT(OUT), "
+		       "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
+		       "of the dummy argument '%s'",
 		       &a->expr->where, f->sym->name);
 	  return 0;
 	}
-- 
cgit v1.2.1


From b3c3927c05d8ad190b76c56ae6020e1650b85a97 Mon Sep 17 00:00:00 2001
From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 21 Jun 2010 14:15:56 +0000
Subject: 2010-06-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40632
        * interface.c (compare_parameter): Add gfc_is_simply_contiguous
        checks.
        * symbol.c (gfc_add_contiguous): New function.
        (gfc_copy_attr, check_conflict): Handle contiguous attribute.
        * decl.c (match_attr_spec): Ditto.
        (gfc_match_contiguous): New function.
        * resolve.c (resolve_fl_derived, resolve_symbol): Handle
        contiguous.
        * gfortran.h (symbol_attribute): Add contiguous.
        (gfc_is_simply_contiguous): Add prototype.
        (gfc_add_contiguous): Add prototype.
        * match.h (gfc_match_contiguous): Add prototype.
        * parse.c (decode_specification_statement,
        decode_statement): Handle contiguous attribute.
        * expr.c (gfc_is_simply_contiguous): New function.
        * dump-parse-tree.c (show_attr): Handle contiguous.
        * module.c (ab_attribute, attr_bits, mio_symbol_attribute):
        Ditto.
        * trans-expr.c (gfc_add_interface_mapping): Copy
        attr.contiguous.
        * trans-array.c (gfc_conv_descriptor_stride_get,
        gfc_conv_array_parameter): Handle contiguous arrays.
        * trans-types.c (gfc_build_array_type, gfc_build_array_type,
        gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info):
        Ditto.
        * trans.h (gfc_array_kind): Ditto.
        * trans-decl.c (gfc_get_symbol_decl): Ditto.

2010-06-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40632
        * gfortran.dg/contiguous_1.f90: New.
        * gfortran.dg/contiguous_2.f90: New.
        * gfortran.dg/contiguous_3.f90: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161079 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 284622f05e0..ee164fc6d1a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1435,6 +1435,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 1;
     }
 
+  /* F2008, C1241.  */
+  if (formal->attr.pointer && formal->attr.contiguous
+      && !gfc_is_simply_contiguous (actual, true))
+    {
+      if (where)
+	gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+		   "must be simply contigous", formal->name, &actual->where);
+      return 0;
+    }
+
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && !gfc_compare_types (&formal->ts, &actual->ts))
     {
@@ -1502,6 +1512,34 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 			: actual->symtree->n.sym->as->corank);
 	  return 0;
 	}
+
+      /* F2008, 12.5.2.8.  */
+      if (formal->attr.dimension
+	  && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+	  && !gfc_is_simply_contiguous (actual, true))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be simply "
+		       "contiguous", formal->name, &actual->where);
+	  return 0;
+	}
+    }
+
+  /* F2008, C1239/C1240.  */
+  if (actual->expr_type == EXPR_VARIABLE
+      && (actual->symtree->n.sym->attr.asynchronous
+         || actual->symtree->n.sym->attr.volatile_)
+      &&  (formal->attr.asynchronous || formal->attr.volatile_)
+      && actual->rank && !gfc_is_simply_contiguous (actual, true)
+      && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+	  || formal->attr.contiguous))
+    {
+      if (where)
+	gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+		   "array without CONTIGUOUS attribute - as actual argument at"
+		   " %L is not simply contiguous and both are ASYNCHRONOUS "
+		   "or VOLATILE", formal->name, &actual->where);
+      return 0;
     }
 
   if (symbol_rank (formal) == actual->rank)
-- 
cgit v1.2.1


From 1a161246ac662c15471f5feb9acc57decbe0629d Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 28 Jun 2010 17:16:06 +0000
Subject: 2010-06-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40158
	* interface.c (argument_rank_mismatch): New function.
	(compare_parameter): Call new function instead of generating
	the error directly.

2010-06-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40158
	* gfortran.dg/actual_rank_check_1.f90: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161504 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 34 ++++++++++++++++++++++++++++------
 1 file changed, 28 insertions(+), 6 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ee164fc6d1a..587b09cdf8c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1376,6 +1376,30 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 }
 
 
+/* Emit clear error messages for rank mismatch.  */
+
+static void
+argument_rank_mismatch (const char *name, locus *where,
+			int rank1, int rank2)
+{
+  if (rank1 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(scalar and rank-%d)", name, where, rank2);
+    }
+  else if (rank2 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(rank-%d and scalar)", name, where, rank1);
+    }
+  else
+    {    
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+		 "(rank-%d and rank-%d)", name, where, rank1, rank2);
+    }
+}
+
+
 /* Given a symbol of a formal argument list and an expression, see if
    the two are compatible as arguments.  Returns nonzero if
    compatible, zero if not compatible.  */
@@ -1559,9 +1583,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  && gfc_is_coindexed (actual)))
     {
       if (where)
-	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
-		   formal->name, &actual->where, symbol_rank (formal),
-		   actual->rank);
+	argument_rank_mismatch (formal->name, &actual->where,
+				symbol_rank (formal), actual->rank);
       return 0;
     }
   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
@@ -1600,9 +1623,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   else if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
       if (where)
-	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
-		   formal->name, &actual->where, symbol_rank (formal),
-		   actual->rank);
+	argument_rank_mismatch (formal->name, &actual->where,
+				symbol_rank (formal), actual->rank);
       return 0;
     }
 
-- 
cgit v1.2.1


From abca35418102c31d95b688897b34b9ff2688ee3d Mon Sep 17 00:00:00 2001
From: pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 19 Jul 2010 18:48:44 +0000
Subject: 2010-07-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* interface.c (matching_typebound_op): Add argument for the
	return of the generic name for the procedure.
	(build_compcall_for_operator): Add an argument for the generic
	name of an operator procedure and supply it to the expression.
	(gfc_extend_expr, gfc_extend_assign): Use the generic name in
	calls to the above procedures.
	* resolve.c (resolve_typebound_function): Catch procedure
	component calls for CLASS objects, check that the vtable is
	complete and insert the $vptr and procedure components, to make
	the call.
	(resolve_typebound_function): The same.
	* trans-decl.c (gfc_trans_deferred_vars): Do not deallocate
	an allocatable scalar if it is a result.


2010-07-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* gfortran.dg/class_defined_operator_1.f03 : New test.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162313 138bc75d-0d04-0410-961f-82ee72b054a4
---
 gcc/fortran/interface.c | 31 ++++++++++++++++++++-----------
 1 file changed, 20 insertions(+), 11 deletions(-)

(limited to 'gcc/fortran/interface.c')

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 587b09cdf8c..201961d6355 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2779,12 +2779,14 @@ gfc_find_sym_in_symtree (gfc_symbol *sym)
 /* See if the arglist to an operator-call contains a derived-type argument
    with a matching type-bound operator.  If so, return the matching specific
    procedure defined as operator-target as well as the base-object to use
-   (which is the found derived-type argument with operator).  */
+   (which is the found derived-type argument with operator).  The generic
+   name, if any, is transmitted to the final expression via 'gname'.  */
 
 static gfc_typebound_proc*
 matching_typebound_op (gfc_expr** tb_base,
 		       gfc_actual_arglist* args,
-		       gfc_intrinsic_op op, const char* uop)
+		       gfc_intrinsic_op op, const char* uop,
+		       const char ** gname)
 {
   gfc_actual_arglist* base;
 
@@ -2850,6 +2852,7 @@ matching_typebound_op (gfc_expr** tb_base,
 		if (matches)
 		  {
 		    *tb_base = base->expr;
+		    *gname = g->specific_st->name;
 		    return g->specific;
 		  }
 	      }
@@ -2868,11 +2871,12 @@ matching_typebound_op (gfc_expr** tb_base,
 
 static void
 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
-			     gfc_expr* base, gfc_typebound_proc* target)
+			     gfc_expr* base, gfc_typebound_proc* target,
+			     const char *gname)
 {
   e->expr_type = EXPR_COMPCALL;
   e->value.compcall.tbp = target;
-  e->value.compcall.name = "operator"; /* Should not matter.  */
+  e->value.compcall.name = gname ? gname : "$op";
   e->value.compcall.actual = actual;
   e->value.compcall.base_object = base;
   e->value.compcall.ignore_pass = 1;
@@ -2898,6 +2902,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   gfc_namespace *ns;
   gfc_user_op *uop;
   gfc_intrinsic_op i;
+  const char *gname;
 
   sym = NULL;
 
@@ -2905,6 +2910,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   actual->expr = e->value.op.op1;
 
   *real_error = false;
+  gname = NULL;
 
   if (e->value.op.op2 != NULL)
     {
@@ -2970,7 +2976,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
       /* See if we find a matching type-bound operator.  */
       if (i == INTRINSIC_USER)
 	tbo = matching_typebound_op (&tb_base, actual,
-				     i, e->value.op.uop->name);
+				     i, e->value.op.uop->name, &gname);
       else
 	switch (i)
 	  {
@@ -2978,10 +2984,10 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   case INTRINSIC_##comp: \
   case INTRINSIC_##comp##_OS: \
     tbo = matching_typebound_op (&tb_base, actual, \
-				 INTRINSIC_##comp, NULL); \
+				 INTRINSIC_##comp, NULL, &gname); \
     if (!tbo) \
       tbo = matching_typebound_op (&tb_base, actual, \
-				   INTRINSIC_##comp##_OS, NULL); \
+				   INTRINSIC_##comp##_OS, NULL, &gname); \
     break;
 	    CHECK_OS_COMPARISON(EQ)
 	    CHECK_OS_COMPARISON(NE)
@@ -2992,7 +2998,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
 #undef CHECK_OS_COMPARISON
 
 	    default:
-	      tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
 	      break;
 	  }
 	      
@@ -3003,7 +3009,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
 	  gfc_try result;
 
 	  gcc_assert (tb_base);
-	  build_compcall_for_operator (e, actual, tb_base, tbo);
+	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
 
 	  result = gfc_resolve_expr (e);
 	  if (result == FAILURE)
@@ -3050,6 +3056,9 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   gfc_actual_arglist *actual;
   gfc_expr *lhs, *rhs;
   gfc_symbol *sym;
+  const char *gname;
+
+  gname = NULL;
 
   lhs = c->expr1;
   rhs = c->expr2;
@@ -3085,7 +3094,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
       /* See if we find a matching type-bound assignment.  */
       tbo = matching_typebound_op (&tb_base, actual,
-				   INTRINSIC_ASSIGN, NULL);
+				   INTRINSIC_ASSIGN, NULL, &gname);
 	      
       /* If there is one, replace the expression with a call to it and
 	 succeed.  */
@@ -3093,7 +3102,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 	{
 	  gcc_assert (tb_base);
 	  c->expr1 = gfc_get_expr ();
-	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
 	  c->expr1->value.compcall.assign = 1;
 	  c->expr2 = NULL;
 	  c->op = EXEC_COMPCALL;
-- 
cgit v1.2.1