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

interface.c (compare_pointer, ): Allow passing TARGETs to pointers dummies with intent(in). 

2010-08-15  Tobias Burnus  <burnus@net-b.de>

        * interface.c (compare_pointer, ): Allow passing TARGETs to
        pointers dummies with intent(in).

2010-08-15  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/pointer_target_1.f90: New.
        * gfortran.dg/pointer_target_2.f90: New.
        * gfortran.dg/pointer_target_3.f90: New.

From-SVN: r163262
This commit is contained in:
Tobias Burnus 2010-08-15 17:47:11 +02:00 committed by Tobias Burnus
parent e6c148988c
commit 7d54ef80fe
6 changed files with 88 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View File

@ -1,3 +1,8 @@
2010-08-15 Tobias Burnus <burnus@net-b.de>
* interface.c (compare_pointer, ): Allow passing TARGETs to pointers
dummies with intent(in).
2010-08-15 Daniel Kraft <d@domob.eu> 2010-08-15 Daniel Kraft <d@domob.eu>
PR fortran/45197 PR fortran/45197

16
gcc/fortran/interface.c
View File

@ -1368,6 +1368,11 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
if (formal->attr.pointer) if (formal->attr.pointer)
{ {
attr = gfc_expr_attr (actual); attr = gfc_expr_attr (actual);
/* Fortran 2008 allows non-pointer actual arguments. */
if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
return 2;
if (!attr.pointer) if (!attr.pointer)
return 0; return 0;
} }
@ -2113,6 +2118,17 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0; return 0;
} }
if (a->expr->expr_type != EXPR_NULL
&& (gfc_option.allow_std & GFC_STD_F2008) == 0
&& compare_pointer (f->sym, a->expr) == 2)
{
if (where)
gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
"pointer dummy '%s'", &a->expr->where,f->sym->name);
return 0;
}
/* Fortran 2008, C1242. */ /* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
{ {

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2010-08-15 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/pointer_target_1.f90: New.
* gfortran.dg/pointer_target_2.f90: New.
* gfortran.dg/pointer_target_3.f90: New.
2010-08-15 Daniel Kraft <d@domob.eu> 2010-08-15 Daniel Kraft <d@domob.eu>
PR fortran/45197 PR fortran/45197

20
gcc/testsuite/gfortran.dg/pointer_target_1.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do run }
!
! TARGET actual to POINTER dummy with INTENT(IN)
!
program test
implicit none
integer, target :: a
a = 66
call foo(a)
if (a /= 647) call abort()
contains
subroutine foo(p)
integer, pointer, intent(in) :: p
if (a /= 66) call abort()
if (p /= 66) call abort()
p = 647
if (p /= 647) call abort()
if (a /= 647) call abort()
end subroutine foo
end program test

21
gcc/testsuite/gfortran.dg/pointer_target_2.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! TARGET actual to POINTER dummy with INTENT(IN)
!
program test
implicit none
integer, target :: a
a = 66
call foo(a) ! { dg-error "Fortran 2008: Non-pointer actual argument" }
if (a /= 647) call abort()
contains
subroutine foo(p)
integer, pointer, intent(in) :: p
if (a /= 66) call abort()
if (p /= 66) call abort()
p = 647
if (p /= 647) call abort()
if (a /= 647) call abort()
end subroutine foo
end program test

20
gcc/testsuite/gfortran.dg/pointer_target_3.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do compile }
!
! TARGET actual to POINTER dummy with INTENT(IN)
!
program test
implicit none
integer, target :: a
integer :: b
call foo(a) ! OK
call foo(b) ! { dg-error "must be a pointer" }
call bar(a) ! { dg-error "must be a pointer" }
call bar(b) ! { dg-error "must be a pointer" }
contains
subroutine foo(p)
integer, pointer, intent(in) :: p
end subroutine foo
subroutine bar(p)
integer, pointer :: p
end subroutine bar
end program test