This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 11 Nov 2007 20:24:00 -0800
- Subject: [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements
:ADDPATCH fortran:
This patch allows intrinsics in PROCEDURE statements by removing the error call
in decl.c and adding the necessary checks and resolving the interfaces. This is
the last part to fixing this PR.
It has taken some time to get to this point, so I thought it best to get this
out for review and testing with real code.
I think the explanation in the ChangeLog is sufficient.
Thanks to Janus Weil for several off list comments, now resolved.
Regression tested on x86-64. New test cases provided. One error condition in
proc_decl_1.f90 is no longer an error, so that test is modified. See attached.
OK for trunk?
Regards,
Jerry
2007-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/33162
* decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
PROCEDURE declarations. Set attr.untyped to allow the interface to be
resolved later where the symbol type will be set.
* interface.c (compare_intr_interfaces): Remove static from pointer
declarations. Add type and kind checks for dummy function arguments.
(compare_actual_formal_intr): New function to compare an actual
argument with an intrinsic function. (gfc_procedures_use): Add check for
interface that points to an intrinsic function, use the new function.
* resolve.c (resolve_specific_f0): Resolve the intrinsic interface.
(resolve_specific_s0): Ditto.
Index: interface.c
===================================================================
--- interface.c (revision 130085)
+++ interface.c (working copy)
@@ -977,13 +977,25 @@ compare_interfaces (gfc_symbol *s1, gfc_
static int
compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
{
- static gfc_formal_arglist *f, *f1;
- static gfc_intrinsic_arg *fi, *f2;
+ gfc_formal_arglist *f, *f1;
+ gfc_intrinsic_arg *fi, *f2;
gfc_intrinsic_sym *isym;
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
+
+ /* If the arguments are functions, check type and kind. */
+
+ if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+ {
+ if (s1->ts.type != s2->ts.type)
+ return 0;
+ if (s1->ts.kind != s2->ts.kind)
+ return 0;
+ if (s1->attr.if_source == IFSRC_DECL)
+ return 1;
+ }
isym = gfc_find_function (s2->name);
@@ -1024,6 +1036,55 @@ compare_intr_interfaces (gfc_symbol *s1,
}
+/* Compare an actual argument list with an intrinsic argument list. */
+
+static int
+compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
+{
+ gfc_actual_arglist *a;
+ gfc_intrinsic_arg *fi, *f2;
+ gfc_intrinsic_sym *isym;
+
+ isym = gfc_find_function (s2->name);
+
+ /* This should already have been checked in
+ resolve.c (resolve_actual_arglist). */
+ gcc_assert (isym);
+
+ f2 = isym->formal;
+
+ /* Special case. */
+ if (*ap == NULL && f2 == NULL)
+ return 1;
+
+ /* First scan through the actual argument list and check the intrinsic. */
+ fi = f2;
+ for (a = *ap; a; a = a->next)
+ {
+ if (fi == NULL)
+ return 0;
+ if ((fi->ts.type != a->expr->ts.type)
+ || (fi->ts.kind != a->expr->ts.kind))
+ return 0;
+ fi = fi->next;
+ }
+
+ /* Now scan through the intrinsic argument list and check the formal. */
+ a = *ap;
+ for (fi = f2; fi; fi = fi->next)
+ {
+ if (a == NULL)
+ return 0;
+ if ((fi->ts.type != a->expr->ts.type)
+ || (fi->ts.kind != a->expr->ts.kind))
+ return 0;
+ a = a->next;
+ }
+
+ return 1;
+}
+
+
/* Given a pointer to an interface pointer, remove duplicate
interfaces and make sure that all symbols are either functions or
subroutines. Returns nonzero if something goes wrong. */
@@ -2225,6 +2286,20 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
sym->name, where);
+ if (sym->interface && sym->interface->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (sym->interface->name);
+ if (isym != NULL)
+ {
+ if (compare_actual_formal_intr (ap, sym->interface))
+ return;
+ gfc_error ("My Type/rank mismatch in argument '%s' at %L",
+ sym->name, where);
+ return;
+ }
+ }
+
if (sym->attr.if_source == IFSRC_UNKNOWN
|| !compare_actual_formal (ap, sym->formal, 0,
sym->attr.elemental, where))
Index: decl.c
===================================================================
--- decl.c (revision 130085)
+++ decl.c (working copy)
@@ -3968,19 +3968,9 @@ match_procedure_decl (void)
"in PROCEDURE statement at %C", proc_if->name);
return MATCH_ERROR;
}
- /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
- (proc_if->name, 0) after PR33162 is fixed. */
- if (proc_if->attr.intrinsic)
- {
- gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
- "in PROCEDURE statement at %C not yet implemented "
- "in gfortran", proc_if->name);
- return MATCH_ERROR;
- }
}
got_ts:
-
if (gfc_match (" )") != MATCH_YES)
{
gfc_current_locus = entry_loc;
@@ -3995,7 +3985,6 @@ got_ts:
/* Get procedure symbols. */
for(num=1;;num++)
{
-
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_NO)
goto syntax;
@@ -4040,7 +4029,10 @@ got_ts:
/* Set interface. */
if (proc_if != NULL)
- sym->interface = proc_if;
+ {
+ sym->interface = proc_if;
+ sym->attr.untyped = 1;
+ }
else if (current_ts.type != BT_UNKNOWN)
{
sym->interface = gfc_new_symbol ("", gfc_current_ns);
Index: ChangeLog
===================================================================
--- ChangeLog (revision 130095)
+++ ChangeLog (working copy)
@@ -1,3 +1,17 @@
+2007-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/33162
+ * decl.c (match_procedure_decl): Remove TODO and allow intrinsics in
+ PROCEDURE declarations. Set attr.untyped to allow the interface to be
+ resolved later where the symbol type will be set.
+ * interface.c (compare_intr_interfaces): Remove static from pointer
+ declarations. Add type and kind checks for dummy function arguments.
+ (compare_actual_formal_intr): New function to compare an actual
+ argument with an intrinsic function. (gfc_procedures_use): Add check for
+ interface that points to an intrinsic function, use the new function.
+ * resolve.c (resolve_specific_f0): Resolve the intrinsic interface.
+ (resolve_specific_s0): Ditto.
+
2007-11-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* trans-common.c: Remove prototype for gfc_get_common.
Index: resolve.c
===================================================================
--- resolve.c (revision 130085)
+++ resolve.c (working copy)
@@ -1074,6 +1074,7 @@ resolve_actual_arglist (gfc_actual_argli
if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
+
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
@@ -1083,6 +1084,7 @@ resolve_actual_arglist (gfc_actual_argli
return FAILURE;
}
sym->ts = isym->ts;
+ sym->attr.intrinsic = 1;
sym->attr.function = 1;
}
goto argument_list;
@@ -1487,6 +1489,22 @@ resolve_specific_f0 (gfc_symbol *sym, gf
{
match m;
+ /* See if we have an intrinsic interface. */
+
+ if (sym->interface != NULL && sym->interface->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (sym->interface->name);
+
+ /* Existance of isym should be checked already. */
+ gcc_assert (isym);
+
+ sym->ts = isym->ts;
+ sym->attr.function = 1;
+ sym->attr.proc = PROC_EXTERNAL;
+ goto found;
+ }
+
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@@ -2513,6 +2531,22 @@ resolve_specific_s0 (gfc_code *c, gfc_sy
{
match m;
+ /* See if we have an intrinsic interface. */
+ if (sym->interface != NULL && !sym->interface->attr.abstract
+ && !sym->interface->attr.subroutine)
+ {
+ gfc_intrinsic_sym *isym;
+
+ isym = gfc_find_function (sym->interface->name);
+
+ /* Existance of isym should be checked already. */
+ gcc_assert (isym);
+
+ sym->ts = isym->ts;
+ sym->attr.function = 1;
+ goto found;
+ }
+
if(sym->attr.is_iso_c)
{
m = gfc_iso_c_sub_interface (c,sym);
! { dg-do compile }
! This tests various error messages for PROCEDURE declarations.
! Contributed by Janus Weil <jaydub66@gmail.com>
module m
abstract interface
subroutine sub()
end subroutine
subroutine sub2() bind(c)
end subroutine
end interface
procedure(), public, private :: a ! { dg-error "was already specified" }
procedure(sub),bind(C) :: a2 ! { dg-error "requires an interface with BIND.C." }
procedure(sub2), public, bind(c, name="myEF") :: e, f ! { dg-error "Multiple identifiers provided with single NAME= specifier" }
procedure(sub2), bind(C, name=""), pointer :: g ! { dg-error "may not have POINTER attribute" }
public:: h
procedure(),public:: h ! { dg-error "was already specified" }
end module m
program prog
interface z
subroutine z1()
end subroutine
subroutine z2(a)
integer :: a
end subroutine
end interface
procedure(z) :: bar ! { dg-error "may not be generic" }
procedure(), allocatable:: b ! { dg-error "PROCEDURE attribute conflicts with ALLOCATABLE attribute" }
procedure(), save:: c ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" }
procedure(dcos) :: my1
procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" }
procedure(),pointer:: ptr ! { dg-error "not yet implemented" }
type t
procedure(),pointer:: p ! { dg-error "not yet implemented" }
end type
real f, x
f(x) = sin(x**2)
external oo
procedure(f) :: q ! { dg-error "may not be a statement function" }
procedure(oo) :: p ! { dg-error "must be explicit" }
contains
subroutine foo(a,c)
abstract interface
subroutine b() bind(C)
end subroutine b
end interface
procedure(b), bind(c,name="hjj") :: a ! { dg-error "may not have BIND.C. attribute with NAME" }
procedure(c),intent(in):: c ! { dg-error "PROCEDURE attribute conflicts with INTENT attribute" }
end subroutine foo
end program
subroutine abc
procedure() :: abc2
entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
real x
end subroutine
! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
contains
subroutine sub(a)
interface
function a()
real :: a
end function a
end interface
print *, a()
end subroutine sub
end module m
use m
implicit none
intrinsic cos
call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
end
! { dg-final { cleanup-modules "m" } }
! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
contains
subroutine sub(a)
interface
function a(x)
real :: a, x
intent(in) :: x
end function a
end interface
print *, a(4.0)
end subroutine sub
end module m
use m
implicit none
EXTERNAL foo ! interface is undefined
procedure(cos) :: foo ! { dg-error "Duplicate EXTERNAL attribute specified" }
call sub(foo) ! { dg-error "Type/rank mismatch in argument" }
end
! { dg-final { cleanup-modules "m" } }
! { 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)
real ::x
t = x
end function
program p
implicit none
intrinsic sin
procedure(sin):: t
if (t(1.0) /= 1.0) call abort
end program
! { dg-do compile }
! PR33162 INTRINSIC functions as ACTUAL argument
! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
module m
implicit none
interface
double precision function my1(x)
double precision, intent(in) :: x
end function my1
end interface
interface
real(kind=4) function my2(x)
real, intent(in) :: x
end function my2
end interface
interface
real function my3(x, y)
real, intent(in) :: x, y
end function my3
end interface
end module
program test
use m
implicit none
procedure(dcos):: my1 ! { dg-error "Cannot change attributes" }
procedure(cos) :: my2 ! { dg-error "Cannot change attributes" }
procedure(dprod) :: my3 ! { dg-error "Cannot change attributes" }
end program test
! { dg-final { cleanup-modules "m" } }