2012-12-21 Tobias Burnus <burnus@net-b.de>

        PR fortran/55763
        * module.c (mio_component): Don't skip _hash's initializer.
        * resolve.c (resolve_select_type): Add an assert.
        * trans-expr.c (gfc_conv_procedure_call): Handle
        INTENT(OUT) for UNLIMIT_POLY.

2012-12-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/unlimited_polymorphic_6.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194696 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6d98c8c..4a84e1d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2012-12-22  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/55763
+       * module.c (mio_component): Don't skip _hash's initializer.
+       * resolve.c (resolve_select_type): Add an assert.
+       * trans-expr.c (gfc_conv_procedure_call): Handle
+       INTENT(OUT) for UNLIMIT_POLY.
+
 2012-12-21  Richard Biener  <rguenther@suse.de>
 
        PR bootstrap/54659

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 168f933..a797f24 100644 (file)
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2603,7 +2603,8 @@ mio_component (gfc_component *c, int vtype)
     c->attr.class_ok = 1;
   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
 
-  if (!vtype || strcmp (c->name, "_final") == 0)
+  if (!vtype || strcmp (c->name, "_final") == 0
+      || strcmp (c->name, "_hash") == 0)
     mio_expr (&c->initializer);
 
   if (c->attr.proc_pointer)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fce6f73..77d3dc5 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8484,7 +8484,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
          gfc_expr *e;
 
          ivtab = gfc_find_intrinsic_vtab (&c->ts);
-         gcc_assert (ivtab);
+         gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
          e = CLASS_DATA (ivtab)->initializer;
          c->low = c->high = gfc_copy_expr (e);
        }

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index ad26684..452f2bc 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4302,7 +4302,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                             null_pointer_node);
                      gfc_add_expr_to_block (&block, tmp);
 
-                     if (fsym->ts.type == BT_CLASS)
+                     if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
+                       {
+                         gfc_add_modify (&block, ptr,
+                                         fold_convert (TREE_TYPE (ptr),
+                                                       null_pointer_node));
+                         gfc_add_expr_to_block (&block, tmp);
+                       }
+                     else if (fsym->ts.type == BT_CLASS)
                        {
                          gfc_symbol *vtab;
                          vtab = gfc_find_derived_vtab (fsym->ts.u.derived);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3fa83c2..0f3d89f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-12-22  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/55763
+       * gfortran.dg/unlimited_polymorphic_6.f90: New.
+
 2012-12-21  Martin Jambor  <mjambor@suse.cz>
 
        PR tree-optimization/55355

diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90
new file mode 100644 (file)
index 0000000..a64f4e3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90
@@ -0,0 +1,37 @@
+! { dg-do run }
+!
+! PR fortran/55763
+!
+! Contributed by Reinhold Bader
+!
+module mod_alloc_scalar_01
+contains
+  subroutine construct(this)
+    class(*), allocatable, intent(out) :: this
+    integer :: this_i
+    this_i = 4
+    allocate(this, source=this_i)
+  end subroutine
+end module
+
+program alloc_scalar_01
+  use mod_alloc_scalar_01
+  implicit none
+  class(*), allocatable :: mystuff
+
+  call construct(mystuff)
+  call construct(mystuff)
+
+  select type(mystuff)
+  type is (integer)
+    if (mystuff == 4) then
+!      write(*,*) 'OK'
+    else 
+      call abort()
+!     write(*,*) 'FAIL 1'
+    end if
+  class default
+    call abort()
+!    write(*,*) 'FAIL 2'
+  end select
+end program