re PR fortran/48887 ([OOP] SELECT TYPE: Associate name shall not be a pointer/alloca...

2011-12-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48887
        * match.c (select_type_set_tmp): Don't set allocatable/pointer
        attribute.
        * class.c (gfc_build_class_symbol): Handle
        attr.select_type_temporary.

2011-12-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48887
        * gfortran.dg/select_type_24.f90: New.
        * gfortran.dg/select_type_23.f03: Add dg-error.
        * gfortran.dg/class_45a.f03: Add missing TARGET attribute.

From-SVN: r181975

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bec5430f8f14c4d31a47e1fb021bec5f0235191a..fbe15b03218e74e3500ff5f7cd260ccd4d1c09ad 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48887
+       * match.c (select_type_set_tmp): Don't set allocatable/pointer
+       attribute.
+       * class.c (gfc_build_class_symbol): Handle
+       attr.select_type_temporary.
+
 2011-12-03  Tobias Burnus  <burnus@net-b.de>                                                                                                           
 
        PR fortran/50684

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index bcb2d0b76bcff8385a6895937dd0b6af3ac03f76..d3f7bf3ab4c153482b2e83b505aa64320c3d2c17 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -188,7 +188,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     /* Class container has already been built.  */
     return SUCCESS;
 
-  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;
+  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
+                  || attr->select_type_temporary;
   
   if (!attr->class_ok)
     /* We can not build the class container yet.  */
@@ -239,7 +240,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
       c->attr.class_pointer = attr->pointer;
-      c->attr.pointer = attr->pointer || attr->dummy;
+      c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
+                       || attr->select_type_temporary;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
       c->attr.codimension = attr->codimension;

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index fbafe82cc6659e2f7c6d399217798676dc18d4ca..3de9c72571eedf188d20a54cc5f1bb3607366802 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5152,16 +5152,11 @@ select_type_set_tmp (gfc_typespec *ts)
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
   gfc_set_sym_referenced (tmp->n.sym);
-  if (select_type_stack->selector->ts.type == BT_CLASS &&
-      CLASS_DATA (select_type_stack->selector)->attr.allocatable)
-    gfc_add_allocatable (&tmp->n.sym->attr, NULL);
-  else
-    gfc_add_pointer (&tmp->n.sym->attr, NULL);
   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  tmp->n.sym->attr.select_type_temporary = 1;
   if (ts->type == BT_CLASS)
     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
                            &tmp->n.sym->as, false);
-  tmp->n.sym->attr.select_type_temporary = 1;
 
   /* Add an association for it, so the rest of the parser knows it is
      an associate-name.  The target will be set during resolution.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ffe51d3e9bcf94fe8698d2a5ebb3f78a66395451..c7cfa2c430e774670b3617587b4bdd007ac9142a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48887
+       * gfortran.dg/select_type_24.f90: New.
+       * gfortran.dg/select_type_23.f03: Add dg-error.
+       * gfortran.dg/class_45a.f03: Add missing TARGET attribute.
+
 2011-12-03  Jakub Jelinek  <jakub@redhat.com>
 
        * gcc.dg/vect/vect-122.c: New test.

diff --git a/gcc/testsuite/gfortran.dg/class_45a.f03 b/gcc/testsuite/gfortran.dg/class_45a.f03
index af8932a6b18b0fd57296bfd535740bd13f41852a..91f11c4ecce9d5945247dc18133359246e393db4 100644 (file)
--- a/gcc/testsuite/gfortran.dg/class_45a.f03
+++ b/gcc/testsuite/gfortran.dg/class_45a.f03
@@ -18,7 +18,7 @@ contains
   function basicGet(self)
     implicit none
     class(t0), pointer :: basicGet
-    class(t0), intent(in) :: self
+    class(t0), target, intent(in) :: self
     select type (self)
     type is (t1)
        basicGet => self

diff --git a/gcc/testsuite/gfortran.dg/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03
index d7788d2f4945c637b4067d521f76d55f9710f477..ced853745f4ffac042da40059c1eba7ddaf7f968 100644 (file)
--- a/gcc/testsuite/gfortran.dg/select_type_23.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_23.f03
@@ -3,6 +3,8 @@
 ! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE
 !
 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+! Updated for PR fortran/48887
 
 program testmv2
 
@@ -16,7 +18,7 @@ program testmv2
 
   select type(sm2) 
   type is (bar)
-    call move_alloc(sm2,sm)
+    call move_alloc(sm2,sm) ! { dg-error "must be ALLOCATABLE" }
   end select
 
 end program testmv2

diff --git a/gcc/testsuite/gfortran.dg/select_type_24.f90 b/gcc/testsuite/gfortran.dg/select_type_24.f90
new file mode 100644 (file)
index 0000000..e47d000
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_24.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+!
+! PR fortran/48887
+!
+! "If the selector is allocatable, it shall be allocated; the
+!  associate name is associated with the data object and does
+!  not have the ALLOCATABLE attribute."
+!
+module m
+  type t
+  end type t
+contains
+  subroutine one(a)
+    class(t), allocatable :: a
+    class(t), allocatable :: b
+    allocate (b)
+    select type (b)
+      type is(t)
+        call move_alloc (b, a) ! { dg-error "must be ALLOCATABLE" }
+    end select
+  end subroutine one
+
+  subroutine two (a)
+    class(t), allocatable :: a
+    type(t), allocatable :: b
+    allocate (b)
+    associate (c => b)
+      call move_alloc (b, c) ! { dg-error "must be ALLOCATABLE" }
+    end associate
+  end subroutine two
+end module m
+
+type t
+end type t
+class(t), allocatable :: x
+
+select type(x)
+  type is(t)
+    print *, allocated (x) ! { dg-error "must be ALLOCATABLE" }
+end select
+
+select type(y=>x)
+  type is(t)
+    print *, allocated (y)  ! { dg-error "must be ALLOCATABLE" }
+end select
+
+associate (y=>x)
+  print *, allocated (y)  ! { dg-error "must be ALLOCATABLE" }
+end associate
+end