diff mbox

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

Message ID 50D4D794.9030003@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Dec. 21, 2012, 9:41 p.m. UTC 
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

Comments

Paul Richard Thomas Dec. 22, 2012, 4:57 p.m. UTC | #1 
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
diff mbox

Patch

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