OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/36947 (Attributes not fully checked comparing actual vs dummy procedure) 

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  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.

From-SVN: r148519
This commit is contained in:
Janus Weil 2009-06-16 11:06:13 +02:00
parent 7c5222ff1a
commit 8ad15a0a8d
17 changed files with 214 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -1,3 +1,19 @@
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

8
gcc/fortran/expr.c
View File

@ -3142,6 +3142,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
/* 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 *lvalue, gfc_expr *rvalue)
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;

2
gcc/fortran/gfortran.h
View File

@ -2567,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
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,

165
gcc/fortran/interface.c
View File

@ -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, 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.
@ -968,17 +929,29 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
/* '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, gfc_symbol *s2, int generic_flag,
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, gfc_symbol *s2, int 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;
@ -1091,7 +1116,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
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, gfc_expr *actual,
if (actual->ts.type == BT_PROCEDURE)
{
char err[200];
if (formal->attr.flavor != FL_PROCEDURE)
goto proc_fail;
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
return 0;
}
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 (!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)

2
gcc/fortran/resolve.c
View File

@ -8593,7 +8593,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
}
/* 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);

16
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,19 @@
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

4
gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/interface_20.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/interface_21.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/interface_26.f90
View File

@ -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 )

4
gcc/testsuite/gfortran.dg/interface_27.f90
View File

@ -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

16
gcc/testsuite/gfortran.dg/interface_28.f90
View File

@ -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" } }

52
gcc/testsuite/gfortran.dg/interface_29.f90 Normal file
View File

@ -0,0 +1,52 @@
! { 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" } }

2
gcc/testsuite/gfortran.dg/proc_decl_7.f90
View File

@ -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" } }

2
gcc/testsuite/gfortran.dg/proc_decl_8.f90
View File

@ -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" } }

8
gcc/testsuite/gfortran.dg/proc_ptr_11.f90
View File

@ -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

8
gcc/testsuite/gfortran.dg/proc_ptr_15.f90
View File

@ -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