Commit 4038d0fb by Tobias Burnus Committed by Tobias Burnus

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
parent 409a5e7e
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> 2012-12-21 Richard Biener <rguenther@suse.de>
PR bootstrap/54659 PR bootstrap/54659
......
...@@ -2603,7 +2603,8 @@ mio_component (gfc_component *c, int vtype) ...@@ -2603,7 +2603,8 @@ mio_component (gfc_component *c, int vtype)
c->attr.class_ok = 1; c->attr.class_ok = 1;
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 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); mio_expr (&c->initializer);
if (c->attr.proc_pointer) if (c->attr.proc_pointer)
......
...@@ -8484,7 +8484,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ...@@ -8484,7 +8484,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
gfc_expr *e; gfc_expr *e;
ivtab = gfc_find_intrinsic_vtab (&c->ts); ivtab = gfc_find_intrinsic_vtab (&c->ts);
gcc_assert (ivtab); gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
e = CLASS_DATA (ivtab)->initializer; e = CLASS_DATA (ivtab)->initializer;
c->low = c->high = gfc_copy_expr (e); c->low = c->high = gfc_copy_expr (e);
} }
......
...@@ -4302,7 +4302,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -4302,7 +4302,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
null_pointer_node); null_pointer_node);
gfc_add_expr_to_block (&block, tmp); 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; gfc_symbol *vtab;
vtab = gfc_find_derived_vtab (fsym->ts.u.derived); vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
......
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> 2012-12-21 Martin Jambor <mjambor@suse.cz>
PR tree-optimization/55355 PR tree-optimization/55355
......
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment