re PR fortran/55763 (Issues with some simpler CLASS(*) programs)

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.

From-SVN: r194696

gcc/fortran/ChangeLog

+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

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)

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);
 	}

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);

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90

+! { 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