[Patch, Fortran] PR55763 fix .mod reading plus CALL with CLASS(*)

[Patch, Fortran] PR55763 fix .mod reading plus CALL with CLASS(*)

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 266 bytes --]

Another two fixes for CLASS(*). (We really should audit all calls to 
gfc_find_derived_vtab for possible issues with CLASS(*).)

If I haven't miscounted, there is still one other failure in the PR.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

[-- Attachment #2: unlimited-default.diff --]
[-- Type: text/x-patch, Size: 3037 bytes --]

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.

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 168f933..a797f24 100644
--- 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..cf130a3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8484,7 +8511,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
--- 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/gfortran.dg/unlimited_polymorphic_6.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_6.f90
new file mode 100644
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

Re: [Patch, Fortran] PR55763 fix .mod reading plus CALL with CLASS(*)

[Paul Richard Thomas]

Dear Tobias,

I did this one myself on the plane to the UK last night!  We came to
the same patch, so yes it's OK for trunk.

Thanks

Paul

On 21 December 2012 22:41, Tobias Burnus <burnus@net-b.de> wrote:
> Another two fixes for CLASS(*). (We really should audit all calls to
> gfc_find_derived_vtab for possible issues with CLASS(*).)
>
> If I haven't miscounted, there is still one other failure in the PR.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy