This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] PR 36947/40039: Better error messages for dummy procedures and check for OPTIONAL
- From: Janus Weil <janus at gcc dot gnu dot org>
- To: Tobias Burnus <burnus at net-b dot de>
- Cc: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Fri, 12 Jun 2009 17:47:50 +0200
- Subject: Re: [Patch, Fortran] PR 36947/40039: Better error messages for dummy procedures and check for OPTIONAL
- References: <20090525101612.GA26118@net-b.de>
2009/5/25 Tobias Burnus <burnus@net-b.de>:
>> "If the interface of the dummy argument is explicit, the
>> ?characteristics listed in 12.2 shall be the same for the
>> ?associated actual argument and the corresponding dummy argument, ..."
>
> I think passing an actual argument with an implicit interface to
> an explicit-interface dummy is also allowed. If the explicit
> argument were required, the standard had written it explicitly.
Attached is a new version of the patch, which retreats to the old
behaviour in this matter. In addition I fixed a smaller bug that
Tobias reported privately and added another test case. I also made
sure that it still passes the testsuite without failures.
Tobi's other comments I will take care of in a follow-up patch (pure,
elemental, recursive checking etc).
Ok for trunk?
Cheers,
Janus
2009-06-12 Janus Weil <janus@gcc.gnu.org>
PR fortran/36947
PR fortran/40039
* expr.c (gfc_check_pointer_assign): Call 'gfc_compare_interfaces' with
error message.
* gfortran.h (gfc_compare_interfaces): Additional argument.
* interface.c (operator_correspondence): Removed.
(gfc_compare_interfaces): Additional argument to return error message.
Directly use the code from 'operator_correspondence' instead of calling
the function. Check for OPTIONAL. Some rearrangements.
(check_interface1): Call 'gfc_compare_interfaces' without error message.
(compare_parameter): Call 'gfc_compare_interfaces' with error message.
* resolve.c (check_generic_tbp_ambiguity): Call 'gfc_compare_interfaces'
without error message.
2009-06-12 Janus Weil <janus@gcc.gnu.org>
PR fortran/36947
PR fortran/40039
* gfortran.dg/dummy_procedure_1.f90: Extended test case.
* gfortran.dg/interface_20.f90: Modified error messages.
* gfortran.dg/interface_21.f90: Ditto.
* gfortran.dg/interface_26.f90: Ditto.
* gfortran.dg/interface_27.f90: Ditto.
* gfortran.dg/interface_28.f90: Extended test case.
* gfortran.dg/interface_29.f90: New.
* gfortran.dg/proc_decl_7.f90: Modified error messages.
* gfortran.dg/proc_decl_8.f90: Ditto.
* gfortran.dg/proc_ptr_11.f90: Ditto.
* gfortran.dg/proc_ptr_15.f90: Ditto.
> I think some other checks should still be added, e.g.
>
> a) PUREness check (see example below); passing/assigning
> ? a pure to a non-pure dummy/proc-pointer is OK; doing vice versa
> ? is not.
>
> See "12.4.1.3" (dummy-actual arguments)
> ?"If the interface of the dummy argument is explicit,
> ?the characteristics listed in 12.2 shall be the same for the
> ?associated actual argument and the corresponding dummy argument,
> ?except that a pure actual argument may be associated with a dummy
> ?argument that is not pure and an elemental intrinsic actual
> ?procedure may be associated with a dummy procedure (which is
> ?prohibited from being elemental)."
> And also "7.4.2.2" (proc-pointer assignment):
> ?"If proc-pointer-object has an explicit interface, its
> ?characteristics shall be the same as proc-target except that
> ?proc-target may be pure even if proc-pointer-object is not pure
> ?and proc-target may be an elemental intrinsic procedure even
> ?if proc-pointer-object is not elemental."
>
> b) Similarly for ELEMENTAL. For proc-pointer assignments, use the
> ? first example with PURE changed to ELEMENTAL. That non-intrinsic
> ? elementals are not allowed as actual argument, is already checked
> ? for (cf. C1228). Except of the remark in parentheses I could not
> ? find in F2003/F2008 anything which prohibits ELEMENTAL for the
> ? dummy argument; however, the parentheses is normative. Maybe one
> ? should re-check the standard before adding an error check (see
> ? example below).
>
> c) One needs to go recursively over the arguments as the second
> ? example below shows.
>
>
> Tobias
>
>
> PROGRAM PURENESS
> implicit none
> interface
> ?subroutine one(a,b,c,d,e,f,g,h,i)
> ? ?implicit none
> ? ?integer,intent(in) :: a,b,c,d,e,f,g,h,i
> ?end subroutine one
> ?pure subroutine two(a,b,c,d,e,f,g,h,i)
> ? ?implicit none
> ? ?integer,intent(in) :: a,b,c,d,e,f,g,h,i
> ?end subroutine two
> end interface
> procedure(two), pointer :: ptr
> ptr => one ?! Invalid: (pure) => (unpure)
> end program pureness
>
>
> program RecursiveInterface
> ?interface
> ? ?subroutine a(x)
> ? ? ?real :: x
> ? ?end subroutine a
> ? ?subroutine b(a)
> ? ? ?integer :: a
> ? ?end subroutine b
> ? ?subroutine c(f)
> ? ? ?procedure(a) :: f
> ? ?end subroutine c
> ? ?subroutine d(f)
> ? ? ?procedure(b) :: f
> ? ?end subroutine d
> ? ?subroutine e(f)
> ? ? procedure(c) :: f
> ? ?end subroutine e
> ?end interface
> ?call e(d) ! Argument (dummy subroutine) d has an integer argument
> ? ? ? ? ? ?! but e's f expects a real argument
> end program RecursiveInterface
>
>
> interface
> ?elemental subroutine a() ?! Expected: Warning: ELEMENTAL procedure
> ? ? ? ? ? ? ? ? ? ? ? ? ? ?! without arguments
> ?! (Having ELEMENTAL does not make much sense without arguments, but
> ?! ?it is valid)
> ?end subroutine a
> ?subroutine sub(f)
> ? ?interface
> ? ? ?elemental subroutine f(a)
> ? ? ? ?integer,intent(IN) :: a
> ? ? ?end subroutine f
> ? ?end interface
> ! Invalid per 12.4.1.3?
> ! "an elemental intrinsic actual procedure may be associated with
> ! ?a dummy procedure (which is prohibited from being elemental)."
> ! ? ? ? ? ? ? ? ? ? ? ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
> ! Todo: Find it elsewhere in the standard - or in the corrigenda;
> ! ? ? ? other compilers accept it. However, the part above is normative
> ?end subroutine sub
> end interface
> end program elementalCheck
>
Index: gcc/testsuite/gfortran.dg/proc_decl_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_7.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_decl_7.f90 (working copy)
@@ -16,6 +16,6 @@ end module m
use m
implicit none
intrinsic cos
-call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
+call sub(cos) ! { dg-error "wrong number of arguments" }
end
! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (working copy)
@@ -27,7 +27,7 @@ program bsp
end function p3
end interface
- pptr => add ! { dg-error "Interfaces don't match" }
+ pptr => add ! { dg-error "is not a subroutine" }
q => add
@@ -40,11 +40,11 @@ program bsp
p2 => p1
p1 => p2
- p1 => abs ! { dg-error "Interfaces don't match" }
- p2 => abs ! { dg-error "Interfaces don't match" }
+ p1 => abs ! { dg-error "Type/kind mismatch in return value" }
+ p2 => abs ! { dg-error "Type/kind mismatch in return value" }
p3 => dsin
- p3 => sin ! { dg-error "Interfaces don't match" }
+ p3 => sin ! { dg-error "Type/kind mismatch in return value" }
contains
Index: gcc/testsuite/gfortran.dg/interface_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_26.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_26.f90 (working copy)
@@ -37,7 +37,7 @@ CONTAINS
END INTERFACE
INTEGER, EXTERNAL :: UserOp
- res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in argument" }
+ res = UserFunction( a,b, UserOp ) ! { dg-error "Type/kind mismatch in return value" }
if( res .lt. 10 ) then
res = recSum( a, res, UserFunction, UserOp )
Index: gcc/testsuite/gfortran.dg/proc_ptr_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_15.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_ptr_15.f90 (working copy)
@@ -19,10 +19,10 @@ p4 => p2
p6 => p1
! invalid
-p1 => iabs ! { dg-error "Interfaces don't match" }
-p1 => p2 ! { dg-error "Interfaces don't match" }
-p1 => p5 ! { dg-error "Interfaces don't match" }
-p6 => iabs ! { dg-error "Interfaces don't match" }
+p1 => iabs ! { dg-error "Type/kind mismatch in return value" }
+p1 => p2 ! { dg-error "Type/kind mismatch in return value" }
+p1 => p5 ! { dg-error "Type/kind mismatch in return value" }
+p6 => iabs ! { dg-error "Type/kind mismatch in return value" }
contains
Index: gcc/testsuite/gfortran.dg/interface_28.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_28.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_28.f90 (working copy)
@@ -2,7 +2,8 @@
!
! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
!
-! Contributed by Walter Spector <w6ws@earthlink.net>
+! Original test case by Walter Spector <w6ws@earthlink.net>
+! Modified by Janus Weil <janus@gcc.gnu.org>
module testsub
contains
@@ -12,7 +13,6 @@ module testsub
integer, intent(in), optional:: x
end subroutine
end interface
- print *, "In test(), about to call sub()"
call sub()
end subroutine
end module
@@ -20,9 +20,12 @@ end module
module sub
contains
subroutine subActual(x)
- ! actual subroutine's argment is different in intent and optional
- integer, intent(inout):: x
- print *, "In subActual():", x
+ ! actual subroutine's argment is different in intent
+ integer, intent(inout),optional:: x
+ end subroutine
+ subroutine subActual2(x)
+ ! actual subroutine's argment is missing OPTIONAL
+ integer, intent(in):: x
end subroutine
end module
@@ -32,7 +35,8 @@ program interfaceCheck
integer :: a
- call test(subActual) ! { dg-error "Type/rank mismatch in argument" }
+ call test(subActual) ! { dg-error "INTENT mismatch in argument" }
+ call test(subActual2) ! { dg-error "OPTIONAL mismatch in argument" }
end program
! { dg-final { cleanup-modules "sub testsub" } }
Index: gcc/testsuite/gfortran.dg/interface_21.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_21.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_21.f90 (working copy)
@@ -18,5 +18,5 @@ end module m
use m
implicit none
EXTERNAL foo ! implicit interface is undefined
-call sub(foo) ! { dg-error "Type/rank mismatch in argument" }
+call sub(foo) ! { dg-error "is not a function" }
end
Index: gcc/testsuite/gfortran.dg/proc_decl_8.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_8.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/proc_decl_8.f90 (working copy)
@@ -20,6 +20,6 @@ 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" }
+call sub(foo) ! { dg-error "is not a function" }
end
! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/interface_27.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_27.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_27.f90 (working copy)
@@ -31,8 +31,8 @@ subroutine caller
end interface
pointer :: p
- call a(4.3,func) ! { dg-error "Type/rank mismatch in argument" }
- p => func ! { dg-error "Interfaces don't match in procedure pointer assignment" }
+ call a(4.3,func) ! { dg-error "INTENT mismatch in argument" }
+ p => func ! { dg-error "INTENT mismatch in argument" }
end subroutine
end module
Index: gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 (working copy)
@@ -21,6 +21,9 @@ contains
end function f
end interface
end subroutine s1
+ subroutine s2(x)
+ integer :: x
+ end subroutine
end module m1
use m1
@@ -38,6 +41,7 @@ end module m1
call s1(x) ! explicit interface
call s1(y) ! declared external
call s1(z) ! { dg-error "Expected a procedure for argument" }
+ call s2(x) ! { dg-error "Invalid procedure argument" }
contains
integer function w()
w = 1
Index: gcc/testsuite/gfortran.dg/interface_20.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_20.f90 (revision 148430)
+++ gcc/testsuite/gfortran.dg/interface_20.f90 (working copy)
@@ -16,5 +16,5 @@ end module m
use m
implicit none
intrinsic cos
-call sub(cos) ! { dg-error "Type/rank mismatch in argument" }
+call sub(cos) ! { dg-error "wrong number of arguments" }
end
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 148430)
+++ gcc/fortran/interface.c (working copy)
@@ -778,7 +778,7 @@ bad_repl:
Since this test is asymmetric, it has to be called twice to make it
symmetric. Returns nonzero if the argument lists are incompatible
by this test. This subroutine implements rule 1 of section
- 14.1.2.3. */
+ 14.1.2.3 in the Fortran 95 standard. */
static int
count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
@@ -869,45 +869,6 @@ count_types_test (gfc_formal_arglist *f1
}
-/* Perform the abbreviated correspondence test for operators. The
- arguments cannot be optional and are always ordered correctly,
- which makes this test much easier than that for generic tests.
-
- This subroutine is also used when comparing a formal and actual
- argument list when an actual parameter is a dummy procedure, and in
- procedure pointer assignments. In these cases, two formal interfaces must be
- compared for equality which is what happens here. 'intent_flag' specifies
- whether the intents of the arguments are required to match, which is not the
- case for ambiguity checks. */
-
-static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
- int intent_flag)
-{
- for (;;)
- {
- /* Check existence. */
- if (f1 == NULL && f2 == NULL)
- break;
- if (f1 == NULL || f2 == NULL)
- return 1;
-
- /* Check type and rank. */
- if (!compare_type_rank (f1->sym, f2->sym))
- return 1;
-
- /* Check intent. */
- if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
- return 1;
-
- f1 = f1->next;
- f2 = f2->next;
- }
-
- return 0;
-}
-
-
/* Perform the correspondence test in rule 2 of section 14.1.2.3.
Returns zero if no argument is found that satisfies rule 2, nonzero
otherwise.
@@ -968,17 +929,29 @@ generic_correspondence (gfc_formal_argli
/* 'Compare' two formal interfaces associated with a pair of symbols.
We return nonzero if there exists an actual argument list that
- would be ambiguous between the two interfaces, zero otherwise. */
+ would be ambiguous between the two interfaces, zero otherwise.
+ 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
+ required to match, which is not the case for ambiguity checks.*/
int
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
- int intent_flag)
+ int intent_flag, char *errmsg, int err_len)
{
gfc_formal_arglist *f1, *f2;
- if ((s1->attr.function && !s2->attr.function)
- || (s1->attr.subroutine && s2->attr.function))
- return 0;
+ if (s1->attr.function && !s2->attr.function)
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+ return 0;
+ }
+
+ if (s1->attr.subroutine && s2->attr.function)
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+ return 0;
+ }
/* If the arguments are functions, check type and kind
(only for dummy procedures and procedure pointer assignments). */
@@ -988,22 +961,25 @@ gfc_compare_interfaces (gfc_symbol *s1,
if (s1->ts.type == BT_UNKNOWN)
return 1;
if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
- return 0;
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Type/kind mismatch in return value "
+ "of '%s'", s2->name);
+ return 0;
+ }
if (s1->attr.if_source == IFSRC_DECL)
return 1;
}
- if (s1->attr.if_source == IFSRC_UNKNOWN)
+ if (s1->attr.if_source == IFSRC_UNKNOWN
+ || s2->attr.if_source == IFSRC_UNKNOWN)
return 1;
f1 = s1->formal;
f2 = s2->formal;
if (f1 == NULL && f2 == NULL)
- return 1; /* Special case. */
-
- if (count_types_test (f1, f2) || count_types_test (f2, f1))
- return 0;
+ return 1; /* Special case: No arguments. */
if (generic_flag)
{
@@ -1011,9 +987,58 @@ gfc_compare_interfaces (gfc_symbol *s1,
return 0;
}
else
+ /* Perform the abbreviated correspondence test for operators (the
+ arguments cannot be optional and are always ordered correctly).
+ This is also done when comparing interfaces for dummy procedures and in
+ procedure pointer assignments. */
+
+ for (;;)
+ {
+ /* Check existence. */
+ if (f1 == NULL && f2 == NULL)
+ break;
+ if (f1 == NULL || f2 == NULL)
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' has the wrong number of "
+ "arguments", s2->name);
+ return 0;
+ }
+
+ /* Check type and rank. */
+ if (!compare_type_rank (f1->sym, f2->sym))
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ /* Check INTENT. */
+ if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+ {
+ snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ /* Check OPTIONAL. */
+ if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ f1 = f1->next;
+ f2 = f2->next;
+ }
+
+ if (count_types_test (f1, f2) || count_types_test (f2, f1))
{
- if (operator_correspondence (f1, f2, intent_flag))
- return 0;
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Interface not matching");
+ return 0;
}
return 1;
@@ -1091,7 +1116,7 @@ check_interface1 (gfc_interface *p, gfc_
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
+ if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
{
if (referenced)
{
@@ -1362,27 +1387,25 @@ compare_parameter (gfc_symbol *formal, g
if (actual->ts.type == BT_PROCEDURE)
{
- if (formal->attr.flavor != FL_PROCEDURE)
- goto proc_fail;
+ char err[200];
- if (formal->attr.function
- && !compare_type_rank (formal, actual->symtree->n.sym))
- goto proc_fail;
-
- if (formal->attr.if_source == IFSRC_UNKNOWN
- || actual->symtree->n.sym->attr.external)
- return 1; /* Assume match. */
+ if (formal->attr.flavor != FL_PROCEDURE)
+ {
+ if (where)
+ gfc_error ("Invalid procedure argument at %L", &actual->where);
+ return 0;
+ }
- if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
- goto proc_fail;
+ if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err,
+ sizeof(err)))
+ {
+ if (where)
+ gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+ formal->name, &actual->where, err);
+ return 0;
+ }
return 1;
-
- proc_fail:
- if (where)
- gfc_error ("Type/rank mismatch in argument '%s' at %L",
- formal->name, &actual->where);
- return 0;
}
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 148430)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2568,7 +2568,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_re
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 148430)
+++ gcc/fortran/expr.c (working copy)
@@ -3142,6 +3142,7 @@ gfc_check_pointer_assign (gfc_expr *lval
/* Checks on rvalue for procedure pointer assignments. */
if (proc_pointer)
{
+ char err[200];
attr = gfc_expr_attr (rvalue);
if (!((rvalue->expr_type == EXPR_NULL)
|| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
@@ -3181,10 +3182,11 @@ gfc_check_pointer_assign (gfc_expr *lval
return SUCCESS;
if (rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0, 1))
+ rvalue->symtree->n.sym, 0, 1, err,
+ sizeof(err)))
{
- gfc_error ("Interfaces don't match "
- "in procedure pointer assignment at %L", &rvalue->where);
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: %s", &rvalue->where, err);
return FAILURE;
}
return SUCCESS;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 148430)
+++ gcc/fortran/resolve.c (working copy)
@@ -8593,7 +8593,7 @@ check_generic_tbp_ambiguity (gfc_tbp_gen
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1, 0))
+ if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
! { dg-do compile }
!
! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
!
! Contributed by Tobias Burnus <burnus@net-b.de>
module m
interface foo
module procedure one, two
end interface foo
contains
subroutine one(op,op2)
interface
subroutine op(x, y)
complex, intent(in) :: x(:)
complex, intent(out) :: y(:)
end subroutine op
subroutine op2(x, y)
complex, intent(in) :: x(:)
complex, intent(out) :: y(:)
end subroutine op2
end interface
end subroutine one
subroutine two(ops,i,j)
interface
subroutine op(x, y)
complex, intent(in) :: x(:)
complex, intent(out) :: y(:)
end subroutine op
end interface
real :: i,j
end subroutine two
end module m
module test
contains
subroutine bar()
use m
call foo(precond_prop,prop2)
end subroutine bar
subroutine precond_prop(x, y)
complex, intent(in) :: x(:)
complex, intent(out) :: y(:)
end subroutine
subroutine prop2(x, y)
complex, intent(in) :: x(:)
complex, intent(out) :: y(:)
end subroutine
end module test
! { dg-final { cleanup-modules "m" } }