2018-10-15 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/87566
* resolve.c (resolve_assoc_var): Add missing array spec for
class associate names.
(resolve_select_type): Handle case where last typed component
of the selector has a different type to the expression.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
call to gfc_expr_to_initialize with call to gfc_copy_expr.
(gfc_conv_class_to_class): Guard assignment to 'len' field
against case where zero constant is supplied.
2018-10-15 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/87566
* gfortran.dg/select_type_44.f90: New test.
* gfortran.dg/associate_42.f90: New test.
Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>
From-SVN: r265171
+2018-10-15 Paul Thomas <pault@gcc.gnu.org>
+ Tobias Burnus <burnus@gcc.gnu.org>
+
+ PR fortran/87566
+ * resolve.c (resolve_assoc_var): Add missing array spec for
+ class associate names.
+ (resolve_select_type): Handle case where last typed component
+ of the selector has a different type to the expression.
+ * trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
+ call to gfc_expr_to_initialize with call to gfc_copy_expr.
+ (gfc_conv_class_to_class): Guard assignment to 'len' field
+ against case where zero constant is supplied.
+
2018-10-12 Tobias Burnus <burnus@net-b.de>
PR fortran/87597
if (as->corank != 0)
sym->attr.codimension = 1;
}
+ else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+ {
+ if (!CLASS_DATA (sym)->as)
+ CLASS_DATA (sym)->as = gfc_get_array_spec ();
+ as = CLASS_DATA (sym)->as;
+ as->rank = target->rank;
+ as->type = AS_DEFERRED;
+ as->corank = gfc_get_corank (target);
+ CLASS_DATA (sym)->attr.dimension = 1;
+ if (as->corank != 0)
+ CLASS_DATA (sym)->attr.codimension = 1;
+ }
}
else
{
if (code->expr2)
{
- if (code->expr1->symtree->n.sym->attr.untyped)
- code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ gfc_ref *ref2 = NULL;
+ for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ ref2 = ref;
+
+ if (ref2)
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = ref->u.c.component->ts;
+ selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
+ }
+ else
+ {
+ if (code->expr1->symtree->n.sym->attr.untyped)
+ code->expr1->symtree->n.sym->ts = code->expr2->ts;
+ selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ }
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
e->ref = NULL;
}
- base_expr = gfc_expr_to_initialize (e);
+ base_expr = gfc_copy_expr (e);
/* Restore the original tail expression. */
if (class_ref)
/* Return the len component, except in the case of scalarized array
references, where the dynamic type cannot change. */
- if (!elemental && full_array && copyback)
+ if (!elemental && full_array && copyback
+ && (UNLIMITED_POLY (e) || VAR_P (tmp)))
gfc_add_modify (&parmse->post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}
+2018-10-15 Paul Thomas <pault@gcc.gnu.org>
+ Tobias Burnus <burnus@gcc.gnu.org>
+
+ PR fortran/87566
+ * gfortran.dg/select_type_44.f90: New test.
+ * gfortran.dg/associate_42.f90: New test.
+
2018-10-15 Bin Cheng <bin.cheng@linux.alibaba.com>
PR tree-optimization/87022
--- /dev/null
+! { dg-do run }
+!
+! Tests the fix for a bug that was found in the course of fixing PR87566.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ call AddArray
+contains
+ subroutine AddArray()
+ type Object_array_pointer
+ class(*), pointer :: p(:) => null()
+ end type Object_array_pointer
+
+ type (Object_array_pointer) :: obj
+ character(3), target :: tgt1(2) = ['one','two']
+ character(5), target :: tgt2(2) = ['three','four ']
+ real, target :: tgt3(3) = [1.0,2.0,3.0]
+
+ obj%p => tgt1
+ associate (point => obj%p)
+ select type (point) ! Used to ICE here.
+ type is (character(*))
+ if (any (point .ne. tgt1)) stop 1
+ end select
+ point => tgt2
+ end associate
+
+ select type (z => obj%p)
+ type is (character(*))
+ if (any (z .ne. tgt2)) stop 2
+ end select
+
+ obj%p => tgt3
+ associate (point => obj%p)
+ select type (point)
+ type is (real)
+ if (any (point .ne. tgt3)) stop 3
+ end select
+ end associate
+ end subroutine AddArray
+end
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR87566
+!
+! Contributed by Antony Lewis <antony@cosmologist.info>
+!
+ call AddArray
+contains
+ subroutine AddArray()
+ type Object_array_pointer
+ class(*), pointer :: p(:) => null()
+ end type Object_array_pointer
+ class(*), pointer :: Pt => null()
+ type (Object_array_pointer) :: obj
+ character(3), target :: tgt1(2) = ['one','two']
+ character(5), target :: tgt2(2) = ['three','four ']
+
+ allocate (Pt, source = Object_array_pointer ())
+ select type (Pt)
+ type is (object_array_pointer)
+ Pt%p => tgt1
+ end select
+
+ select type (Pt)
+ class is (object_array_pointer)
+ select type (Point=> Pt%P)
+ type is (character(*))
+ if (any (Point .ne. tgt1)) stop 1
+ Point = ['abc','efg']
+ end select
+ end select
+
+ select type (Pt)
+ class is (object_array_pointer)
+ select type (Point=> Pt%P)
+ type is (character(*))
+ if (any (Point .ne. ['abc','efg'])) stop 2
+ end select
+ end select
+
+ end subroutine AddArray
+end
projects / gcc.git / commitdiff