+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>
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
/* Basically make this into
-
+
if (present)
{
if (contiguous)
}
}
-/* 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. */
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);
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. */
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
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);
+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
* 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>
--- /dev/null
+! { 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