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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@154679 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2ca0e24..0572b05 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+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

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 74a31d2..cc3ccf5 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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 *);

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 13f68ab..f6650e7 100644 (file)
--- a/gcc/fortran/match.c
+++ b/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);
 

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index c0777c4..113729f 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 740679e..5048f25 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 73f39a7..b9893da 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/select_type_10.f03 b/gcc/testsuite/gfortran.dg/select_type_10.f03
new file mode 100644 (file)
index 0000000..217d72a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_10.f03
@@ -0,0 +1,34 @@
+! { 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" } }

diff --git a/gcc/testsuite/gfortran.dg/typebound_call_11.f03 b/gcc/testsuite/gfortran.dg/typebound_call_11.f03
index 14f3232..8d7b8f0 100644 (file)
--- a/gcc/testsuite/gfortran.dg/typebound_call_11.f03
+++ b/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" } }