+2009-06-16 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-16 Tobias Burnus <burnus@net-b.de>
PR fortran/40383
/* 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)
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;
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,
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)
}
-/* 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.
/* '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). */
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)
{
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;
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)
{
if (actual->ts.type == BT_PROCEDURE)
{
- if (formal->attr.flavor != FL_PROCEDURE)
- goto proc_fail;
-
- if (formal->attr.function
- && !compare_type_rank (formal, actual->symtree->n.sym))
- goto proc_fail;
+ char err[200];
- 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)
}
/* 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);
+2009-06-16 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.
+
2009-06-16 Ira Rosen <irar@il.ibm.com>
* gcc.dg/vect/vect-outer-4g.c: Don't look for pattern not allowed
end function f
end interface
end subroutine s1
+ subroutine s2(x)
+ integer :: x
+ end subroutine
end module m1
use 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
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
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
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 )
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
!
! 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
integer, intent(in), optional:: x
end subroutine
end interface
- print *, "In test(), about to call sub()"
call sub()
end subroutine
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
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" } }
--- /dev/null
+! { 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" } }
+
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" } }
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" } }
end function p3
end interface
- pptr => add ! { dg-error "Interfaces don't match" }
+ pptr => add ! { dg-error "is not a subroutine" }
q => add
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
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
OSDN Git Service
