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
2012-12-21 Tobias Burnus <bur...@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 <bur...@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
