git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/54285 ([F03] Calling a PPC with proc-ptr result) 

2012-09-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54285
	* expr.c (gfc_check_pointer_assign): Correctly handle procedure pointers
	as function results.
	* primary.c (gfc_match_varspec): Allow to call a PPC with proc-ptr
	result.

2012-09-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54285
	* gfortran.dg/proc_ptr_result_7.f90: New.

From-SVN: r191383
This commit is contained in:
Janus Weil 2012-09-17 14:50:34 +02:00
parent 640a4c59ed
commit a4a76e5242
5 changed files with 52 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2012-09-17 Janus Weil <janus@gcc.gnu.org>
PR fortran/54285
* expr.c (gfc_check_pointer_assign): Correctly handle procedure pointers
as function results.
* primary.c (gfc_match_varspec): Allow to call a PPC with proc-ptr
result.
2012-09-17 Tobias Burnus <burnus@net-b.de> 2012-09-17 Tobias Burnus <burnus@net-b.de>
PR fortran/54603 PR fortran/54603

12
gcc/fortran/expr.c
View File

@ -3513,8 +3513,16 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
comp = gfc_get_proc_ptr_comp (rvalue); comp = gfc_get_proc_ptr_comp (rvalue);
if (comp) if (comp)
{ {
s2 = comp->ts.interface; if (rvalue->expr_type == EXPR_FUNCTION)
name = comp->name; {
s2 = comp->ts.interface->result;
name = comp->ts.interface->result->name;
}
else
{
s2 = comp->ts.interface;
name = comp->name;
}
} }
else if (rvalue->expr_type == EXPR_FUNCTION) else if (rvalue->expr_type == EXPR_FUNCTION)
{ {

5
gcc/fortran/primary.c
View File

@ -2004,8 +2004,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
primary->ts = component->ts; primary->ts = component->ts;
if (component->attr.proc_pointer && ppc_arg if (component->attr.proc_pointer && ppc_arg)
&& !gfc_matching_procptr_assignment)
{ {
/* Procedure pointer component call: Look for argument list. */ /* Procedure pointer component call: Look for argument list. */
m = gfc_match_actual_arglist (sub_flag, m = gfc_match_actual_arglist (sub_flag,
@ -2014,7 +2013,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
return MATCH_ERROR; return MATCH_ERROR;
if (m == MATCH_NO && !gfc_matching_ptr_assignment if (m == MATCH_NO && !gfc_matching_ptr_assignment
&& !matching_actual_arglist) && !gfc_matching_procptr_assignment && !matching_actual_arglist)
{ {
gfc_error ("Procedure pointer component '%s' requires an " gfc_error ("Procedure pointer component '%s' requires an "
"argument list at %C", component->name); "argument list at %C", component->name);

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2012-09-17 Janus Weil <janus@gcc.gnu.org>
PR fortran/54285
* gfortran.dg/proc_ptr_result_7.f90: New.
2012-09-17 Tobias Burnus <burnus@net-b.de> 2012-09-17 Tobias Burnus <burnus@net-b.de>
PR fortran/54603 PR fortran/54603

27
gcc/testsuite/gfortran.dg/proc_ptr_result_7.f90 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do run }
!
! PR 54285: [F03] Calling a PPC with proc-ptr result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type :: t
procedure(a), pointer, nopass :: p
end type
type(t) :: x
procedure(iabs), pointer :: pp
x%p => a
pp => x%p()
if (pp(-3) /= 3) call abort
contains
function a() result (b)
procedure(iabs), pointer :: b
b => iabs
end function
end