2013-12-04 Tobias Burnus <burnus@net-b.de>
PR fortran/59103
PR fortran/58676
PR fortran/41724
* resolve.c (gfc_resolve_intrinsic): Set elemental/pure.
(resolve_symbol): Reject pure dummy procedures/procedure
pointers.
(gfc_explicit_interface_required): Don't require a
match of ELEMENTAL for intrinsics.
2013-12-04 Tobias Burnus <burnus@net-b.de>
PR fortran/59103
PR fortran/58676
PR fortran/41724
* gfortran.dg/elemental_subroutine_8.f90: New.
* gfortran.dg/proc_decl_9.f90: Add ELEMENTAL to make valid.
* gfortran.dg/proc_ptr_11.f90: Ditto.
* gfortran.dg/proc_ptr_result_8.f90: Ditto.
* gfortran.dg/proc_ptr_32.f90: Update dg-error.
* gfortran.dg/proc_ptr_33.f90: Ditto.
* gfortran.dg/proc_ptr_result_1.f90: Add abstract interface
which is not elemental.
* gfortran.dg/proc_ptr_result_7.f90: Ditto.
@@ -1679,6 +1679,9 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
gfc_copy_formal_args_intr (sym, isym);
+ sym->attr.pure = isym->pure;
+ sym->attr.elemental = isym->elemental;
+
/* Check it is actually available in the standard settings. */
if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
{
@@ -2314,7 +2317,7 @@ gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len)
}
}
- if (sym->attr.elemental) /* (4) */
+ if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */
{
strncpy (errmsg, _("elemental procedure"), err_len);
return true;
@@ -12757,6 +12760,23 @@ resolve_symbol (gfc_symbol *sym)
&& !resolve_procedure_interface (sym))
return;
+ /* F2008, C1218. */
+ if (sym->attr.flavor == FL_PROCEDURE && sym->attr.elemental)
+ {
+ if (sym->attr.proc_pointer)
+ {
+ gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ if (sym->attr.dummy)
+ {
+ gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
if (sym->attr.is_protected && !sym->attr.proc_pointer
&& (sym->attr.procedure || sym->attr.external))
{
@@ -1,7 +1,7 @@
! { dg-do run }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
-real function t(x)
+elemental real function t(x)
real, intent(in) ::x
t = x
end function
@@ -9,6 +9,6 @@ end function
program p
implicit none
intrinsic sin
- procedure(sin):: t
+ procedure(sin) :: t
if (t(1.0) /= 1.0) call abort
end program
@@ -48,13 +48,13 @@ program bsp
contains
- function add( a, b )
+ pure function add( a, b )
integer :: add
integer, intent( in ) :: a, b
add = a + b
end function add
- integer function f(x)
+ pure integer function f(x)
integer,intent(in) :: x
f = 317 + x
end function
@@ -5,8 +5,8 @@
! Contributed by James Van Buskirk
implicit none
- procedure(my_dcos), pointer :: f
- f => my_dcos ! { dg-error "invalid in procedure pointer assignment" }
+ procedure(my_dcos), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" }
+ f => my_dcos ! { dg-error "Nonintrinsic elemental procedure 'my_dcos' is invalid in procedure pointer assignment" }
contains
real elemental function my_dcos(x)
real, intent(in) :: x
@@ -22,7 +22,7 @@ end module
program start
use funcs
implicit none
- procedure(fun), pointer :: f
+ procedure(fun), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" }
real x(3)
x = [1,2,3]
f => my_dcos ! { dg-error "Mismatch in PURE attribute" }
@@ -171,7 +171,13 @@ contains
end function
function l()
- procedure(iabs),pointer :: l
+ ! we cannot use iabs directly as it is elemental
+ abstract interface
+ pure function interf_iabs(x)
+ integer, intent(in) :: x
+ end function interf_iabs
+ end interface
+ procedure(interf_iabs),pointer :: l
integer :: i
l => iabs
if (l(-11)/=11) call abort()
@@ -9,7 +9,14 @@ type :: t
end type
type(t) :: x
-procedure(iabs), pointer :: pp
+
+! We cannot use "iabs" directly as it is elemental.
+abstract interface
+ pure integer function interf_iabs(x)
+ integer, intent(in) :: x
+ end function interf_iabs
+end interface
+procedure(interf_iabs), pointer :: pp
x%p => a
@@ -20,7 +27,7 @@ if (pp(-3) /= 3) call abort
contains
function a() result (b)
- procedure(iabs), pointer :: b
+ procedure(interf_iabs), pointer :: b
b => iabs
end function
@@ -26,7 +26,14 @@ type :: t
end type
type(t) :: x
-procedure(iabs), pointer :: pp
+! We cannot use iabs directly as it is elemental
+abstract interface
+ integer pure function interf_iabs(x)
+ integer, intent(in) :: x
+ end function interf_iabs
+end interface
+
+procedure(interf_iabs), pointer :: pp
procedure(foo), pointer :: pp1
x%p => a ! ok
@@ -47,7 +54,7 @@ contains
function a (c) result (b)
integer, intent(in) :: c
- procedure(iabs), pointer :: b
+ procedure(interf_iabs), pointer :: b
if (c .eq. 1) then
b => iabs
else
@@ -55,7 +62,7 @@ contains
end if
end function
- integer function foo (arg)
+ pure integer function foo (arg)
integer, intent (in) :: arg
foo = -iabs(arg)
end function
new file mode 100644
@@ -0,0 +1,50 @@
+! { dg-do compile }
+!
+! PR fortran/58099
+!
+! See also interpretation request F03-0130 in 09-217 and 10-006T5r1.
+!
+! - ELEMENTAL is only permitted for external names with PROCEDURE/INTERFACE
+! but not for dummy arguments or proc-pointers
+! - Using PROCEDURE with an elemental intrinsic as interface name a is valid,
+! but doesn't make the proc-pointer/dummy argument elemental
+!
+
+ interface
+ elemental real function x(y)
+ real, intent(in) :: y
+ end function x
+ end interface
+ intrinsic :: sin
+ procedure(x) :: xx1 ! OK
+ procedure(x), pointer :: xx2 ! { dg-error "Procedure pointer 'xx2' at .1. shall not be elemental" }
+ procedure(real), pointer :: pp
+ procedure(sin) :: bar ! OK
+ procedure(sin), pointer :: foo ! { dg-error "Procedure pointer 'foo' at .1. shall not be elemental" }
+ pp => sin !OK
+contains
+ subroutine sub1(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" }
+ procedure(x) :: z
+ end subroutine sub1
+ subroutine sub2(z) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" }
+ procedure(x), pointer :: z
+ end subroutine sub2
+ subroutine sub3(z)
+ interface
+ elemental real function z(y) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" }
+ real, intent(in) :: y
+ end function z
+ end interface
+ end subroutine sub3
+ subroutine sub4(z)
+ interface
+ elemental real function z(y) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" }
+ real, intent(in) :: y
+ end function z
+ end interface
+ pointer :: z
+ end subroutine sub4
+ subroutine sub5(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" }
+ procedure(sin) :: z
+ end subroutine sub5
+end