re PR fortran/90786 (ICE on procedure pointer assignment to function with class pointer result)
2019-06-08 Paul Thomas <pault@gcc.gnu.org> PR fortran/90786 * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as it is very simple and only called from one place. (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign as non_proc_ptr_assign. Assign to it directly, rather than call to above, deleted function and use gfc_expr_attr instead of only checking the reference chain. 2019-06-08 Paul Thomas <pault@gcc.gnu.org> PR fortran/90786 * gfortran.dg/proc_ptr_51.f90 : New test. From-SVN: r272084
This commit is contained in:
Paul Thomas
parent
ec332875f8
commit
8e73afcf40
4 changed files with 61 additions and 23 deletions
|
|
@ -1,3 +1,13 @@
|
|||
2019-06-08 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/90786
|
||||
* trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
|
||||
it is very simple and only called from one place.
|
||||
(gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
|
||||
as non_proc_ptr_assign. Assign to it directly, rather than call
|
||||
to above, deleted function and use gfc_expr_attr instead of
|
||||
only checking the reference chain.
|
||||
|
||||
2019-06-08 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
Tomáš Trnka <trnka@scm.com>
|
||||
|
||||
|
|
|
|||
|
|
@ -4881,7 +4881,7 @@ class_array_fcn:
|
|||
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
|
||||
|
||||
/* Basically make this into
|
||||
|
||||
|
||||
if (present)
|
||||
{
|
||||
if (contiguous)
|
||||
|
|
@ -8979,23 +8979,6 @@ trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
|
|||
}
|
||||
}
|
||||
|
||||
/* Indentify class valued proc_pointer assignments. */
|
||||
|
||||
static bool
|
||||
pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
|
||||
{
|
||||
gfc_ref * ref;
|
||||
|
||||
ref = expr1->ref;
|
||||
while (ref && ref->next)
|
||||
ref = ref->next;
|
||||
|
||||
return ref && ref->type == REF_COMPONENT
|
||||
&& ref->u.c.component->attr.proc_pointer
|
||||
&& expr2->expr_type == EXPR_VARIABLE
|
||||
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
|
||||
}
|
||||
|
||||
|
||||
/* Do everything that is needed for a CLASS function expr2. */
|
||||
|
||||
|
|
@ -9048,7 +9031,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
tree desc;
|
||||
tree tmp;
|
||||
tree expr1_vptr = NULL_TREE;
|
||||
bool scalar, non_proc_pointer_assign;
|
||||
bool scalar, non_proc_ptr_assign;
|
||||
gfc_ss *ss;
|
||||
|
||||
gfc_start_block (&block);
|
||||
|
|
@ -9056,7 +9039,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
gfc_init_se (&lse, NULL);
|
||||
|
||||
/* Usually testing whether this is not a proc pointer assignment. */
|
||||
non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
|
||||
non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
|
||||
&& expr2->expr_type == EXPR_VARIABLE
|
||||
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
|
||||
|
||||
/* Check whether the expression is a scalar or not; we cannot use
|
||||
expr1->rank as it can be nonzero for proc pointers. */
|
||||
|
|
@ -9066,7 +9051,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
gfc_free_ss_chain (ss);
|
||||
|
||||
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
|
||||
&& expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
|
||||
&& expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
|
||||
{
|
||||
gfc_add_data_component (expr2);
|
||||
/* The following is required as gfc_add_data_component doesn't
|
||||
|
|
@ -9086,7 +9071,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
else
|
||||
gfc_conv_expr (&rse, expr2);
|
||||
|
||||
if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
|
||||
if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
|
||||
{
|
||||
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
|
||||
NULL);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2019-06-08 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/90786
|
||||
* gfortran.dg/proc_ptr_51.f90 : New test.
|
||||
|
||||
2019-06-08 Marek Polacek <polacek@redhat.com>
|
||||
|
||||
PR c++/52269
|
||||
|
|
@ -57,7 +62,7 @@
|
|||
* gfortran.dg/fmt_f_default_field_width_3.f90: Modify dg-error
|
||||
to allow use when kind=16 is not supported.
|
||||
* gfortran.dg/fmt_g_default_field_width_3.f90: Modify dg-error
|
||||
to allow use when kind=16 is not supported.
|
||||
to allow use when kind=16 is not supported.
|
||||
|
||||
2019-06-07 Richard Biener <rguenther@suse.de>
|
||||
|
||||
|
|
|
|||
38
gcc/testsuite/gfortran.dg/proc_ptr_51.f90
Normal file
38
gcc/testsuite/gfortran.dg/proc_ptr_51.f90
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR90786.
|
||||
!
|
||||
! Contributed by Andrew benson <abensonca@gmail.com>
|
||||
!
|
||||
module f
|
||||
procedure(c), pointer :: c_
|
||||
|
||||
type :: s
|
||||
integer :: i = 42
|
||||
end type s
|
||||
class(s), pointer :: res, tgt
|
||||
|
||||
contains
|
||||
|
||||
function c()
|
||||
implicit none
|
||||
class(s), pointer :: c
|
||||
c => tgt
|
||||
return
|
||||
end function c
|
||||
|
||||
subroutine fs()
|
||||
implicit none
|
||||
c_ => c ! This used to ICE
|
||||
return
|
||||
end subroutine fs
|
||||
|
||||
end module f
|
||||
|
||||
use f
|
||||
allocate (tgt, source = s(99))
|
||||
call fs()
|
||||
res => c_()
|
||||
if (res%i .ne. 99) stop 1
|
||||
deallocate (tgt)
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue