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>
|
2013-01-12 Janus Weil <janus@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/55072
|
PR fortran/55072
|
||||||
|
|
|
@ -3506,7 +3506,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
||||||
if (comp)
|
if (comp)
|
||||||
s1 = comp->ts.interface;
|
s1 = comp->ts.interface;
|
||||||
else
|
else
|
||||||
s1 = lvalue->symtree->n.sym;
|
{
|
||||||
|
s1 = lvalue->symtree->n.sym;
|
||||||
|
if (s1->ts.interface)
|
||||||
|
s1 = s1->ts.interface;
|
||||||
|
}
|
||||||
|
|
||||||
comp = gfc_get_proc_ptr_comp (rvalue);
|
comp = gfc_get_proc_ptr_comp (rvalue);
|
||||||
if (comp)
|
if (comp)
|
||||||
|
@ -3514,7 +3518,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
||||||
if (rvalue->expr_type == EXPR_FUNCTION)
|
if (rvalue->expr_type == EXPR_FUNCTION)
|
||||||
{
|
{
|
||||||
s2 = comp->ts.interface->result;
|
s2 = comp->ts.interface->result;
|
||||||
name = comp->ts.interface->result->name;
|
name = s2->name;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
|
@ -3525,16 +3529,30 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
||||||
else if (rvalue->expr_type == EXPR_FUNCTION)
|
else if (rvalue->expr_type == EXPR_FUNCTION)
|
||||||
{
|
{
|
||||||
s2 = rvalue->symtree->n.sym->result;
|
s2 = rvalue->symtree->n.sym->result;
|
||||||
name = rvalue->symtree->n.sym->result->name;
|
name = s2->name;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
s2 = rvalue->symtree->n.sym;
|
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)
|
||||||
err, sizeof(err), NULL, NULL))
|
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 "
|
gfc_error ("Interface mismatch in procedure pointer assignment "
|
||||||
"at %L: %s", &rvalue->where, err);
|
"at %L: %s", &rvalue->where, err);
|
||||||
|
|
|
@ -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>
|
2013-01-13 Richard Sandiford <rdsandiford@googlemail.com>
|
||||||
|
|
||||||
* gcc.dg/unroll_5.c: Add nomips16 attributes.
|
* 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