re PR fortran/51605 (internal compiler error gfc_trans_block_construct, at fortran/trans-stmt.c:984)
2011-12-19 Tobias Burnus <burnus@net-b.de> PR fortran/51605 * match.c (gfc_match_select_type): Handle scalar polymophic coarrays. (select_type_set_tmp, ): Ditto; avoid segfault if !class_ok. * primary.c (gfc_match_rvalue): Avoid segfault if !class_ok. * resolve.c (resolve_select_type): Ditto. (resolve_assoc_var): Fix setting the TARGET attribute for polymorphic selectors which are pointers. 2011-12-19 Tobias Burnus <burnus@net-b.de> PR fortran/51605 * gfortran.dg/select_type_25.f90: New. From-SVN: r182484
This commit is contained in:
parent
6a9ceb1703
commit
cd99c23ca4
|
@ -1,3 +1,14 @@
|
|||
2011-12-19 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/51605
|
||||
* match.c (gfc_match_select_type): Handle
|
||||
scalar polymophic coarrays.
|
||||
(select_type_set_tmp, ): Ditto; avoid segfault if !class_ok.
|
||||
* primary.c (gfc_match_rvalue): Avoid segfault if !class_ok.
|
||||
* resolve.c (resolve_select_type): Ditto.
|
||||
(resolve_assoc_var): Fix setting the TARGET attribute for
|
||||
polymorphic selectors which are pointers.
|
||||
|
||||
2011-12-19 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
* check.c (coarray_check): Add class ref if needed.
|
||||
|
|
|
@ -5154,19 +5154,27 @@ select_type_set_tmp (gfc_typespec *ts)
|
|||
|
||||
/* Copy across the array spec to the selector, taking care as to
|
||||
whether or not it is a class object or not. */
|
||||
if (select_type_stack->selector->ts.type == BT_CLASS &&
|
||||
CLASS_DATA (select_type_stack->selector)->attr.dimension)
|
||||
if (select_type_stack->selector->ts.type == BT_CLASS
|
||||
&& select_type_stack->selector->attr.class_ok
|
||||
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|
||||
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
|
||||
{
|
||||
if (ts->type == BT_CLASS)
|
||||
{
|
||||
CLASS_DATA (tmp->n.sym)->attr.dimension = 1;
|
||||
CLASS_DATA (tmp->n.sym)->attr.dimension
|
||||
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
|
||||
CLASS_DATA (tmp->n.sym)->attr.codimension
|
||||
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
|
||||
CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
|
||||
CLASS_DATA (tmp->n.sym)->as
|
||||
= CLASS_DATA (select_type_stack->selector)->as;
|
||||
}
|
||||
else
|
||||
{
|
||||
tmp->n.sym->attr.dimension = 1;
|
||||
tmp->n.sym->attr.dimension
|
||||
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
|
||||
tmp->n.sym->attr.codimension
|
||||
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
|
||||
tmp->n.sym->as = gfc_get_array_spec ();
|
||||
tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
|
||||
}
|
||||
|
@ -5248,7 +5256,8 @@ gfc_match_select_type (void)
|
|||
&& expr1->ts.type != BT_UNKNOWN
|
||||
&& CLASS_DATA (expr1)
|
||||
&& (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
|
||||
&& CLASS_DATA (expr1)->attr.dimension
|
||||
&& (CLASS_DATA (expr1)->attr.dimension
|
||||
|| CLASS_DATA (expr1)->attr.codimension)
|
||||
&& expr1->ref
|
||||
&& expr1->ref->type == REF_ARRAY
|
||||
&& expr1->ref->next == NULL;
|
||||
|
|
|
@ -2914,7 +2914,7 @@ gfc_match_rvalue (gfc_expr **result)
|
|||
break;
|
||||
}
|
||||
|
||||
if (sym->ts.type == BT_CLASS
|
||||
if (sym->ts.type == BT_CLASS && sym->attr.class_ok
|
||||
&& (CLASS_DATA (sym)->attr.dimension
|
||||
|| CLASS_DATA (sym)->attr.codimension))
|
||||
{
|
||||
|
|
|
@ -7817,9 +7817,12 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
|
|||
sym->attr.asynchronous = tsym->attr.asynchronous;
|
||||
sym->attr.volatile_ = tsym->attr.volatile_;
|
||||
|
||||
sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
|
||||
if (tsym->ts.type == BT_CLASS)
|
||||
sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
|
||||
else
|
||||
sym->attr.target = tsym->attr.target || tsym->attr.pointer;
|
||||
|
||||
if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS)
|
||||
if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
|
||||
target->rank = sym->as ? sym->as->rank : 0;
|
||||
}
|
||||
|
||||
|
@ -7887,6 +7890,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
|
|||
return;
|
||||
}
|
||||
|
||||
if (!code->expr1->symtree->n.sym->attr.class_ok)
|
||||
return;
|
||||
|
||||
if (code->expr2)
|
||||
{
|
||||
if (code->expr1->symtree->n.sym->attr.untyped)
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2011-12-19 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/51605
|
||||
* gfortran.dg/select_type_25.f90: New.
|
||||
|
||||
2011-12-19 Martin Jambor <mjambor@suse.cz>
|
||||
|
||||
PR tree-optimization/51583
|
||||
|
|
|
@ -0,0 +1,71 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-fcoarray=single" }
|
||||
!
|
||||
! PR fortran/51605
|
||||
!
|
||||
|
||||
subroutine one()
|
||||
type t
|
||||
end type t
|
||||
! (a) Invalid (was ICEing before)
|
||||
class(t), target :: p1 ! { dg-error "must be dummy, allocatable or pointer" }
|
||||
class(t), pointer :: p2
|
||||
|
||||
select type(p1)
|
||||
type is(t)
|
||||
p2 => p1
|
||||
class is(t)
|
||||
p2 => p1
|
||||
end select
|
||||
end subroutine one
|
||||
|
||||
subroutine two()
|
||||
type t
|
||||
end type t
|
||||
class(t), allocatable, target :: p1 ! (b) Valid
|
||||
class(t), pointer :: p2
|
||||
|
||||
select type(p1)
|
||||
type is(t)
|
||||
p2 => p1
|
||||
class is(t)
|
||||
p2 => p1
|
||||
end select
|
||||
end subroutine two
|
||||
|
||||
subroutine three()
|
||||
type t
|
||||
end type t
|
||||
class(t), allocatable :: p1 ! (c) Invalid as not TARGET
|
||||
class(t), pointer :: p2
|
||||
|
||||
select type(p1)
|
||||
type is(t)
|
||||
p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
|
||||
class is(t)
|
||||
p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" }
|
||||
end select
|
||||
end subroutine three
|
||||
|
||||
subroutine four()
|
||||
type t
|
||||
end type t
|
||||
class(t), pointer :: p1 ! (d) Valid
|
||||
class(t), pointer :: p2
|
||||
|
||||
select type(p1)
|
||||
type is(t)
|
||||
p2 => p1
|
||||
class is(t)
|
||||
p2 => p1
|
||||
end select
|
||||
end subroutine four
|
||||
|
||||
subroutine caf(x)
|
||||
type t
|
||||
end type t
|
||||
class(t) :: x[*]
|
||||
select type(x)
|
||||
type is(t)
|
||||
end select
|
||||
end subroutine caf
|
Loading…
Reference in New Issue