This patch addresses three issues:
a) For SELECT TYPE: If the selector has the pointer attribute, the
associate name is a nonpointer, but it gets the target attribute.
(Rejects-valid issue; was accepted [for the wrong reasons] before PR
48887 got fixed.)
b) The example "one" is invalid, but the ICE came before the error was
printed. After adding three "&& attr.class_ok", the ICE is gone.
c) Some preparatory patches for SELECT TYPE support of polymorphic
coarrays. (Using them will still fail.)
The ICE with the original test case of the PR is not yet fixed. (It's a
BLOCK label issue, unrelated to polymorphism.)
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
2011-12-19 Tobias Burnus <bur...@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 <bur...@net-b.de>
PR fortran/51605
* gfortran.dg/select_type_25.f90: New.
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0e12730..fd91921 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -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;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index afc4684..f79ed22 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -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))
{
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 5e8371a..4bfdb79 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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)
--- /dev/null 2011-12-19 07:31:56.575697380 +0100
+++ gcc/gcc/testsuite/gfortran.dg/select_type_25.f90 2011-12-19 15:03:56.000000000 +0100
@@ -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
