re PR fortran/42048 ([F03] Erroneous syntax error message on TBP call)

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

	PR fortran/42048
	PR fortran/42167
	* gfortran.h (gfc_is_function_return_value): New prototype.
	* match.c (gfc_match_call): Use new function
	'gfc_is_function_return_value'.
	* primary.c (gfc_is_function_return_value): New function to check if a
	symbol is the return value of an encompassing function.
	(match_actual_arg,gfc_match_rvalue,match_variable): Use new function
	'gfc_is_function_return_value'.
	* resolve.c (resolve_common_blocks,resolve_actual_arglist): Ditto.

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

	PR fortran/42048
	PR fortran/42167
	* gfortran.dg/select_type_10.f03: New test case.
	* gfortran.dg/typebound_call_11.f03: Extended test case.

From-SVN: r154679

gcc/fortran/ChangeLog

+2009-11-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42048
+	PR fortran/42167
+	* gfortran.h (gfc_is_function_return_value): New prototype.
+	* match.c (gfc_match_call): Use new function
+	'gfc_is_function_return_value'.
+	* primary.c (gfc_is_function_return_value): New function to check if a
+	symbol is the return value of an encompassing function.
+	(match_actual_arg,gfc_match_rvalue,match_variable): Use new function
+	'gfc_is_function_return_value'.
+	* resolve.c (resolve_common_blocks,resolve_actual_arglist): Ditto.
+
 2009-11-25  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/42162

gcc/fortran/gfortran.h

@@ -2751,6 +2751,7 @@ symbol_attribute gfc_expr_attr (gfc_expr *);
 match gfc_match_rvalue (gfc_expr **);
 match gfc_match_varspec (gfc_expr*, int, bool, bool);
 int gfc_check_digit (char, int);
+bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
 
 /* trans.c */
 void gfc_generate_code (gfc_namespace *);

gcc/fortran/match.c

@@ -2975,7 +2975,8 @@ gfc_match_call (void)
 
   /* If this is a variable of derived-type, it probably starts a type-bound
      procedure call.  */
-  if ((sym->attr.flavor != FL_PROCEDURE || sym == gfc_current_ns->proc_name)
+  if ((sym->attr.flavor != FL_PROCEDURE
+       || gfc_is_function_return_value (sym, gfc_current_ns))
       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
     return match_typebound_call (st);
 

gcc/fortran/primary.c

@@ -1347,6 +1347,25 @@ gfc_match_literal_constant (gfc_expr **result, int signflag)
 }
 
 
+/* This checks if a symbol is the return value of an encompassing function.
+   Function nesting can be maximally two levels deep, but we may have
+   additional local namespaces like BLOCK etc.  */
+
+bool
+gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
+{
+  if (!sym->attr.function || (sym->result != sym))
+    return false;
+  while (ns)
+    {
+      if (ns->proc_name == sym)
+	return true;
+      ns = ns->parent;
+    }
+  return false;
+}
+
+
 /* Match a single actual argument value.  An actual argument is
    usually an expression, but can also be a procedure name.  If the
    argument is a single name, it is not always possible to tell
@@ -1415,9 +1434,7 @@ match_actual_arg (gfc_expr **result)
 	     is being defined, then we have a variable.  */
 	  if (sym->attr.function && sym->result == sym)
 	    {
-	      if (gfc_current_ns->proc_name == sym
-		  || (gfc_current_ns->parent != NULL
-		      && gfc_current_ns->parent->proc_name == sym))
+	      if (gfc_is_function_return_value (sym, gfc_current_ns))
 		break;
 
 	      if (sym->attr.entry
@@ -2521,9 +2538,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  return MATCH_ERROR;
 	}
 
-      if (gfc_current_ns->proc_name == sym
-	  || (gfc_current_ns->parent != NULL
-	      && gfc_current_ns->parent->proc_name == sym))
+      if (gfc_is_function_return_value (sym, gfc_current_ns))
 	goto variable;
 
       if (sym->attr.entry
@@ -2998,10 +3013,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
       if (sym->attr.function
           && !sym->attr.external
           && sym->result == sym
-          && ((sym == gfc_current_ns->proc_name
-               && sym == gfc_current_ns->proc_name->result)
-              || (gfc_current_ns->parent
-                  && sym == gfc_current_ns->parent->proc_name->result)
+          && (gfc_is_function_return_value (sym, gfc_current_ns)
               || (sym->attr.entry
                   && sym->ns == gfc_current_ns)
               || (sym->attr.entry

gcc/fortran/resolve.c

@@ -776,7 +776,7 @@ resolve_common_blocks (gfc_symtree *common_root)
     gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
 	       sym->name, &common_root->n.common->where);
   else if (sym->attr.result
-	   ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+	   || gfc_is_function_return_value (sym, gfc_current_ns))
     gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
 		    "that is also a function result", sym->name,
 		    &common_root->n.common->where);
@@ -1400,10 +1400,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  /* If the symbol is the function that names the current (or
 	     parent) scope, then we really have a variable reference.  */
 
-	  if (sym->attr.function && sym->result == sym
-	      && (sym->ns->proc_name == sym
-		  || (sym->ns->parent != NULL
-		      && sym->ns->parent->proc_name == sym)))
+	  if (gfc_is_function_return_value (sym, sym->ns))
 	    goto got_variable;
 
 	  /* If all else fails, see if we have a specific intrinsic.  */

gcc/testsuite/ChangeLog

+2009-11-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42048
+	PR fortran/42167
+	* gfortran.dg/select_type_10.f03: New test case.
+	* gfortran.dg/typebound_call_11.f03: Extended test case.
+
 2009-11-26  Michael Matz  <matz@suse.de>
 
 	PR tree-optimization/41905

gcc/testsuite/gfortran.dg/select_type_10.f03

+! { dg-do compile }
+!
+! PR 42167: [OOP] SELECT TYPE with function return value
+!
+! Contributed by Damian Rouson <damian@rouson.net>
+
+module bar_module
+
+  implicit none
+  type :: bar
+    real ,dimension(:) ,allocatable :: f
+  contains
+    procedure :: total
+  end type
+
+contains
+
+  function total(lhs,rhs)
+    class(bar) ,intent(in) :: lhs
+    class(bar) ,intent(in) :: rhs
+    class(bar) ,pointer :: total
+    select type(rhs)
+      type is (bar)
+        allocate(bar :: total)
+        select type(total)
+          type is (bar)
+            total%f = lhs%f + rhs%f
+        end select
+    end select
+  end function
+
+end module 
+
+! { dg-final { cleanup-modules "bar_module" } }

gcc/testsuite/gfortran.dg/typebound_call_11.f03

@@ -35,6 +35,14 @@ contains
   call new%mesh%new_grid()
  end function
 
+ type(field) function new_field3()
+  call g()
+ contains
+  subroutine g()
+    call new_field3%mesh%new_grid()
+  end subroutine g
+ end function new_field3
+
 end module
 
 ! { dg-final { cleanup-modules "grid_module field_module" } }