Commit 23e38561 by Janus Weil

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

2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* expr.c (gfc_check_pointer_assign): Check intents when comparing
	interfaces.
	* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
	(gfc_compare_interfaces): Additional argument.
	* interface.c (operator_correspondence): Add check for equality of
	intents, and new argument 'intent_check'.
	(gfc_compare_interfaces): New argument 'intent_check', which is passed
	on to operator_correspondence.
	(check_interface1): Don't check intents when comparing interfaces.
	(compare_parameter): Do check intents when comparing interfaces.
	* intrinsic.c (add_sym): Add intents for arguments of intrinsic
	procedures.
	(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
	add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
	default.
	(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
	: New functions to add intrinsic symbols, specifying custom intents.
	(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
	(add_functions,add_subroutines): Add intents for various intrinsics.
	* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
	comparing interfaces.
	* symbol.c (gfc_copy_formal_args_intr): Copy intent.


2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36947
	PR fortran/40039
	* gfortran.dg/interface_27.f90: New.
	* gfortran.dg/interface_28.f90: New.
	* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
	* gfortran.dg/proc_ptr_result_1.f90: Ditto.

From-SVN: r147655
parent 75df395f
2009-05-18 Janus Weil <janus@gcc.gnu.org>
PR fortran/36947
PR fortran/40039
* expr.c (gfc_check_pointer_assign): Check intents when comparing
interfaces.
* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
(gfc_compare_interfaces): Additional argument.
* interface.c (operator_correspondence): Add check for equality of
intents, and new argument 'intent_check'.
(gfc_compare_interfaces): New argument 'intent_check', which is passed
on to operator_correspondence.
(check_interface1): Don't check intents when comparing interfaces.
(compare_parameter): Do check intents when comparing interfaces.
* intrinsic.c (add_sym): Add intents for arguments of intrinsic
procedures.
(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
default.
(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
: New functions to add intrinsic symbols, specifying custom intents.
(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
(add_functions,add_subroutines): Add intents for various intrinsics.
* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
comparing interfaces.
* symbol.c (gfc_copy_formal_args_intr): Copy intent.
2009-05-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 2009-05-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32, * iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32,
......
...@@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) ...@@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS; return SUCCESS;
if (rvalue->expr_type == EXPR_VARIABLE if (rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym, && !gfc_compare_interfaces (lvalue->symtree->n.sym,
rvalue->symtree->n.sym, 0)) rvalue->symtree->n.sym, 0, 1))
{ {
gfc_error ("Interfaces don't match " gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where); "in procedure pointer assignment at %L", &rvalue->where);
......
...@@ -1445,6 +1445,7 @@ typedef struct gfc_intrinsic_arg ...@@ -1445,6 +1445,7 @@ typedef struct gfc_intrinsic_arg
gfc_typespec ts; gfc_typespec ts;
int optional; int optional;
ENUM_BITFIELD (sym_intent) intent:2;
gfc_actual_arglist *actual; gfc_actual_arglist *actual;
struct gfc_intrinsic_arg *next; struct gfc_intrinsic_arg *next;
...@@ -2566,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *); ...@@ -2566,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
void gfc_free_interface (gfc_interface *); void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *); int gfc_compare_types (gfc_typespec *, gfc_typespec *);
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
void gfc_check_interfaces (gfc_namespace *); void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_symbol *gfc_search_interface (gfc_interface *, int,
......
...@@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) ...@@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
which makes this test much easier than that for generic tests. which makes this test much easier than that for generic tests.
This subroutine is also used when comparing a formal and actual This subroutine is also used when comparing a formal and actual
argument list when an actual parameter is a dummy procedure. At argument list when an actual parameter is a dummy procedure, and in
that point, two formal interfaces must be compared for equality procedure pointer assignments. In these cases, two formal interfaces must be
which is what happens here. */ 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 static int
operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
int intent_flag)
{ {
for (;;) for (;;)
{ {
/* Check existence. */
if (f1 == NULL && f2 == NULL) if (f1 == NULL && f2 == NULL)
break; break;
if (f1 == NULL || f2 == NULL) if (f1 == NULL || f2 == NULL)
return 1; return 1;
/* Check type and rank. */
if (!compare_type_rank (f1->sym, f2->sym)) if (!compare_type_rank (f1->sym, f2->sym))
return 1; return 1;
/* Check intent. */
if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
return 1;
f1 = f1->next; f1 = f1->next;
f2 = f2->next; f2 = f2->next;
} }
...@@ -961,7 +970,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) ...@@ -961,7 +970,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
would be ambiguous between the two interfaces, zero otherwise. */ would be ambiguous between the two interfaces, zero otherwise. */
int int
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag) gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
int intent_flag)
{ {
gfc_formal_arglist *f1, *f2; gfc_formal_arglist *f1, *f2;
...@@ -1001,7 +1011,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag) ...@@ -1001,7 +1011,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
} }
else else
{ {
if (operator_correspondence (f1, f2)) if (operator_correspondence (f1, f2, intent_flag))
return 0; return 0;
} }
...@@ -1080,7 +1090,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, ...@@ -1080,7 +1090,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue; continue;
if (gfc_compare_interfaces (p->sym, q->sym, generic_flag)) if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
{ {
if (referenced) if (referenced)
{ {
...@@ -1362,7 +1372,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, ...@@ -1362,7 +1372,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|| actual->symtree->n.sym->attr.external) || actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */ return 1; /* Assume match. */
if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0)) if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
goto proc_fail; goto proc_fail;
return 1; return 1;
......
...@@ -8585,7 +8585,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, ...@@ -8585,7 +8585,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
} }
/* Compare the interfaces. */ /* Compare the interfaces. */
if (gfc_compare_interfaces (sym1, sym2, 1)) if (gfc_compare_interfaces (sym1, sym2, 1, 0))
{ {
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where); sym1->name, sym2->name, generic_name, &where);
......
...@@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) ...@@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
/* May need to copy more info for the symbol. */ /* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts; formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional; formal_arg->sym->attr.optional = curr_arg->optional;
formal_arg->sym->attr.intent = curr_arg->intent;
formal_arg->sym->attr.flavor = FL_VARIABLE; formal_arg->sym->attr.flavor = FL_VARIABLE;
formal_arg->sym->attr.dummy = 1; formal_arg->sym->attr.dummy = 1;
......
2009-05-18 Janus Weil <janus@gcc.gnu.org>
PR fortran/36947
PR fortran/40039
* gfortran.dg/interface_27.f90: New.
* gfortran.dg/interface_28.f90: New.
* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
* gfortran.dg/proc_ptr_result_1.f90: Ditto.
2009-05-18 Maxim Kuvyrkov <maxim@codesourcery.com> 2009-05-18 Maxim Kuvyrkov <maxim@codesourcery.com>
* gcc.target/m68k/tls-ie.c: New test. * gcc.target/m68k/tls-ie.c: New test.
......
! { dg-do compile }
!
! PR 40039: Procedures as actual arguments: Check intent of arguments
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
contains
subroutine a(x,f)
real :: x
interface
real function f(y)
real,intent(in) :: y
end function
end interface
print *,f(x)
end subroutine
real function func(z)
real,intent(inout) :: z
func = z**2
end function
subroutine caller
interface
real function p(y)
real,intent(in) :: y
end function
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" }
end subroutine
end module
! { dg-final { cleanup-modules "m" } }
! { dg-do compile }
!
! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
!
! Contributed by Walter Spector <w6ws@earthlink.net>
module testsub
contains
subroutine test(sub)
interface
subroutine sub(x)
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
end subroutine
end module
program interfaceCheck
use testsub
use sub
integer :: a
call test(subActual) ! { dg-error "Type/rank mismatch in argument" }
end program
! { dg-final { cleanup-modules "sub testsub" } }
...@@ -23,6 +23,7 @@ program bsp ...@@ -23,6 +23,7 @@ program bsp
interface interface
function p3(x) function p3(x)
real(8) :: p3,x real(8) :: p3,x
intent(in) :: x
end function p3 end function p3
end interface end interface
......
...@@ -114,7 +114,7 @@ contains ...@@ -114,7 +114,7 @@ contains
pointer :: f pointer :: f
interface interface
integer function f(x) integer function f(x)
integer :: x integer,intent(in) :: x
end function end function
end interface end interface
f => iabs f => iabs
...@@ -123,7 +123,7 @@ contains ...@@ -123,7 +123,7 @@ contains
function g() function g()
interface interface
integer function g(x) integer function g(x)
integer :: x integer,intent(in) :: x
end function g end function g
end interface end interface
pointer :: g pointer :: g
...@@ -133,13 +133,13 @@ contains ...@@ -133,13 +133,13 @@ contains
function h(arg) function h(arg)
interface interface
subroutine arg(b) subroutine arg(b)
integer :: b integer,intent(inout) :: b
end subroutine arg end subroutine arg
end interface end interface
pointer :: h pointer :: h
interface interface
subroutine h(a) subroutine h(a)
integer :: a integer,intent(inout) :: a
end subroutine h end subroutine h
end interface end interface
h => arg h => arg
...@@ -150,6 +150,7 @@ contains ...@@ -150,6 +150,7 @@ contains
interface interface
function i(x) function i(x)
integer :: i,x integer :: i,x
intent(in) :: x
end function i end function i
end interface end interface
i => iabs i => iabs
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment