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

re PR fortran/45521 ([F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE) 

2012-10-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* interface.c (generic_correspondence): Implement additional
	distinguishability criteria of F08.
	(compare_actual_formal): Reject data object as actual argument for
	procedure formal argument.

2012-10-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* gfortran.dg/generic_25.f90: New.
	* gfortran.dg/generic_26.f90: New.
	* gfortran.dg/generic_27.f90: New.

From-SVN: r192157
This commit is contained in:
Janus Weil 2012-10-06 14:20:09 +02:00
parent 2aa3b677b1
commit e9355cc32e
6 changed files with 130 additions and 17 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-10-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/45521
* interface.c (generic_correspondence): Implement additional
distinguishability criteria of F08.
(compare_actual_formal): Reject data object as actual argument for
procedure formal argument.
2012-10-04 Tobias Burnus <burnus@net-b.de>
* expr.c (scalarize_intrinsic_call): Plug memory leak.

39
gcc/fortran/interface.c
View File

@ -932,9 +932,9 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
}
/* Perform the correspondence test in rule 3 of section F03:16.2.3.
Returns zero if no argument is found that satisfies rule 3, nonzero
otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
/* Perform the correspondence test in rule (3) of F08:C1215.
Returns zero if no argument is found that satisfies this rule,
nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
(if applicable).
This test is also not symmetric in f1 and f2 and must be called
@ -942,13 +942,13 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
argument list with keywords. For example:
INTERFACE FOO
SUBROUTINE F1(A, B)
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F1(A, B)
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F2(B, A)
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F2(B, A)
INTEGER :: A ; REAL :: B
END SUBROUTINE F1
END INTERFACE FOO
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
@ -973,7 +973,10 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
f2 = f2->next;
if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
|| compare_type_rank (f2->sym, f1->sym)))
|| compare_type_rank (f2->sym, f1->sym))
&& !((gfc_option.allow_std & GFC_STD_F2008)
&& ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
|| (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
goto next;
/* Now search for a disambiguating keyword argument starting at
@ -984,7 +987,10 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
continue;
sym = find_keyword_arg (g->sym->name, f2_save);
if (sym == NULL || !compare_type_rank (g->sym, sym))
if (sym == NULL || !compare_type_rank (g->sym, sym)
|| ((gfc_option.allow_std & GFC_STD_F2008)
&& ((sym->attr.allocatable && g->sym->attr.pointer)
|| (sym->attr.pointer && g->sym->attr.allocatable))))
return 1;
}
@ -2551,8 +2557,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
skip_size_check:
/* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
is provided for a procedure pointer formal argument. */
/* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
argument is provided for a procedure pointer formal argument. */
if (f->sym->attr.proc_pointer
&& !((a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym->attr.proc_pointer)
@ -2566,11 +2572,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
/* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr)
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
if (f->sym->attr.flavor == FL_PROCEDURE
&& gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
{
if (where)
gfc_error ("Expected a procedure for argument '%s' at %L",

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2012-10-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/45521
* gfortran.dg/generic_25.f90: New.
* gfortran.dg/generic_26.f90: New.
* gfortran.dg/generic_27.f90: New.
2012-10-06 Oleg Endo <olegendo@gcc.gnu.org>
PR target/54760

30
gcc/testsuite/gfortran.dg/generic_25.f90 Normal file
View File

@ -0,0 +1,30 @@
! { dg-do run }
!
! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
!
! Contributed by <wangmianzhi1@linuxmail.org>
interface test
procedure testAlloc
procedure testPtr
end interface
integer, allocatable :: a1
integer, pointer :: a2
if (.not.test(a1)) call abort()
if (test(a2)) call abort()
contains
logical function testAlloc(obj)
integer, allocatable :: obj
testAlloc = .true.
end function
logical function testPtr(obj)
integer, pointer :: obj
testPtr = .false.
end function
end

29
gcc/testsuite/gfortran.dg/generic_26.f90 Normal file
View File

@ -0,0 +1,29 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
!
! Contributed by <wangmianzhi1@linuxmail.org>
module a
interface test
procedure testAlloc
procedure testPtr ! { dg-error "Ambiguous interfaces" }
end interface
contains
logical function testAlloc(obj)
integer, allocatable :: obj
testAlloc = .true.
end function
logical function testPtr(obj)
integer, pointer :: obj
testPtr = .false.
end function
end
! { dg-final { cleanup-modules "a" } }

34
gcc/testsuite/gfortran.dg/generic_27.f90 Normal file
View File

@ -0,0 +1,34 @@
! { dg-do run }
!
! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
implicit none
interface testIF
module procedure test1
module procedure test2
end interface
contains
real function test1 (obj)
real :: obj
test1 = obj
end function
real function test2 (pr)
procedure(real) :: pr
test2 = pr(0.)
end function
end module
program test
use m
implicit none
intrinsic :: cos
if (testIF(2.0)/=2.0) call abort()
if (testIF(cos)/=1.0) call abort()
end program
! { dg-final { cleanup-modules "m" } }