re PR fortran/51605 (internal compiler error gfc_trans_block_construct, at fortran...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9d7d7c744efe13aca30a9d49582103d6ab81cb83..e5e8e7fe340dff92c924fa2cd82e060464ed8aae 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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.

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0e12730015013b8fb3d6c7659aa214be8e0acec8..fd91921c9793004a2a0a17b228ea970a4355b49c 100644 (file)
--- 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 afc4684682fd5514523feb9331c735f523514727..f79ed228d2f8193a96f9ab0a31f51842dda7de6c 100644 (file)
--- 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 5e8371a622b285bd1e54ed613f84a365e26f8bbc..4bfdb7987bf9d53be2958a22ab454fd30acb947e 100644 (file)
--- 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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b1a3762b47516d2d696dc6b31ef94d6ac67b2839..57a5dc844ac73fa10cf200cc52aa1768002f24fd 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/select_type_25.f90 b/gcc/testsuite/gfortran.dg/select_type_25.f90
new file mode 100644 (file)
index 0000000..45fe9af
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_25.f90
@@ -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