re PR fortran/54286 (Accepts invalid proc-pointer assignments involving proc-ptr function result)
2013-01-13 Paul Thomas <pault@gcc.gnu.org> PR fortran/54286 * expr.c (gfc_check_pointer_assign): Ensure that both lvalue and rvalue interfaces are presented to gfc_compare_interfaces. Simplify references to interface names by using the symbols themselves. Call gfc_compare_interfaces with s1 and s2 inter- changed to overcome the asymmetry of this function. Do not repeat the check for the presence of s1 and s2. 2013-01-13 Paul Thomas <pault@gcc.gnu.org> PR fortran/54286 * gfortran.dg/proc_ptr_result_8.f90 : New test. From-SVN: r195133
This commit is contained in:
parent
8816ac704c
commit
899d52c6e2
|
@ -1,3 +1,13 @@
|
|||
2013-01-13 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/54286
|
||||
* expr.c (gfc_check_pointer_assign): Ensure that both lvalue
|
||||
and rvalue interfaces are presented to gfc_compare_interfaces.
|
||||
Simplify references to interface names by using the symbols
|
||||
themselves. Call gfc_compare_interfaces with s1 and s2 inter-
|
||||
changed to overcome the asymmetry of this function. Do not
|
||||
repeat the check for the presence of s1 and s2.
|
||||
|
||||
2013-01-12 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/55072
|
||||
|
|
|
@ -3506,7 +3506,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
if (comp)
|
||||
s1 = comp->ts.interface;
|
||||
else
|
||||
{
|
||||
s1 = lvalue->symtree->n.sym;
|
||||
if (s1->ts.interface)
|
||||
s1 = s1->ts.interface;
|
||||
}
|
||||
|
||||
comp = gfc_get_proc_ptr_comp (rvalue);
|
||||
if (comp)
|
||||
|
@ -3514,7 +3518,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
if (rvalue->expr_type == EXPR_FUNCTION)
|
||||
{
|
||||
s2 = comp->ts.interface->result;
|
||||
name = comp->ts.interface->result->name;
|
||||
name = s2->name;
|
||||
}
|
||||
else
|
||||
{
|
||||
|
@ -3525,15 +3529,29 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
else if (rvalue->expr_type == EXPR_FUNCTION)
|
||||
{
|
||||
s2 = rvalue->symtree->n.sym->result;
|
||||
name = rvalue->symtree->n.sym->result->name;
|
||||
name = s2->name;
|
||||
}
|
||||
else
|
||||
{
|
||||
s2 = rvalue->symtree->n.sym;
|
||||
name = rvalue->symtree->n.sym->name;
|
||||
name = s2->name;
|
||||
}
|
||||
|
||||
if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
|
||||
if (s2->attr.proc_pointer && s2->ts.interface)
|
||||
s2 = s2->ts.interface;
|
||||
|
||||
if (s1 == s2 || !s1 || !s2)
|
||||
return SUCCESS;
|
||||
|
||||
if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
|
||||
err, sizeof(err), NULL, NULL))
|
||||
{
|
||||
gfc_error ("Interface mismatch in procedure pointer assignment "
|
||||
"at %L: %s", &rvalue->where, err);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (!gfc_compare_interfaces (s2, s1, name, 0, 1,
|
||||
err, sizeof(err), NULL, NULL))
|
||||
{
|
||||
gfc_error ("Interface mismatch in procedure pointer assignment "
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2013-01-13 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/54286
|
||||
* gfortran.dg/proc_ptr_result_8.f90 : New test.
|
||||
|
||||
2013-01-13 Richard Sandiford <rdsandiford@googlemail.com>
|
||||
|
||||
* gcc.dg/unroll_5.c: Add nomips16 attributes.
|
||||
|
|
|
@ -0,0 +1,45 @@
|
|||
! { dg-do compile }
|
||||
! Test fix for PR54286.
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
!
|
||||
implicit integer (a)
|
||||
type :: t
|
||||
procedure(a), pointer, nopass :: p
|
||||
end type
|
||||
type(t) :: x
|
||||
|
||||
procedure(iabs), pointer :: pp
|
||||
procedure(foo), pointer :: pp1
|
||||
|
||||
x%p => a ! ok
|
||||
if (x%p(0) .ne. loc(foo)) call abort
|
||||
if (x%p(1) .ne. loc(iabs)) call abort
|
||||
|
||||
x%p => a(1) ! { dg-error "PROCEDURE POINTER mismatch in function result" }
|
||||
|
||||
pp => a(1) ! ok
|
||||
if (pp(-99) .ne. iabs(-99)) call abort
|
||||
|
||||
pp1 => a(2) ! ok
|
||||
if (pp1(-99) .ne. -iabs(-99)) call abort
|
||||
|
||||
pp => a ! { dg-error "PROCEDURE POINTER mismatch in function result" }
|
||||
|
||||
contains
|
||||
|
||||
function a (c) result (b)
|
||||
integer, intent(in) :: c
|
||||
procedure(iabs), pointer :: b
|
||||
if (c .eq. 1) then
|
||||
b => iabs
|
||||
else
|
||||
b => foo
|
||||
end if
|
||||
end function
|
||||
|
||||
integer function foo (arg)
|
||||
integer, intent (in) :: arg
|
||||
foo = -iabs(arg)
|
||||
end function
|
||||
end
|
Loading…
Reference in New Issue