This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, fortran] PR20896 - dummy procedures interfaces
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Dominique Dhumieres <dominiq at lps dot ens dot fr>
- Cc: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 13 Jan 2007 18:36:55 +0100
- Subject: Re: [Patch, fortran] PR20896 - dummy procedures interfaces
- References: <20070103213833.115C15BB46@mailhost.lps.ens.fr>
Dominique,
It is not the way I read 12.4.1.2. My reading is:
1) if it is typed or it is used as a function (I assume it means
something like a=b() within the scoping unit), then it is a function;
2) if it is not typed and used as a subroutine (I assume it means
something like CALL b() within the scoping unit), then it a subroutine;
3) otherwise it will be resolved at the level of the external procedure
to which it is passed as a dummy argument, hence could not be used in a
generic interface.
This is the way that the attached version of the patch does it. In
practical terms, this means that an external procedure without an
explicit interface, within another interface, can only unambiguously be
a function. Thus EXTERNAL P; REAL P is ambiguous with functions,
subroutines and all other EXTERNAL symbols. On the other hand, EXTERNAL
P is ambiguous with any procedure.
Bootstrapped and regtested on IA64/FC5 - OK for trunk and after, >1
week, for 4.2?
Paul
2007-01-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/20896
* interface.c (compare_type_rank_if): If a dummy procedure is
external and explicitly typed, give it the attribute of a
function and do the comparison accordingly. Otherwise, if it
is not typed, it is always ambiguous with another procedure.
(compare_actual_formal): Return zero if either the actual or
the formal argument is external and the types are different.
2007-01-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/20896
* gfortran.dg/interface_10.f90: New test.
* gfortran.dg/interface_11.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 120520)
--- gcc/fortran/interface.c (working copy)
*************** compare_type_rank_if (gfc_symbol * s1, g
*** 452,458 ****
if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
return 0;
! /* At this point, both symbols are procedures. */
if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
|| (s2->attr.function == 0 && s2->attr.subroutine == 0))
return 0;
--- 452,478 ----
if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
return 0;
! /* At this point, both symbols are procedures.
!
! If they are external, they can be identified as functions, by
! the rules of 12.4.1.2, if they have a type. Otherwise, we don't
! know from the interface, since there can be no CALL to establish
! if they are functions or subroutines. In this case, the other
! symbol, being a procedure, is always ambiguous. */
! if (s1->attr.external)
! {
! s1->attr.function = 1;
! if (s1->ts.type == BT_UNKNOWN)
! return 1;
! }
!
! if (s2->attr.external)
! {
! s2->attr.function = 1;
! if (s2->ts.type == BT_UNKNOWN)
! return 1;
! }
!
if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
|| (s2->attr.function == 0 && s2->attr.subroutine == 0))
return 0;
*************** compare_actual_formal (gfc_actual_arglis
*** 1377,1382 ****
--- 1397,1413 ----
return 0;
}
+ if (a->expr->ts.type == BT_PROCEDURE
+ && (a->expr->symtree->n.sym->attr.external
+ || f->sym->attr.external)
+ && compare_type_rank (a->expr->symtree->n.sym, f->sym) == 0)
+ {
+ if (where)
+ gfc_error ("TYPE/RANK mismatch to the dummy procedure '%s' at "
+ "%L", f->sym->name, &a->expr->where);
+ return 0;
+ }
+
if (f->sym->attr.flavor == FL_PROCEDURE
&& f->sym->attr.pure
&& a->expr->ts.type == BT_PROCEDURE
Index: gcc/testsuite/gfortran.dg/interface_10.f90
===================================================================
*** gcc/testsuite/gfortran.dg/interface_10.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/interface_10.f90 (revision 0)
***************
*** 0 ****
--- 1,123 ----
+ ! { dg-do run }
+ ! Tests the fix for PR20896 in which the requirements of
+ ! 12.2.1.2 were not being observed in respect of explicitness.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ !
+ real function foo ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "foo"
+ foo = 1.0
+ end
+ subroutine bar ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "bar"
+ end
+ subroutine s_ext()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "s_ext"
+ end
+ real function f_ext ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "f_ext"
+ f_ext = 1.0
+ end
+ SUBROUTINE s1(p)
+ common // chr(2)
+ character*6 chr
+ INTERFACE
+ SUBROUTINE p
+ END
+ END INTERFACE
+ chr(1) = "s1"
+ call p ()
+ END
+ SUBROUTINE s2(p)
+ common // chr(2)
+ character*6 chr
+ INTERFACE
+ REAL FUNCTION p()
+ END
+ END INTERFACE
+ chr(1) = "s2"
+ x = p ()
+ END
+
+ module mod1
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ INTERFACE
+ function p2 ()
+ real p2
+ END
+ END INTERFACE
+ END
+ SUBROUTINE s1(p1)
+ INTERFACE
+ SUBROUTINE p1
+ END
+ END INTERFACE
+ END
+ END INTERFACE
+ end module mod1
+
+ module mod2
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ external p2
+ real p2
+ END
+ SUBROUTINE s1(p1)
+ INTERFACE
+ SUBROUTINE p1
+ END
+ END INTERFACE
+ END
+ END INTERFACE
+ end module mod2
+
+ program main
+ common // chr(2)
+ character*6 chr
+ external f_ext, s_ext
+ real f_ext
+ INTERFACE
+ REAL FUNCTION foo()
+ END
+ END INTERFACE
+ INTERFACE
+ subroutine bar()
+ END
+ END INTERFACE
+ call test1 ! Both interfaces explicit
+ call test2 ! EXTERNAL function and explicit subroutine
+ contains
+ subroutine test1
+ use mod1
+ call g (f_ext)
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext)
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo)
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar)
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test1
+ subroutine test2
+ use mod2
+ call g (f_ext)
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext)
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo)
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar)
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test2
+ END
+
+ ! { dg-final { cleanup-modules "mod1 mod2" } }
Index: gcc/testsuite/gfortran.dg/interface_11.f90
===================================================================
*** gcc/testsuite/gfortran.dg/interface_11.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/interface_11.f90 (revision 0)
***************
*** 0 ****
--- 1,191 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20896 in which the requirements of
+ ! 12.2.1.2 were not being observed in respect of explicitness.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ !
+ real function foo ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "foo"
+ foo = 1.0
+ end
+ subroutine bar ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "bar"
+ end
+ subroutine s_ext()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "s_ext"
+ end
+ real function f_ext ()
+ common // chr(2)
+ character*6 chr
+ chr(2) = "f_ext"
+ f_ext = 1.0
+ end
+ SUBROUTINE s1(p)
+ common // chr(2)
+ character*6 chr
+ INTERFACE
+ SUBROUTINE p
+ END
+ END INTERFACE
+ chr(1) = "s1"
+ call p ()
+ END
+ SUBROUTINE s2(p)
+ common // chr(2)
+ character*6 chr
+ INTERFACE
+ REAL FUNCTION p()
+ END
+ END INTERFACE
+ chr(1) = "s2"
+ x = p ()
+ END
+
+ module mod1
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ INTERFACE
+ function p2 ()
+ real p2
+ END
+ END INTERFACE
+ END
+ end interface
+ end module mod1
+
+ module mod2
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ external p2 ! Indistinguishable from subroutine
+ END
+ SUBROUTINE s1(p1)
+ INTERFACE
+ SUBROUTINE p1
+ END
+ END INTERFACE
+ END ! { dg-error "Ambiguous interfaces" }
+ END INTERFACE
+ end module mod2
+
+ module mod3
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ interface
+ function p2 ()
+ real p2
+ end
+ end interface
+ END
+ SUBROUTINE s1(p1)
+ external p1
+ real p1
+ END ! { dg-error "Ambiguous interfaces" }
+ END INTERFACE
+ end module mod3
+
+ module mod5
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ interface
+ function p2 ()
+ real p2
+ end
+ end interface
+ END
+ SUBROUTINE s1(p1)
+ external p1
+ END
+ END INTERFACE
+ end module mod5
+
+ module mod6
+ INTERFACE g
+ SUBROUTINE s2(p2)
+ external p2
+ real p2
+ END
+ SUBROUTINE s1(p1)
+ external p1
+ END
+ END INTERFACE
+ end module mod6
+
+ module mod4
+ INTERFACE g
+ SUBROUTINE s1(p1)
+ external p1
+ END
+ END INTERFACE
+ end module mod4
+
+ program main
+ common // chr(2)
+ character*6 chr
+ external f_ext, s_ext
+ real f_ext
+ INTERFACE
+ REAL FUNCTION foo()
+ END
+ END INTERFACE
+ INTERFACE
+ subroutine bar()
+ END
+ END INTERFACE
+ call test1 ! Both interfaces explicit
+ call test4 ! function and subroutine EXTERNAL
+ call test5 ! function and subroutine EXTERNAL
+ call test6 ! function and subroutine EXTERNAL
+ contains
+ subroutine test1
+ use mod1
+ call g (f_ext)
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo)
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test1
+ subroutine test4
+ use mod4
+ call g (f_ext) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext)
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar)
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test4
+ subroutine test5
+ use mod5 ! { dg-error "Ambiguous interfaces" }
+ call g (f_ext)
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo)
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test5
+ subroutine test6
+ use mod6 ! { dg-error "Ambiguous interfaces" }
+ call g (f_ext)
+ if (any (chr .ne. (/"s2 ","f_ext "/))) call abort ()
+ call g (s_ext) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","s_ext "/))) call abort ()
+ call g (foo)
+ if (any (chr .ne. (/"s2 ","foo "/))) call abort ()
+ call g (bar) ! { dg-error "no specific subroutine" }
+ if (any (chr .ne. (/"s1 ","bar "/))) call abort ()
+ end subroutine test6
+ END
+
+ ! { dg-final { cleanup-modules "mod1 mod2 mod3 mod4 mod5 mod6" } }