OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Janus Weil 2009-11-26 20:01:02 +01:00
parent 90dcfecb47
commit 2d71b918d4
8 changed files with 89 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -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

1
gcc/fortran/gfortran.h
View File

@ -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 *);

3
gcc/fortran/match.c
View File

@ -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);

32
gcc/fortran/primary.c
View File

@ -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

7
gcc/fortran/resolve.c
View File

@ -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. */

7
gcc/testsuite/ChangeLog
View File

@ -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

34
gcc/testsuite/gfortran.dg/select_type_10.f03 Normal file
View File

@ -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" } }

8
gcc/testsuite/gfortran.dg/typebound_call_11.f03
View File

@ -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" } }