Skip to content

R
riscv-gcc-1
Commit e9355cc3 by Janus Weil
Options

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
parent 2aa3b677
Showing with 130 additions and 17 deletions
gcc/fortran/ChangeLog
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.
......
gcc/fortran/interface.c
......@@ -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",
......
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/generic_25.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/generic_26.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/generic_27.f90 0 → 100644
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment