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

login
register
mail settings
Submitter Tobias Burnus
Date Dec. 21, 2012, 9:41 p.m.
Message ID <50D4D794.9030003@net-b.de>
Download mbox | patch
Permalink /patch/207879/
State New
Headers show

Comments

Tobias Burnus - Dec. 21, 2012, 9:41 p.m.
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
Paul Richard Thomas - Dec. 22, 2012, 4:57 p.m.
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

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