This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[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: gfortran <fortran at gcc dot gnu dot org>, gcc patches <gcc-patches at gcc dot gnu dot org>, Walter Spector <w6ws at earthlink dot net>, Paul Thomas <paul dot richard dot thomas at gmail dot com>
- Date: Fri, 22 May 2009 15:51:12 +0200
- Subject: [Patch, Fortran] PR 36947/40039: Better error messages for dummy procedures and check for OPTIONAL
Hi all,
here is my second patch for the PRs 36947/40039 (both dealing with
checks for dummy procedures). After my first patch implemented a check
for INTENTs, this follow-up adds a check for OPTIONAL and improves the
error messages: Instead of simply saying that the interfaces don't
match ("Type/rank mismatch in argument ..."), we now give a
description of where exactly the interfaces differ. This has the
effect that for quite a number of test cases the error messages have
changed.
To accomplish the improved error messages, I added a new argument to
'gfc_check_interfaces', which returns a string describing the error. I
also removed the function 'operator_correspondence', which is only
called from one place in 'gfc_check_interfaces', where I now put the
code directly, because this makes it easier to handle the error
messages.
Moreover, I think I found two invalid test cases in our test suite:
dummy_procedure_1 and ..._2. Both involve the case where a dummy
procedure has an explicit interface, but the actual argument has an
implicit interface, which I believe is invalid, due to the following
passage from F2003 section 12.4.1.3:
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, ...
If the actual arg has an implicit interface, the characterics can not
be verified to match, so I believe it should be rejected. This is
different from the case where the formal arg has an implicit interface
(in this case the actual arg can have an arbitrary interface, explicit
or not). Both test cases were added in r114296 by pault as a fix for
PR25147. However, no justification or reference to the standard was
given.
The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
Cheers,
Janus
2009-05-22 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. Some rearrangement.
(check_interface1): Call 'gfc_compare_interfaces' without error message.
(compare_parameter): Call 'gfc_compare_interfaces' with error message.
Implement stricter checking.
* resolve.c (check_generic_tbp_ambiguity): Call 'gfc_compare_interfaces'
without error message.
2009-05-22 Janus Weil <janus@gcc.gnu.org>
PR fortran/36947
PR fortran/40039
* gfortran.dg/dummy_procedure_1.f90: Corrected and extended.
* gfortran.dg/dummy_procedure_2.f90: Corrected invalid 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/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.
Index: gcc/testsuite/gfortran.dg/proc_decl_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_7.f90 (revision 147794)
+++ 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 147794)
+++ 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 147794)
+++ 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 147794)
+++ 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 147794)
+++ 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/dummy_procedure_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/dummy_procedure_2.f90 (revision 147794)
+++ gcc/testsuite/gfortran.dg/dummy_procedure_2.f90 (working copy)
@@ -27,8 +27,8 @@ contains
print *,integrate (f,0d0,3d0) ! { dg-error "Expected a procedure" }
end subroutine foo1
subroutine foo2 ()
- real(8), external :: g ! This would give an error, incorrectly.
- print *,integrate (g,0d0,3d0)
+ real(8), external :: g
+ print *,integrate (g,0d0,3d0) ! { dg-error "must be explicit" }
end subroutine foo2
end
! { dg-final { cleanup-modules "integrator" } }
Index: gcc/testsuite/gfortran.dg/interface_21.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_21.f90 (revision 147794)
+++ 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 147794)
+++ 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 147794)
+++ 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 147794)
+++ 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
@@ -36,8 +39,9 @@ end module m1
call s1(i) ! { dg-error "Expected a procedure for argument" }
call s1(w) ! { dg-error "not allowed as an actual argument" }
call s1(x) ! explicit interface
- call s1(y) ! declared external
+ call s1(y) ! { dg-error "must be explicit" }
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 147794)
+++ 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 147794)
+++ gcc/fortran/interface.c (working copy)
@@ -777,7 +777,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)
@@ -868,45 +868,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.
@@ -967,17 +928,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)
{
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)
+ sprintf (errmsg, "'%s' is not a function", s2->name);
+ return 0;
+ }
+
+ if (s1->attr.subroutine && s2->attr.function)
+ {
+ if (errmsg != NULL)
+ sprintf (errmsg, "'%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). */
@@ -987,7 +960,12 @@ 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)
+ sprintf (errmsg, "Type/kind mismatch in return value of '%s'",
+ s2->name);
+ return 0;
+ }
if (s1->attr.if_source == IFSRC_DECL)
return 1;
}
@@ -995,14 +973,18 @@ gfc_compare_interfaces (gfc_symbol *s1,
if (s1->attr.if_source == IFSRC_UNKNOWN)
return 1;
+ if (s2->attr.if_source == IFSRC_UNKNOWN)
+ {
+ if (errmsg != NULL)
+ sprintf (errmsg, "Interface of '%s' must be explicit", s2->name);
+ return 0;
+ }
+
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)
{
@@ -1010,9 +992,57 @@ 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)
+ sprintf (errmsg, "'%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)
+ sprintf (errmsg, "Type/rank mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ /* Check INTENT. */
+ if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+ {
+ sprintf (errmsg, "INTENT mismatch in argument '%s'", f1->sym->name);
+ return 0;
+ }
+
+ /* Check OPTIONAL. */
+ if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
+ {
+ sprintf (errmsg, "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)
+ sprintf (errmsg, "Interface not matching");
+ return 0;
}
return 1;
@@ -1090,7 +1120,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))
{
if (referenced)
{
@@ -1361,27 +1391,22 @@ 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)
+ {
+ 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))
+ {
+ 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 147794)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2567,7 +2567,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 *);
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 147794)
+++ gcc/fortran/expr.c (working copy)
@@ -3137,6 +3137,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)
@@ -3176,10 +3177,10 @@ 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))
{
- 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 147794)
+++ gcc/fortran/resolve.c (working copy)
@@ -8591,7 +8591,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))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);