[Patch, Fortran] PR 42048 & 42167

[Patch, Fortran] PR 42048 & 42167

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 1932 bytes --]

Hi all,

both of the PRs in the subject line deal with the problem of detecting
if a symbol is the return value of an encompassing function.

The simplistic way to do that is to check if the symbol equals the
proc_name of the current ns (which is done in several places throught
the front end). However, it's not that simple in general. Firstly, one
has to deal with internal functions nested in other functions (this
was mostly taken care of already). Second, we now have local
namespaces, e.g. for BLOCK and SELECT TYPE statements, and these might
be arbitrarily nested. So, as a general solution, one has to look
through the current namespace and all its parents, to find out if the
symbol is a function return value. [Note that what I'm talking about
only applies to functions without an explicit result variable.]

To fix the two PRs I created a function which performs the check
described above. Using this function in gfc_match_rvalue fixes
PR42167, and in gfc_match_call it fixes the remaining issues of
PR42048 (comment #4). I also tried to use it in other places where it
does apply, but I'm not sure if I caught all of them.

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-11-25  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  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.

[-- Attachment #2: pr42167_42048.diff --]
[-- Type: application/octet-stream, Size: 5184 bytes --]

Index: gcc/testsuite/gfortran.dg/typebound_call_11.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_11.f03	(revision 154644)
+++ gcc/testsuite/gfortran.dg/typebound_call_11.f03	(working copy)
@@ -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" } }
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 154644)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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 *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 154644)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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, p
 	  /* 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.  */
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 154644)
+++ gcc/fortran/match.c	(working copy)
@@ -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);
 
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 154644)
+++ gcc/fortran/primary.c	(working copy)
@@ -1347,6 +1347,25 @@ gfc_match_literal_constant (gfc_expr **result, int
 }
 
 
+/* 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,
       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

[-- Attachment #3: select_type_10.f03 --]
[-- Type: application/octet-stream, Size: 676 bytes --]

! { 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" } }

Re: [Patch, Fortran] PR 42048 & 42167

[Tobias Burnus]

Janus Weil wrote:
> The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>   

OK - and thanks for the patch. However, please wait with the check a
while; currently, it seems to be undecided whether the patch
http://gcc.gnu.org/ml/gcc-cvs/2009-11/msg00868.html will be eliminated
from the SVN server (erasing its history), be reverted, or will stay.
(See lengthy threads in gcc@.)

Tobias

PS: When this patch is in, I plan to merge again the trunk into the
fortran-dev branch.

> 2009-11-25  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  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.
>   

Re: [Patch, Fortran] PR 42048 & 42167

[Janus Weil]

>> The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>
> OK - and thanks for the patch.

Thanks for reviewing. Committed as r154679.

Cheers,
Janus


>> 2009-11-25  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  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.
>>
>
>