* [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements
@ 2007-11-12 8:25 Jerry DeLisle
2007-11-12 9:06 ` Jerry DeLisle
2007-11-13 11:13 ` Tobias Burnus
0 siblings, 2 replies; 3+ messages in thread
From: Jerry DeLisle @ 2007-11-12 8:25 UTC (permalink / raw)
To: Fortran List; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1370 bytes --]
: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.
[-- Attachment #2: pr33162-part3d.diff --]
[-- Type: text/x-patch, Size: 7040 bytes --]
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);
[-- Attachment #3: proc_decl_1.f90 --]
[-- Type: text/x-fortran, Size: 2102 bytes --]
! { 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
[-- Attachment #4: proc_decl_7.f90 --]
[-- Type: text/x-fortran, Size: 470 bytes --]
! { 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" } }
[-- Attachment #5: proc_decl_8.f90 --]
[-- Type: text/x-fortran, Size: 614 bytes --]
! { 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" } }
[-- Attachment #6: proc_decl_9.f90 --]
[-- Type: text/x-fortran, Size: 293 bytes --]
! { 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
[-- Attachment #7: proc_decl_10.f90 --]
[-- Type: text/x-fortran, Size: 803 bytes --]
! { 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" } }
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements
2007-11-12 8:25 [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements Jerry DeLisle
@ 2007-11-12 9:06 ` Jerry DeLisle
2007-11-13 11:13 ` Tobias Burnus
1 sibling, 0 replies; 3+ messages in thread
From: Jerry DeLisle @ 2007-11-12 9:06 UTC (permalink / raw)
To: Fortran List; +Cc: gcc-patches
Jerry DeLisle wrote:
> :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.
There is a spurious "My " in the error message added in gfc_procedure_use. I
have taken care of that. :)
Jerry
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements
2007-11-12 8:25 [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements Jerry DeLisle
2007-11-12 9:06 ` Jerry DeLisle
@ 2007-11-13 11:13 ` Tobias Burnus
1 sibling, 0 replies; 3+ messages in thread
From: Tobias Burnus @ 2007-11-13 11:13 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: Fortran List, gcc-patches
:REVIEWMAIL:
Jerry DeLisle wrote:
> 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 played a bit around and it looks ok. The problem is that there is not
much "real code" as the PROCEDURE feature is quite new and not many
compiler supports it; of my compilers only gfortran and NAG f95 do so -
and NAG seems to have also some small issues.
> Regression tested on x86-64. OK for trunk?
OK with the "My" removed from the error message.
Tobias
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2007-11-13 10:17 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2007-11-12 8:25 [patch,fortran] PR33162 Allow intrinsic functions in PROCEDURE statements Jerry DeLisle
2007-11-12 9:06 ` Jerry DeLisle
2007-11-13 11:13 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).